[Guile-commits] 01/08: Lower logtest branches to instead be 'zero? logand'

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 0d42f5467f9b0d7841af3043bca7ad53a6c6ee64
Author: Andy Wingo <address@hidden>
Date:   Mon Oct 30 10:14:48 2017 +0100

    Lower logtest branches to instead be 'zero? logand'
    
    * module/language/cps/compile-bytecode.scm (compile-function): Rename
      the binary* helper back to binary, update uses, and remove logtest
      branch as we no longer put logtest in test context.
    * module/language/cps/primitives.scm (*comparisons*): Remove logtest.
    * module/language/cps/type-fold.scm: Remove logtest folder.
      (logbit?): Fold to logand.
    * module/language/cps/types.scm (logtest): Update to be a type inferrer
      and not a predicate inferrer.
    * module/language/tree-il/peval.scm (peval): Transform logtest and
      logbit? to (zero? (logand _ _)).
---
 module/language/cps/compile-bytecode.scm | 51 ++++++++++++--------------------
 module/language/cps/primitives.scm       |  3 --
 module/language/cps/type-fold.scm        | 27 +++++++----------
 module/language/cps/types.scm            |  5 ++--
 module/language/tree-il/peval.scm        | 26 +++++++++-------
 5 files changed, 48 insertions(+), 64 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index f580551..a4150ac 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -411,23 +411,11 @@
       (define (unary op a)
         (op asm (from-sp (slot a)))
         (emit-branch emit-je emit-jne))
