[Guile-commits] 03/12: Canonicalize <=, >=, and > primcalls to <

[Andy Wingo]

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.