Compiler emits br-if-logtest

* module/language/cps/compile-bytecode.scm (compile-fun):
* module/language/cps/primitives.scm (*branching-primcall-arities*):
* module/language/cps/type-fold.scm (logtest):
* module/language/cps/types.scm (logtest):
* module/system/vm/assembler.scm (system):
* module/system/vm/disassembler.scm (compute-labels): Add backend
  support for the logtest instruction.

6 files changed, 21 insertions, 19 deletions

diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 25626a372..e04eb6cb8 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -438,7 +438,8 @@
         (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
         (($ $primcall '= (a b)) (binary emit-br-if-= a b))
         (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
-        (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
+        (($ $primcall '> (a b)) (binary emit-br-if-< b a))
+        (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
 
     (define (compile-trunc label k exp nreq rest-var nlocals)
       (define (do-call proc args emit-call)
diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm
index 4c6287a91..a095fce33 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -86,7 +86,8 @@
     (< . (1 . 2))
     (> . (1 . 2))
     (<= . (1 . 2))
-    (>= . (1 . 2))))
+    (>= . (1 . 2))
+    (logtest . (1 . 2))))
 
 (define (compute-prim-instructions)
   (let ((table (make-hash-table)))
diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index 3dc21552b..6fc48c452 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -123,6 +123,19 @@
     ((= <= <) (values #t #f))
     (else (values #f #f))))
 
+(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) (eqv? type0 type1 &exact-integer))
+      (values #t (logtest min0 min1))
+      (values #f #f)))
+
 (define (compute-folded fun dfg min-label min-var)
   (define (scalar-value type val)
     (cond
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 87cfe1719..d3125bd74 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1013,23 +1013,9 @@ minimum, and maximum."
            (- -1 (&min a))))
 
 (define-simple-type-checker (logtest &exact-integer &exact-integer))
-(define-type-inferrer (logtest a b result)
-  (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)))
+(define-predicate-inferrer (logtest a b true?)
   (restrict! a &exact-integer -inf.0 +inf.0)
-  (restrict! b &exact-integer -inf.0 +inf.0)
-  (let ((min (logand-min (&min a) (&min b)))
-        (max (logand-max (&max a) (&max b))))
-    (if (and (= min max) (not (inf? min)))
-        (let ((res (if (zero? min) 0 1)))
-          (define! result &boolean res res))
-        (define! result &exact-integer 0 1))))
+  (restrict! b &exact-integer -inf.0 +inf.0))
 
 (define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer))
 (define-type-inferrer (logbit? a b result)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 787273eb7..e944e6818 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -95,6 +95,7 @@
             (emit-br-if-=* . emit-br-if-=)
             (emit-br-if-<* . emit-br-if-<)
             (emit-br-if-<=* . emit-br-if-<=)
+            (emit-br-if-logtest* . emit-br-if-logtest)
             (emit-mov* . emit-mov)
             (emit-box* . emit-box)
             (emit-box-ref* . emit-box-ref)
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index d41c2c1c6..adacf1b4b 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -296,7 +296,7 @@ address of that offset."
                    br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
                    br-if-true br-if-null br-if-nil br-if-pair br-if-struct
                    br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
-                   br-if-= br-if-< br-if-<= br-if-> br-if->=)
+                   br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest)
                   (match arg
                     ((_ ... target)
                      (add-label! (+ offset target) "L"))))