-      (define (binary-test op a b)
-        (op asm (from-sp (slot a)) (from-sp (slot b)))
-        (emit-branch emit-je emit-jne))
-      (define (binary* op emit-jt emit-jf a b)
+      (define (binary op emit-jt emit-jf a b)
         (op asm (from-sp (slot a)) (from-sp (slot b)))
         (emit-branch emit-jt emit-jf))
-      (define (binary op a b)
-        (cond
-         ((eq? kt next-label)
-          (op asm (from-sp (slot a)) (from-sp (slot b)) #t kf))
-         ((eq? kf next-label)
-          (op asm (from-sp (slot a)) (from-sp (slot b)) #f kt))
-         (else
-          (let ((invert? (not (prefer-true?))))
-            (op asm (from-sp (slot a)) (from-sp (slot b)) invert?
-                (if invert? kf kt))
-            (emit-j asm (if invert? kt kf))))))
+      (define (binary-test op a b)
+        (binary op emit-je emit-jne a b))
       (match exp
         (($ $primcall 'heap-object? (a)) (unary emit-heap-object? a))
         (($ $primcall 'null? (a)) (unary emit-null? a))
@@ -451,27 +439,26 @@
         (($ $primcall 'eq? (a b)) (binary-test emit-eq? a b))
         (($ $primcall 'heap-numbers-equal? (a b))
          (binary-test emit-heap-numbers-equal? a b))
-        (($ $primcall '< (a b)) (binary* emit-<? emit-jl emit-jnl a b))
-        (($ $primcall '<= (a b)) (binary* emit-<? emit-jge emit-jnge b a))
+        (($ $primcall '< (a b)) (binary emit-<? emit-jl emit-jnl a b))
+        (($ $primcall '<= (a b)) (binary emit-<? emit-jge emit-jnge b a))
         (($ $primcall '= (a b)) (binary-test emit-=? a b))
-        (($ $primcall '>= (a b)) (binary* emit-<? emit-jge emit-jnge a b))
-        (($ $primcall '> (a b)) (binary* emit-<? emit-jl emit-jnl b a))
-        (($ $primcall 'u64-< (a b)) (binary* emit-u64<? emit-jl emit-jnl a b))
-        (($ $primcall 'u64-<= (a b)) (binary* emit-u64<? emit-jnl emit-jl b a))
+        (($ $primcall '>= (a b)) (binary emit-<? emit-jge emit-jnge a b))
+        (($ $primcall '> (a b)) (binary emit-<? emit-jl emit-jnl b a))
+        (($ $primcall 'u64-< (a b)) (binary emit-u64<? emit-jl emit-jnl a b))
+        (($ $primcall 'u64-<= (a b)) (binary emit-u64<? emit-jnl emit-jl b a))
         (($ $primcall 'u64-= (a b)) (binary-test emit-u64=? a b))
-        (($ $primcall 'u64->= (a b)) (binary* emit-u64<? emit-jnl emit-jl a b))
-        (($ $primcall 'u64-> (a b)) (binary* emit-u64<? emit-jl emit-jnl b a))
-        (($ $primcall 's64-< (a b)) (binary* emit-s64<? emit-jl emit-jnl a b))
-        (($ $primcall 's64-<= (a b)) (binary* emit-s64<? emit-jnl emit-jl b a))
+        (($ $primcall 'u64->= (a b)) (binary emit-u64<? emit-jnl emit-jl a b))
+        (($ $primcall 'u64-> (a b)) (binary emit-u64<? emit-jl emit-jnl b a))
+        (($ $primcall 's64-< (a b)) (binary emit-s64<? emit-jl emit-jnl a b))
+        (($ $primcall 's64-<= (a b)) (binary emit-s64<? emit-jnl emit-jl b a))
         (($ $primcall 's64-= (a b)) (binary-test emit-s64=? a b))
-        (($ $primcall 's64->= (a b)) (binary* emit-s64<? emit-jnl emit-jl a b))
-        (($ $primcall 's64-> (a b)) (binary* emit-s64<? emit-jl emit-jnl b a))
-        (($ $primcall 'f64-< (a b)) (binary* emit-f64<? emit-jl emit-jnl a b))
-        (($ $primcall 'f64-<= (a b)) (binary* emit-f64<? emit-jge emit-jnge b 
a))
+        (($ $primcall 's64->= (a b)) (binary emit-s64<? emit-jnl emit-jl a b))
+        (($ $primcall 's64-> (a b)) (binary emit-s64<? emit-jl emit-jnl b a))
+        (($ $primcall 'f64-< (a b)) (binary emit-f64<? emit-jl emit-jnl a b))
+        (($ $primcall 'f64-<= (a b)) (binary emit-f64<? emit-jge emit-jnge b 
a))
         (($ $primcall 'f64-= (a b)) (binary-test emit-f64=? a b))
-        (($ $primcall 'f64->= (a b)) (binary* emit-f64<? emit-jge emit-jnge a 
b))
-        (($ $primcall 'f64-> (a b)) (binary* emit-f64<? emit-jl emit-jnl b a))
-        (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
+        (($ $primcall 'f64->= (a b)) (binary emit-f64<? emit-jge emit-jnge a 
b))
+        (($ $primcall 'f64-> (a b)) (binary emit-f64<? emit-jl emit-jnl b a))))
 
     (define (compile-trunc label k exp nreq rest-var)
       (define (do-call proc args emit-call)
diff --git a/module/language/cps/primitives.scm 
b/module/language/cps/primitives.scm
index c807472..8d07e0d 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -143,9 +143,6 @@ before it is lowered to CPS?"
     f64-<
     f64-<=
 
-    ;; FIXME: Expand these.
-    logtest
-
     ;; FIXME: Remove these.
     >
     >=
diff --git a/module/language/cps/type-fold.scm 
b/module/language/cps/type-fold.scm
index 5a79a7b..8086b0c 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -184,20 +184,6 @@
 (define-branch-folder-alias u64-> >)
 (define-branch-folder-alias s64-> >)
 
-(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
-  (define (logand-min a b)
-    (if (< a b 0)
-        (min a b)
-        0))
-  (define (logand-max a b)
-    (if (< a b 0)
-        0
-        (max a b)))
-  (if (and (= min0 max0) (= min1 max1)
-           (type<=? (logior type0 type1) &exact-integer))
-      (values #t (logtest min0 min1))
-      (values #f #f)))
-
 
 
 
@@ -282,6 +268,7 @@
 (define-binary-primcall-reducer (logbit? cps k src
                                          arg0 type0 min0 max0
                                          arg1 type1 min1 max1)
+  ;; FIXME: Use an unboxed number for the mask instead of a fixnum.
   (define (convert-to-logtest cps kbool)
     (define (compute-mask cps kmask src)
       (if (eq? min0 max0)
@@ -293,14 +280,20 @@
                  (build-term
                    ($continue kmask src ($primcall 'ash (one arg0)))))))))
     (with-cps cps
-      (letv mask)
+      (letv mask test)
       (letk kt ($kargs () ()
                  ($continue kbool src ($const #t))))
       (letk kf ($kargs () ()
                  ($continue kbool src ($const #f))))
+      (let$ body (with-cps-constants ((zero 0))
+                   (build-term
+                     ($continue kt src
+                       ($branch kf ($primcall 'eq? (test zero)))))))
+      (letk kand ($kargs (#f) (test)
+                   ,body))
       (letk kmask ($kargs (#f) (mask)
-                    ($continue kf src
-                      ($branch kt ($primcall 'logtest (mask arg1))))))
+                    ($continue kand src
+                      ($primcall 'logand (mask arg1)))))
       ($ (compute-mask kmask src))))
   ;; Hairiness because we are converting from a primcall with unknown
   ;; arity to a branching primcall.
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index f194849..f19adde 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1476,9 +1476,10 @@ minimum, and maximum."
     (- -1 (&min a))))
 
 (define-simple-type-checker (logtest &exact-integer &exact-integer))
-(define-predicate-inferrer (logtest a b true?)
+(define-type-inferrer (logtest a b result)
   (restrict! a &exact-integer -inf.0 +inf.0)
-  (restrict! b &exact-integer -inf.0 +inf.0))
+  (restrict! b &exact-integer -inf.0 +inf.0)
+  (define! result &special-immediate &false &true))
 
 (define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer))
 (define-type-inferrer (logbit? a b result)
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 993fa0a..0c23f7b 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1,6 +1,6 @@
 ;;; Tree-IL partial evaluator
 
-;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014, 2017 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1381,19 +1381,25 @@ top-level bindings from ENV and return the resulting 
expression."
            ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
           (for-tail (make-const #f #t)))
 
-         (('= ($ <primcall> src2 'logand (a b)) ($ <const> _ 0))
-          (let ((src (or src src2)))
-            (make-primcall src 'not
-                           (list (make-primcall src 'logtest (list a b))))))
-
          (('logbit? ($ <const> src2
                        (? (lambda (bit)
-                            (and (exact-integer? bit) (not (negative? bit))))
+                            (and (exact-integer? bit)
+                                 (<= 0 bit (logcount most-positive-fixnum))))
                           bit))
                     val)
-          (fold-constants src 'logtest
-                          (list (make-const (or src2 src) (ash 1 bit)) val)
-                          ctx))
+          (for-tail
+           (make-primcall src 'logtest
+                          (list (make-const src2 (ash 1 bit)) val))))
+
+         (('logtest a b)
+          (for-tail
+           (make-primcall
+            src
+            'not
+            (list
+             (make-primcall src 'eq?
+                            (list (make-primcall src 'logand (list a b))
+                                  (make-const src 0)))))))
 
          (((? effect-free-primitive?) . args)
           (fold-constants src name args ctx))