[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/12: Canonicalize <=, >=, and > primcalls to <
From: |
Andy Wingo |
Subject: |
[Guile-commits] 03/12: Canonicalize <=, >=, and > primcalls to < |
Date: |
Sat, 11 Nov 2017 16:12:24 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 7a7f71de5c609cff0a9b366ae0e894aa0e8182fe
Author: Andy Wingo <address@hidden>
Date: Thu Nov 9 12:52:31 2017 +0100
Canonicalize <=, >=, and > primcalls to <
* module/language/tree-il/compile-cps.scm (canonicalize): Convert <=,
>=, and > primcalls to <.
* module/language/cps/primitives.scm (*comparisons*):
* module/language/cps/effects-analysis.scm: Remove superfluous
primcalls.
* module/language/cps/specialize-numbers.scm
(specialize-u64-scm-comparison): Only emit < primcalls for ordered
comparisons.
(specialize-scm-u64-comparison): New helper.
* module/language/cps/specialize-numbers.scm (specialize-operations):
Remove support for >=, <=, and the like.
* module/language/cps/type-fold.scm: Remove folders for <= and so on.
* module/language/cps/types.scm (define-=-inferrer, define-<-inferrer):
New helpers; use them for all = and < variants. Remove checkers and
inferrers for <= and the like.
* module/language/cps/compile-bytecode.scm (compile-function): Remove
unnecessary cases.
---
module/language/cps/compile-bytecode.scm | 16 +--
module/language/cps/effects-analysis.scm | 12 ---
module/language/cps/primitives.scm | 20 +---
module/language/cps/specialize-numbers.scm | 48 +++++++--
module/language/cps/type-fold.scm | 24 -----
module/language/cps/types.scm | 151 +++++++----------------------
module/language/tree-il/compile-cps.scm | 18 ++++
7 files changed, 99 insertions(+), 190 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 8e61604..ed25148 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -421,8 +421,6 @@
(binary op emit-je emit-jne a b))
(define (binary-< emit-<? a b)
(binary emit-<? emit-jl emit-jnl a b))
- (define (binary->= emit-<? a b)
- (binary emit-<? emit-jge emit-jnge a b))
(match exp
(($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a))
(($ $primcall 'null? #f (a)) (unary emit-null? a))
@@ -447,25 +445,13 @@
(($ $primcall 'heap-numbers-equal? #f (a b))
(binary-test emit-heap-numbers-equal? a b))
(($ $primcall '< #f (a b)) (binary-< emit-<? a b))
- (($ $primcall '<= #f (a b)) (binary->= emit-<? b a))
(($ $primcall '= #f (a b)) (binary-test emit-=? a b))
- (($ $primcall '>= #f (a b)) (binary->= emit-<? a b))
- (($ $primcall '> #f (a b)) (binary-< emit-<? b a))
(($ $primcall 'u64-< #f (a b)) (binary-< emit-u64<? a b))
- (($ $primcall 'u64-<= #f (a b)) (binary->= emit-u64<? b a))
(($ $primcall 'u64-= #f (a b)) (binary-test emit-u64=? a b))
- (($ $primcall 'u64->= #f (a b)) (binary->= emit-u64<? a b))
- (($ $primcall 'u64-> #f (a b)) (binary-< emit-u64<? b a))
(($ $primcall 's64-< #f (a b)) (binary-< emit-s64<? a b))
- (($ $primcall 's64-<= #f (a b)) (binary->= emit-s64<? b a))
(($ $primcall 's64-= #f (a b)) (binary-test emit-s64=? a b))
- (($ $primcall 's64->= #f (a b)) (binary->= emit-s64<? a b))
- (($ $primcall 's64-> #f (a b)) (binary-< emit-s64<? b a))
(($ $primcall 'f64-< #f (a b)) (binary-< emit-f64<? a b))
- (($ $primcall 'f64-<= #f (a b)) (binary->= emit-f64<? b a))
- (($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))
- (($ $primcall 'f64->= #f (a b)) (binary->= emit-f64<? a b))
- (($ $primcall 'f64-> #f (a b)) (binary-< emit-f64<? b a))))
+ (($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))))
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index afcc39a..9a7f70d 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -421,24 +421,12 @@ is or might be a read or a write to the same location as
A."
((heap-numbers-equal? . _))
((= . _) &type-check)
((< . _) &type-check)
- ((> . _) &type-check)
- ((<= . _) &type-check)
- ((>= . _) &type-check)
((u64-= . _))
((u64-< . _))
- ((u64-> . _))
- ((u64-<= . _))
- ((u64->= . _))
((s64-= . _))
((s64-< . _))
- ((s64-> . _))
- ((s64-<= . _))
- ((s64->= . _))
((f64-= . _))
((f64-< . _))
- ((f64-> . _))
- ((f64-<= . _))
- ((f64->= . _))
((zero? . _) &type-check)
((add . _) &type-check)
((add/immediate . _) &type-check)
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index 3b0eb08..d9a6d58 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -130,28 +130,18 @@ before it is lowered to CPS?"
(define *comparisons*
'(eq?
heap-numbers-equal?
+
<
- <=
=
+
u64-<
- u64-<=
u64-=
+
s64-<
- s64-<=
s64-=
- f64-=
+
f64-<
- f64-<=
-
- ;; FIXME: Remove these.
- >
- >=
- u64->
- u64->=
- s64->
- s64->=
- f64->
- f64->=))
+ f64-=))
(define *branching-primcall-arities* (make-hash-table))
(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 1)))
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 9daa78a..48a0d20 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -207,8 +207,8 @@
($continue kf src
($branch kt ($primcall u64-op #f (u64 s64))))))
(letk kz64 ($kargs ('z64) (z64)
- ($continue (case op ((< <= =) kf) (else kt)) src
- ($branch kcmp ($primcall 's64-<= #f (z64 s64))))))
+ ($continue kcmp src
+ ($branch kf ($primcall 's64-< #f (s64 z64))))))
(letk ks64 ($kargs ('s64) (s64)
($continue kz64 src ($primcall 'load-s64 0 ()))))
(letk kfix ($kargs () ()
@@ -221,6 +221,40 @@
($continue ku64 src
($primcall 'scm->u64 #f (a-u64)))))))
+(define (specialize-scm-u64-comparison cps kf kt src op a-scm b-u64)
+ (match op
+ ('= (specialize-u64-scm-comparison cps kf kt src op b-u64 a-scm))
+ ('<
+ (with-cps cps
+ (letv u64 s64 z64 sunk)
+ (letk kheap ($kargs ('sunk) (sunk)
+ ($continue kf src
+ ($branch kt ($primcall '< #f (a-scm sunk))))))
+ ;; Re-box the variable. FIXME: currently we use a specially
+ ;; marked u64->scm to avoid CSE from hoisting the allocation
+ ;; again. Instaed we should just use a-u64 directly and implement
+ ;; an allocation sinking pass that should handle this..
+ (letk kretag ($kargs () ()
+ ($continue kheap src
+ ($primcall 'u64->scm/unlikely #f (u64)))))
+ (letk kcmp ($kargs () ()
+ ($continue kf src
+ ($branch kt ($primcall 'u64-< #f (s64 u64))))))
+ (letk kz64 ($kargs ('z64) (z64)
+ ($continue kcmp src
+ ($branch kt ($primcall 's64-< #f (s64 z64))))))
+ (letk ks64 ($kargs ('s64) (s64)
+ ($continue kz64 src ($primcall 'load-s64 0 ()))))
+ (letk kfix ($kargs () ()
+ ($continue ks64 src
+ ($primcall 'untag-fixnum #f (a-scm)))))
+ (letk ku64 ($kargs ('u64) (u64)
+ ($continue kretag src
+ ($branch kfix ($primcall 'fixnum? #f (a-scm))))))
+ (build-term
+ ($continue ku64 src
+ ($primcall 'scm->u64 #f (b-u64))))))))
+
(define (specialize-f64-comparison cps kf kt src op a b)
(let ((op (symbol-append 'f64- op)))
(with-cps cps
@@ -525,7 +559,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
types sigbits))))
(($ $kargs names vars
($ $continue k src
- ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) #f (a
b)))))
+ ($ $branch kt ($ $primcall (and op (or '< '=)) #f (a b)))))
(values
(cond
((f64-operands? a b)
@@ -540,11 +574,9 @@ BITS indicating the significant bits needed for a
variable. BITS may be
(let$ body (specialize k kt src op a b))
(setk label ($kargs names vars ,body)))))
((u64-operand? b)
- (let ((op (match op
- ('< '>) ('<= '>=) ('= '=) ('>= '<=) ('> '<))))
- (with-cps cps
- (let$ body (specialize-u64-scm-comparison k kt src op b a))
- (setk label ($kargs names vars ,body)))))
+ (with-cps cps
+ (let$ body (specialize-scm-u64-comparison k kt src op a b))
+ (setk label ($kargs names vars ,body))))
(else cps))
types
sigbits))
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index fdbefae..1e58009 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -152,14 +152,6 @@
;;
;; (define-branch-folder-alias f64-< <)
-(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
- (case (compare-ranges type0 min0 max0 type1 min1 max1)
- ((< <= =) (values #t #t))
- ((>) (values #t #f))
- (else (values #f #f))))
-(define-branch-folder-alias u64-<= <=)
-(define-branch-folder-alias s64-<= <=)
-
(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((=) (values #t #t))
@@ -168,22 +160,6 @@
(define-branch-folder-alias u64-= =)
(define-branch-folder-alias s64-= =)
-(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
- (case (compare-ranges type0 min0 max0 type1 min1 max1)
- ((> >= =) (values #t #t))
- ((<) (values #t #f))
- (else (values #f #f))))
-(define-branch-folder-alias u64->= >=)
-(define-branch-folder-alias s64->= >=)
-
-(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
- (case (compare-ranges type0 min0 max0 type1 min1 max1)
- ((>) (values #t #t))
- ((= <= <) (values #t #f))
- (else (values #f #f))))
-(define-branch-folder-alias u64-> >)
-(define-branch-folder-alias s64-> >)
-
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 9561d6d..267e9ef 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -956,132 +956,51 @@ minimum, and maximum."
;;; Numbers.
;;;
-;; First, branching primitives with no results.
-(define-simple-type-checker (= &number &number))
-(define-predicate-inferrer (= a b true?)
- (when (and true?
- (zero? (logand (logior (&type a) (&type b)) (lognot &number))))
- (let ((min (max (&min a) (&min b)))
- (max (min (&max a) (&max b))))
- (restrict! a &number min max)
- (restrict! b &number min max))))
-
-(define (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1)
- (define (infer-integer-ranges)
- (match op
- ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
- ('<= (values min0 (min max0 max1) (max min0 min1) max1))
- ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
- ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
- (define (infer-real-ranges)
- (match op
- ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1))
- ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1)))))
- (if (type<=? (logior type0 type1) &exact-integer)
- (infer-integer-ranges)
- (infer-real-ranges)))
-
-(define-syntax-rule (true-comparison-restrictions op a b a-type b-type)
- (call-with-values
- (lambda ()
- (restricted-comparison-ranges op
- (&type a) (&min a) (&max a)
- (&type b) (&min b) (&max b)))
- (lambda (min0 max0 min1 max1)
- (restrict! a a-type min0 max0)
- (restrict! b b-type min1 max1))))
-
-(define-syntax-rule (define-comparison-inferrer (op inverse))
+(define-syntax-rule (define-=-inferrer (op &domain))
(define-predicate-inferrer (op a b true?)
- (when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
- (true-comparison-restrictions (if true? 'op 'inverse) a b &real &real))))
+ (let ((types (logior (&type a) (&type b))))
+ (when (and true? (type<=? types &domain))
+ (let ((min (max (&min a) (&min b)))
+ (max (min (&max a) (&max b))))
+ (restrict! a &domain min max)
+ (restrict! b &domain min max))))))
+
+(define-syntax-rule (define-<-inferrer (op &domain &integer-domain))
+ (define-predicate-inferrer (op a b true?)
+ (let ((types (logior (&type a) (&type b))))
+ (when (type<=? types &domain)
+ (let ((int? (type<=? types &integer-domain))
+ (min0 (&min a)) (max0 (&max a))
+ (min1 (&min b)) (max1 (&max b)))
+ (cond
+ (true?
+ (restrict! a &domain
+ min0
+ (min max0 (if int? (1- max1) max1)))
+ (restrict! b &domain
+ (max (if int? (1+ min0) min0) min1)
+ max1))
+ (else
+ (restrict! a &domain (max min0 min1) max0)
+ (restrict! b &domain min1 (min max0 max1)))))))))
+(define-simple-type-checker (= &number &number))
+(define-=-inferrer (= &number))
(define-simple-type-checker (< &real &real))
-(define-comparison-inferrer (< >=))
-
-(define-simple-type-checker (<= &real &real))
-(define-comparison-inferrer (<= >))
-
-(define-simple-type-checker (>= &real &real))
-(define-comparison-inferrer (>= <))
-
-(define-simple-type-checker (> &real &real))
-(define-comparison-inferrer (> <=))
+(define-<-inferrer (< &real &exact-integer))
(define-simple-type-checker (u64-= &u64 &u64))
-(define-predicate-inferrer (u64-= a b true?)
- (when true?
- (let ((min (max (&min/0 a) (&min/0 b)))
- (max (min (&max/u64 a) (&max/u64 b))))
- (restrict! a &u64 min max)
- (restrict! b &u64 min max))))
-
-(define (infer-u64-comparison-ranges op min0 max0 min1 max1)
- (match op
- ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
- ('<= (values min0 (min max0 max1) (max min0 min1) max1))
- ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
- ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
-(define-syntax-rule (define-u64-comparison-inferrer (u64-op op inverse))
- (define-predicate-inferrer (u64-op a b true?)
- (call-with-values
- (lambda ()
- (infer-u64-comparison-ranges (if true? 'op 'inverse)
- (&min/0 a) (&max/u64 a)
- (&min/0 b) (&max/u64 b)))
- (lambda (min0 max0 min1 max1)
- (restrict! a &u64 min0 max0)
- (restrict! b &u64 min1 max1)))))
-
+(define-=-inferrer (u64-= &u64))
(define-simple-type-checker (u64-< &u64 &u64))
-(define-u64-comparison-inferrer (u64-< < >=))
-
-(define-simple-type-checker (u64-<= &u64 &u64))
-(define-u64-comparison-inferrer (u64-<= <= >))
-
-(define-simple-type-checker (u64->= &u64 &u64))
-(define-u64-comparison-inferrer (u64-<= >= <))
-
-(define-simple-type-checker (u64-> &u64 &u64))
-(define-u64-comparison-inferrer (u64-> > <=))
+(define-<-inferrer (u64-< &u64 &u64))
-;; Signed unboxed comparisons.
(define-simple-type-checker (s64-= &s64 &s64))
-(define-predicate-inferrer (s64-= a b true?)
- (when true?
- (let ((min (max (&min/s64 a) (&min/s64 b)))
- (max (min (&max/s64 a) (&max/s64 b))))
- (restrict! a &s64 min max)
- (restrict! b &s64 min max))))
-
-(define (infer-s64-comparison-ranges op min0 max0 min1 max1)
- (match op
- ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
- ('<= (values min0 (min max0 max1) (max min0 min1) max1))
- ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
- ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
-(define-syntax-rule (define-s64-comparison-inferrer (s64-op op inverse))
- (define-predicate-inferrer (s64-op a b true?)
- (call-with-values
- (lambda ()
- (infer-s64-comparison-ranges (if true? 'op 'inverse)
- (&min/s64 a) (&max/s64 a)
- (&min/s64 b) (&max/s64 b)))
- (lambda (min0 max0 min1 max1)
- (restrict! a &s64 min0 max0)
- (restrict! b &s64 min1 max1)))))
-
+(define-=-inferrer (s64-= &s64))
(define-simple-type-checker (s64-< &s64 &s64))
-(define-s64-comparison-inferrer (s64-< < >=))
-
-(define-simple-type-checker (s64-<= &s64 &s64))
-(define-s64-comparison-inferrer (s64-<= <= >))
-
-(define-simple-type-checker (s64->= &s64 &s64))
-(define-s64-comparison-inferrer (s64-<= >= <))
+(define-<-inferrer (s64-< &s64 &s64))
-(define-simple-type-checker (s64-> &s64 &s64))
-(define-s64-comparison-inferrer (s64-> > <=))
+;; Unfortunately, we can't define f64 comparison inferrers because of
+;; not-a-number values.
;; Arithmetic.
(define-syntax-rule (define-unary-result! a-type$ result min$ max$)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 9ff497a..c2b000e 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1050,6 +1050,24 @@ integer."
(($ <conditional>)
(reduce-conditional exp))
+ (($ <primcall> src '<= (a b))
+ ;; No need to reduce as < is a branching primitive.
+ (make-conditional src (make-primcall src '< (list b a))
+ (make-const src #f)
+ (make-const src #t)))
+
+ (($ <primcall> src '>= (a b))
+ ;; No need to reduce as < is a branching primitive.
+ (make-conditional src (make-primcall src '< (list a b))
+ (make-const src #f)
+ (make-const src #t)))
+
+ (($ <primcall> src '> (a b))
+ ;; No need to reduce as < is a branching primitive.
+ (make-conditional src (make-primcall src '< (list b a))
+ (make-const src #t)
+ (make-const src #f)))
+
(($ <primcall> src (? branching-primitive? name) args)
;; No need to reduce because test is not reducible: reifying
;; #t/#f is the right thing.
- [Guile-commits] branch master updated (f96a670 -> 83a03a3), Andy Wingo, 2017/11/11
- [Guile-commits] 01/12: Fix effects analysis bug introduced with primcall param, Andy Wingo, 2017/11/11
- [Guile-commits] 02/12: Refactor numeric comparison bytecode emission, Andy Wingo, 2017/11/11
- [Guile-commits] 05/12: Closure conversion uses immediate variants of vector instructions, Andy Wingo, 2017/11/11
- [Guile-commits] 06/12: Use immediate primcalls when unfolding constructors, Andy Wingo, 2017/11/11
- [Guile-commits] 09/12: Convert "ash" to "lsh"/"rsh" when lowering to CPS, Andy Wingo, 2017/11/11
- [Guile-commits] 12/12: Specialize rsh/lsh, not ash, Andy Wingo, 2017/11/11
- [Guile-commits] 07/12: Add tag-fixnum instruction, Andy Wingo, 2017/11/11
- [Guile-commits] 08/12: Compiler uses target fixnum range, Andy Wingo, 2017/11/11
- [Guile-commits] 03/12: Canonicalize <=, >=, and > primcalls to <,
Andy Wingo <=
- [Guile-commits] 11/12: Add missing lsh/immediate, rsh/immediate type inferrers, Andy Wingo, 2017/11/11
- [Guile-commits] 04/12: Specialize comparisons to SCM as s64, Andy Wingo, 2017/11/11
- [Guile-commits] 10/12: Type folding has "macro reduction" phase, Andy Wingo, 2017/11/11