[Guile-commits] 36/41: Add logsub op.

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 82085252ec278e3c12271a038e7ae96ae23e3673
Author: Andy Wingo <address@hidden>
Date:   Mon Nov 30 11:54:19 2015 +0100

    Add logsub op.
    
    * libguile/vm-engine.c (logsub): New op.
    * module/language/cps/effects-analysis.scm (logsub):
    * module/language/cps/types.scm (logsub):
    * module/system/vm/assembler.scm (system): Add support for the new op.
    
    * module/language/tree-il/compile-cps.scm (canonicalize):
      Rewrite (logand x (lognot y)) to (logsub x y).
---
 libguile/vm-engine.c                     |   22 +++++++++++++++++++++-
 module/language/cps/effects-analysis.scm |    1 +
 module/language/cps/types.scm            |   25 +++++++++++++++++++++++++
 module/language/tree-il/compile-cps.scm  |   10 ++++++++++
 module/system/vm/assembler.scm           |    1 +
 5 files changed, 58 insertions(+), 1 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 991280b..33d2b7b 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3482,7 +3482,27 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  VM_DEFINE_OP (161, unused_161, NULL, NOP)
+  /* logsub dst:8 a:8 b:8
+   *
+   * Place the bitwise AND of A and the bitwise NOT of B into DST.
+   */
+  VM_DEFINE_OP (161, logsub, "logsub", OP1 (X8_S8_S8_S8) | OP_DST)
+    {
+      ARGS2 (x, y);
+
+      if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
+        {
+          scm_t_signed_bits a, b;
+
+          a = SCM_I_INUM (x);
+          b = SCM_I_INUM (y);
+
+          RETURN (SCM_I_MAKINUM (a & ~b));
+        }
+
+      RETURN_EXP (scm_logand (x, scm_lognot (y)));
+    }
+
   VM_DEFINE_OP (162, unused_162, NULL, NOP)
   VM_DEFINE_OP (163, unused_163, NULL, NOP)
   VM_DEFINE_OP (164, unused_164, NULL, NOP)
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 5821c5d..7018a11 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -465,6 +465,7 @@ is or might be a read or a write to the same location as A."
   ((logand . _)                    &type-check)
   ((logior . _)                    &type-check)
   ((logxor . _)                    &type-check)
+  ((logsub . _)                    &type-check)
   ((lognot . _)                    &type-check)
   ((logtest a b)                   &type-check)
   ((logbit? a b)                   &type-check)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 0c46d36..3f13d92 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1212,6 +1212,31 @@ minimum, and maximum."
            (logand-min (&min a) (&min b))
            (logand-max (&max a) (&max b))))
 
+(define-simple-type-checker (logsub &exact-integer &exact-integer))
+(define-type-inferrer (logsub a b result)
+  (define (logsub-bounds min-a max-a min-b max-b)
+    (cond
+     ((negative? max-b)
+      ;; Sign bit always set on B, so result will never be negative.
+      ;; If A might be negative (all leftmost bits 1), we don't know
+      ;; how positive the result might be.
+      (values 0 (if (negative? min-a) +inf.0 max-a)))
+     ((negative? min-b)
+      ;; Sign bit might be set on B.
+      (values min-a (if (negative? min-a) +inf.0 max-a)))
+     ((negative? min-a)
+      ;; Sign bit never set on B -- result will have the sign of A.
+      (values min-a (if (negative? max-a) -1 max-a)))
+     (else
+      ;; Sign bit never set on A and never set on B -- the nice case.
+      (values 0 max-a))))
+  (restrict! a &exact-integer -inf.0 +inf.0)
+  (restrict! b &exact-integer -inf.0 +inf.0)
+  (call-with-values (lambda ()
+                      (logsub-bounds (&min a) (&max a) (&min b) (&max b)))
+    (lambda (min max)
+      (define! result &exact-integer min max))))
+
 (define-simple-type-checker (logior &exact-integer &exact-integer))
 (define-type-inferrer (logior a b result)
   ;; Saturate all bits of val.
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 57c52aa..5fa6010 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1012,6 +1012,16 @@ integer."
                                                    (make-lexical-ref src 'v 
v)))
                               (make-lexical-ref src 'v v)))))
 
+       ;; Lower (logand x (lognot y)) to (logsub x y).  We do it here
+       ;; instead of in CPS because it gets rid of the lognot entirely;
+       ;; if type folding can't prove Y to be an exact integer, then DCE
+       ;; would have to leave it in the program for its possible
+       ;; effects.
+       (($ <primcall> src 'logand (x ($ <primcall> _ 'lognot (y))))
+        (make-primcall src 'logsub (list x y)))
+       (($ <primcall> src 'logand (($ <primcall> _ 'lognot (y)) x))
+        (make-primcall src 'logsub (list x y)))
+
        (($ <prompt> src escape-only? tag body
            ($ <lambda> hsrc hmeta
               ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 564ec06..3f08d7e 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -152,6 +152,7 @@
             (emit-logand* . emit-logand)
             (emit-logior* . emit-logior)
             (emit-logxor* . emit-logxor)
+            (emit-logsub* . emit-logsub)
             (emit-make-vector* . emit-make-vector)
             (emit-make-vector/immediate* . emit-make-vector/immediate)
             (emit-vector-length* . emit-vector-length)