From 8006d2d6eb8eee0fd08a6d29cf48484f64552c29 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 3 Jul 2014 14:45:12 +0200
Subject: [PATCH] Optimizer support for logtest and logbit?

* module/language/cps/effects-analysis.scm: Add entries for logtest and
  logbit?.
* module/language/cps/types.scm (logtest, logbit?): New checkers and
  inferrers.
* module/language/tree-il/peval.scm (peval): Convert (zero? (logand a
  b)) to (logtest a b), in anticipation of opcode support for logtest.
*
  module/language/tree-il/primitives.scm (*interesting-primitive-names*):
  (*effect-free-primitives*): Add logtest and logbit?.
---
 module/language/cps/effects-analysis.scm |  2 ++
 module/language/cps/types.scm            | 31 ++++++++++++++++++++++++
 module/language/tree-il/peval.scm        | 14 +++++++++++
 module/language/tree-il/primitives.scm   |  4 +--
 4 files changed, 49 insertions(+), 2 deletions(-)

diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index b1e2cc841..d59283c40 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -417,6 +417,8 @@ is or might be a read or a write to the same location as A."
   ((logior . _)                    &type-check)
   ((logxor . _)                    &type-check)
   ((lognot . _)                    &type-check)
+  ((logtest a b)                   &type-check)
+  ((logbit? a b)                   &type-check)
   ((sqrt _)                        &type-check)
   ((abs _)                         &type-check))
 
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 0bd2812ff..87cfe1719 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1012,6 +1012,37 @@ minimum, and maximum."
            (- -1 (&max a))
            (- -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)))
+  (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))))
+
+(define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer))
+(define-type-inferrer (logbit? a b result)
+  (let ((a-min (&min a))
+        (a-max (&max a))
+        (b-min (&min b))
+        (b-max (&max b)))
+    (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min))
+             (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min)))
+        (let ((res (if (logbit? a-min b-min) 1 0)))
+          (define! result &boolean res res))
+        (define! result &boolean 0 1))))
+
 ;; Flonums.
 (define-simple-type-checker (sqrt &number))
 (define-type-inferrer (sqrt x result)
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 3331291a7..f70d3b154 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1334,6 +1334,20 @@ 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))))
+                          bit))
+                    val)
+          (fold-constants src 'logtest
+                          (list (make-const (or src2 src) (ash 1 bit)) val)
+                          ctx))
+
          (((? effect-free-primitive?) . args)
           (fold-constants src name args ctx))
 
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index a959df25d..e4e61044a 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -47,7 +47,7 @@
     memq memv
     = < > <= >= zero? positive? negative?
     + * - / 1- 1+ quotient remainder modulo
-    ash logand logior logxor lognot
+    ash logand logior logxor lognot logtest logbit?
     sqrt abs
     not
     pair? null? list? symbol? vector? string? struct? number? char? nil?
@@ -165,7 +165,7 @@
   `(values
     eq? eqv? equal?
     = < > <= >= zero? positive? negative?
-    ash logand logior logxor lognot
+    ash logand logior logxor lognot logtest logbit?
     + * - / 1- 1+ sqrt abs quotient remainder modulo
     not
     pair? null? nil? list?
-- 
2.20.1