From f21e0f5b908263715ea0d867edb64ceba5a3d668 Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Mon, 20 May 2013 12:19:27 -0400
Subject: [PATCH] Enable (type-directed) constant folding for LOGTEST on
 x86oids and PPC

 * COMBINATION-IMPLEMENTATION-STYLE can return :maybe. Like :default,
   it enables transforms, but transforms can call C-I-S themselves to
   selectively disable rewrites.

 * Implement type-directed constant folding for LOGTEST. !x86oids/PPC
   platforms get that for free via inlining.

 * Use :maybe to enable all LOGTEST transforms except inlining.
---
 src/compiler/ir1opt.lisp    |    2 +-
 src/compiler/ppc/vm.lisp    |    2 +-
 src/compiler/srctran.lisp   |   20 ++++++++++++++++++--
 src/compiler/x86-64/vm.lisp |    2 +-
 src/compiler/x86/vm.lisp    |    6 +++---
 tests/compiler.pure.lisp    |    7 +++++++
 6 files changed, 31 insertions(+), 8 deletions(-)

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index b664bf7..4992ea4 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -889,7 +889,7 @@
                 ;; The VM mostly knows how to handle this.  We need
                 ;; to massage the call slightly, though.
                 (transform-call node transform (combination-fun-source-name node)))
-               (:default
+               ((:default :maybe)
                 ;; Let transforms have a crack at it.
                 (dolist (x (fun-info-transforms info))
                   #!+sb-show
diff --git a/src/compiler/ppc/vm.lisp b/src/compiler/ppc/vm.lisp
index cac0428..7f1bc96 100644
--- a/src/compiler/ppc/vm.lisp
+++ b/src/compiler/ppc/vm.lisp
@@ -369,7 +369,7 @@
          ((or (valid-funtype '(fixnum fixnum) '*)
               (valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
               (valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*))
-          (values :direct nil))
+          (values :maybe nil))
          (t (values :default nil))))
       (logbitp
        (cond
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index b7e8a29..d2b2246 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -310,8 +310,24 @@
 ;;; on the argument types), but we make it a regular transform so that
 ;;; the VM has a chance to see the bare LOGTEST and potentiall choose
 ;;; to implement it differently.  --njf, 06-02-2006
-(deftransform logtest ((x y) * *)
-  `(not (zerop (logand x y))))
+;;;
+;;; Other transforms may be useful even with direct LOGTEST VOPs; let
+;;; them fire (including the type-directed constant folding below), but
+;;; disable the inlining rewrite in such cases. -- PK, 2013-05-20
+(deftransform logtest ((x y) * * :node node)
+  (let ((type (two-arg-derive-type x y
+                                   #'logand-derive-type-aux
+                                   #'logand)))
+    (multiple-value-bind (typep definitely)
+        (ctypep 0 type)
+      (cond ((and (not typep) definitely)
+             t)
+            ((type= type (specifier-type '(eql 0)))
+             nil)
+            ((neq :default (combination-implementation-style node))
+             (give-up-ir1-transform))
+            (t
+             `(not (zerop (logand x y))))))))
 
 (deftransform logbitp
     ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index 6c44424..91298cc 100644
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -568,7 +568,7 @@
               ;; a signed word, except for the mess of VOPs it would demand
               (valid-funtype '((signed-byte 64) (signed-byte 64)) '*)
               (valid-funtype '((unsigned-byte 64) (unsigned-byte 64)) '*))
-          (values :direct nil))
+          (values :maybe nil))
          (t
           (values :default nil))))
       (logbitp
diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp
index b7320e8..0006fb5 100644
--- a/src/compiler/x86/vm.lisp
+++ b/src/compiler/x86/vm.lisp
@@ -499,11 +499,11 @@
       (logtest
        (cond
          ((valid-funtype '(fixnum fixnum) '*)
-          (values :direct nil))
+          (values :maybe nil))
          ((valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
-          (values :direct nil))
+          (values :maybe nil))
          ((valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*)
-          (values :direct nil))
+          (values :maybe nil))
          (t (values :default nil))))
       (logbitp
        (cond
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 7cced51..9a46285 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4476,3 +4476,10 @@
                 (declare (inline recursed called))
                 (recursed)))))
 
+(with-test (:name :constant-fold-logtest)
+  (assert (equal (sb-kernel:%simple-fun-type
+                  (compile nil `(lambda (x)
+                                  (declare (type (mod 1024) x)
+                                           (optimize speed))
+                                  (logtest x 2048))))
+                 '(function ((unsigned-byte 10)) (values null &optional)))))
-- 
1.7.10.4