[Sbcl-commits] master: More identity folding for LOGAND and LOGIOR with constants

[Paul K. <pk...@us...>]

The branch "master" has been updated in SBCL:
       via  69018386b391f17fb722a4ded00474be182db355 (commit)
      from  e4f3dfe7fefc2ab3980360ce597dc378c6b02393 (commit)

- Log -----------------------------------------------------------------
commit 69018386b391f17fb722a4ded00474be182db355
Author: Paul Khuong <pv...@pv...>
Date:   Fri Jun 7 19:36:13 2013 -0400

    More identity folding for LOGAND and LOGIOR with constants
    
     * Handle more complex cases than only powers of two:
       compare the variant argument with a power-of-two-sized
       prefix of the constant bit pattern.
    
     * Add parallel logic for LOGIOR: if all the ones we're ORing in
       are already set because the variant argument is a small enough
       negative integer, we've got an identity.
    
     * This is a bit hairy, so exhaustively check the logic with small
       values.
---
 NEWS                      |    1 +
 src/compiler/srctran.lisp |   25 +++++++++++++++++++------
 tests/arith.pure.lisp     |   20 ++++++++++++++++++++
 3 files changed, 40 insertions(+), 6 deletions(-)

diff --git a/NEWS b/NEWS
index b23e3ee..ba7dcd9 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,7 @@ changes relative to sbcl-1.1.8:
     conditionals.
   * optimization: bitwise OR forms can now trigger modular arithmetic as well,
     when the result is known to be negative.
+  * optimization: recognize more cases of useless LOGAND/LOGIOR with constants.
   * bug fix: problems with NCONC type derivation (reported by Jerry James).
   * bug fix: EXPT type derivation no longer constructs bogus floating-point
     types.  (reported by Vsevolod Dyomkin)
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index d408fa3..7c7f8fd 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3401,14 +3401,17 @@
   (def logxor -1 (lognot x))
   (def logxor 0 x))
 
+(defun least-zero-bit (x)
+  (and (/= x -1)
+       (1- (integer-length (logxor x (1+ x))))))
+
 (deftransform logand ((x y) (* (constant-arg t)) *)
   "fold identity operation"
-  (let ((y (lvar-value y)))
-    (unless (and (plusp y)
-                 (= y (1- (ash 1 (integer-length y)))))
-      (give-up-ir1-transform))
-    (unless (csubtypep (lvar-type x)
-                       (specifier-type `(integer 0 ,y)))
+  (let* ((y (lvar-value y))
+         (width (or (least-zero-bit y) '*)))
+    (unless (and (neq width 0) ; (logand x 0) handled elsewhere
+                 (csubtypep (lvar-type x)
+                            (specifier-type `(unsigned-byte ,width))))
       (give-up-ir1-transform))
     'x))
 
@@ -3419,6 +3422,16 @@
       (give-up-ir1-transform))
     'x))
 
+(deftransform logior ((x y) (* (constant-arg t)) *)
+  "fold identity operation"
+  (let* ((y (lvar-value y))
+         (width (or (least-zero-bit (lognot y))
+                    (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
+    (unless (csubtypep (lvar-type x)
+                       (specifier-type `(integer ,(- (ash 1 width)) -1)))
+      (give-up-ir1-transform))
+    'x))
+
 ;;; Pick off easy association opportunities for constant folding.
 ;;; More complicated stuff that also depends on commutativity
 ;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp
index 8281d7e..32cff23 100644
--- a/tests/arith.pure.lisp
+++ b/tests/arith.pure.lisp
@@ -608,3 +608,23 @@
                                         (the (integer 21371810342718833225 21371810343571293860) b))))
                 16779072918521075607 21371810342718833263)
                2923729245085762055)))
+
+(with-test (:name :complicated-logand-identity)
+  (loop for k from -8 upto 8 do
+    (loop for min from -16 upto 16 do
+      (loop for max from min upto 16 do
+        (let ((f (compile nil `(lambda (x)
+                                 (declare (type (integer ,min ,max) x))
+                                 (logand x ,k)))))
+          (loop for x from min upto max do
+            (assert (eql (logand x k) (funcall f x)))))))))
+
+(with-test (:name :complicated-logior-identity)
+  (loop for k from -8 upto 8 do
+    (loop for min from -16 upto 16 do
+      (loop for max from min upto 16 do
+        (let ((f (compile nil `(lambda (x)
+                                 (declare (type (integer ,min ,max) x))
+                                 (logior x ,k)))))
+          (loop for x from min upto max do
+            (assert (eql (logior x k) (funcall f x)))))))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL