X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fsrctran.lisp;h=0d22154584167da326e779bc29f8d7c2960c4179;hb=1d68d81c3022715f83faeff6ccc9836975783462;hp=63f198061b09c97a6f1dd61f5fb6f557ef88c805;hpb=5b63b08f9ee8a50a679b5e533bf76e253e8caff5;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 63f1980..0d22154 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)
@@ -3265,6 +3281,60 @@
       (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
+;;; probably be handled with a more general tree-rewriting pass.
+(macrolet ((def (operator &key (type 'integer) (folded operator))
+             `(deftransform ,operator ((x z) (,type (constant-arg ,type)))
+                ,(format nil "associate ~A/~A of constants"
+                         operator folded)
+                (binding* ((node  (if (lvar-has-single-use-p x)
+                                      (lvar-use x)
+                                      (give-up-ir1-transform)))
+                           (nil (or (and (combination-p node)
+                                         (eq (lvar-fun-name
+                                              (combination-fun node))
+                                             ',folded))
+                                    (give-up-ir1-transform)))
+                           (y   (second (combination-args node)))
+                           (nil (or (constant-lvar-p y)
+                                    (give-up-ir1-transform)))
+                           (y   (lvar-value y)))
+                  (unless (typep y ',type)
+                    (give-up-ir1-transform))
+                  (splice-fun-args x ',folded 2)
+                  `(lambda (x y z)
+                     (declare (ignore y z))
+                     (,',operator x ',(,folded y (lvar-value z))))))))
+  (def logand)
+  (def logior)
+  (def logxor)
+  (def logtest :folded logand)
+  (def + :type rational)
+  (def * :type rational))
+
+(deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *))
+  "Fold mask-signed-field/mask-signed-field of constant width"
+  (binding* ((node  (if (lvar-has-single-use-p x)
+                        (lvar-use x)
+                        (give-up-ir1-transform)))
+             (nil (or (combination-p node)
+                      (give-up-ir1-transform)))
+             (nil (or (eq (lvar-fun-name (combination-fun node))
+                          'mask-signed-field)
+                      (give-up-ir1-transform)))
+             (x-width (first (combination-args node)))
+             (nil (or (constant-lvar-p x-width)
+                      (give-up-ir1-transform)))
+             (x-width (lvar-value x-width)))
+    (unless (typep x-width 'unsigned-byte)
+      (give-up-ir1-transform))
+    (splice-fun-args x 'mask-signed-field 2)
+    `(lambda (width x-width x)
+       (declare (ignore width x-width))
+       (mask-signed-field ,(min (lvar-value width) x-width) x))))
+
 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
 ;;; (* 0 -4.0) is -0.0.
 (deftransform - ((x y) ((constant-arg (member 0)) rational) *)
@@ -3516,10 +3586,10 @@
         ((and (csubtypep x-type char-type)
               (csubtypep y-type char-type))
          '(char= x y))
-        ((or (fixnum-type-p x-type) (fixnum-type-p y-type))
-         (commutative-arg-swap node))
         ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
-         '(eq x y))
+         (if (and (constant-lvar-p x) (not (constant-lvar-p y)))
+             '(eq y x)
+             '(eq x y)))
         ((and (not (constant-lvar-p y))
               (or (constant-lvar-p x)
                   (and (csubtypep x-type y-type)