X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=997e50b12083b32fe41ed9831f1a6398203b9ef4;hb=a6661cdaac013752213d381aa469cb0919a6ce4c;hp=545c4d690f518405d1f64c72b6ecf696ead27b24;hpb=63690d6dc4617f2140f229a142728d1784efd0b5;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 545c4d6..997e50b 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -176,12 +176,11 @@
             (loop for (arg next) on args
                   while next
                   do
-                  (let ((lvar-type (lvar-type arg)))
-                    (unless (or (csubtypep list-type lvar-type)
-                                (csubtypep lvar-type list-type))
-                      (assert-lvar-type arg list-type
-                                        (lexenv-policy *lexenv*))
-                      (return *empty-type*))))
+                  (when (eq (type-intersection (lvar-type arg) list-type)
+                            *empty-type*)
+                    (assert-lvar-type arg list-type
+                                      (lexenv-policy *lexenv*))
+                    (return *empty-type*)))
             (loop with all-nil = t
                   for (arg next) on args
                   for lvar-type = (lvar-type arg)
@@ -189,7 +188,7 @@
                   do
                   (cond
                     ;; Cons in the middle guarantees the result will be a cons
-                    ((csubtypep lvar-type cons-type)
+                    ((not (csubtypep null-type lvar-type))
                      (return cons-type))
                     ;; If all but the last are NIL the type of the last arg
                     ;; can be used
@@ -310,8 +309,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)
@@ -2760,7 +2775,88 @@
               (specifier-type `(signed-byte ,size-high))
               *universal-type*))
         *universal-type*)))
+
+;;; Rightward ASH
+#!+ash-right-vops
+(progn
+  (defun %ash/right (integer amount)
+    (ash integer (- amount)))
+
+  (deftransform ash ((integer amount) (sb!vm:signed-word (integer * 0)))
+    "Convert ASH of signed word to %ASH/RIGHT"
+    (when (constant-lvar-p amount)
+      (give-up-ir1-transform))
+    (let ((use (lvar-uses amount)))
+      (cond ((and (combination-p use)
+                  (eql '%negate (lvar-fun-name (combination-fun use))))
+             (splice-fun-args amount '%negate 1)
+             `(lambda (integer amount)
+                (declare (type unsigned-byte amount))
+                (%ash/right integer (if (>= amount ,sb!vm:n-word-bits)
+                                        ,(1- sb!vm:n-word-bits)
+                                        amount))))
+            (t
+             `(%ash/right integer (if (<= amount ,(- sb!vm:n-word-bits))
+                                      ,(1- sb!vm:n-word-bits)
+                                      (- amount)))))))
+
+  (deftransform ash ((integer amount) (word (integer * 0)))
+    "Convert ASH of word to %ASH/RIGHT"
+    (when (constant-lvar-p amount)
+      (give-up-ir1-transform))
+    (let ((use (lvar-uses amount)))
+      (cond ((and (combination-p use)
+                  (eql '%negate (lvar-fun-name (combination-fun use))))
+             (splice-fun-args amount '%negate 1)
+             `(lambda (integer amount)
+                (declare (type unsigned-byte amount))
+                (if (>= amount ,sb!vm:n-word-bits)
+                    0
+                    (%ash/right integer amount))))
+            (t
+             `(if (<= amount ,(- sb!vm:n-word-bits))
+                  0
+                  (%ash/right integer (- amount)))))))
+
+  (deftransform %ash/right ((integer amount) (integer (constant-arg unsigned-byte)))
+    "Convert %ASH/RIGHT by constant back to ASH"
+    `(ash integer ,(- (lvar-value amount))))
+
+  (deftransform %ash/right ((integer amount) * * :node node)
+    "strength reduce large variable right shift"
+    (let ((return-type (single-value-type (node-derived-type node))))
+      (cond ((type= return-type (specifier-type '(eql 0)))
+             0)
+            ((type= return-type (specifier-type '(eql -1)))
+             -1)
+            ((csubtypep return-type (specifier-type '(member -1 0)))
+             `(ash integer ,(- sb!vm:n-word-bits)))
+            (t
+             (give-up-ir1-transform)))))
 
+  (defun %ash/right-derive-type-aux (n-type shift same-arg)
+    (declare (ignore same-arg))
+    (or (and (or (csubtypep n-type (specifier-type 'sb!vm:signed-word))
+                 (csubtypep n-type (specifier-type 'word)))
+             (csubtypep shift (specifier-type `(mod ,sb!vm:n-word-bits)))
+             (let ((n-low (numeric-type-low n-type))
+                   (n-high (numeric-type-high n-type))
+                   (s-low (numeric-type-low shift))
+                   (s-high (numeric-type-high shift)))
+               (make-numeric-type :class 'integer :complexp :real
+                                  :low (when n-low
+                                         (if (minusp n-low)
+                                             (ash n-low (- s-low))
+                                             (ash n-low (- s-high))))
+                                  :high (when n-high
+                                          (if (minusp n-high)
+                                              (ash n-high (- s-high))
+                                              (ash n-high (- s-low)))))))
+        *universal-type*))
+
+  (defoptimizer (%ash/right derive-type) ((n shift))
+    (two-arg-derive-type n shift #'%ash/right-derive-type-aux #'%ash/right))
+  )
 
 ;;; Modular functions
 
@@ -2837,7 +2933,8 @@
                                            (mask-signed-field width constant-value)
                                            (ldb (byte width 0) constant-value))))
                        (unless (= constant-value new-value)
-                         (change-ref-leaf node (make-constant new-value))
+                         (change-ref-leaf node (make-constant new-value)
+                                          :recklessly t)
                          (let ((lvar (node-lvar node)))
                            (setf (lvar-%derived-type lvar)
                                  (and (lvar-has-single-use-p lvar)
@@ -2848,10 +2945,7 @@
                     (lambda-var
                      (binding* ((dest (lvar-dest lvar) :exit-if-null)
                                 (nil  (combination-p dest) :exit-if-null)
-                                (fun-ref (lvar-use (combination-fun dest)))
-                                (leaf (ref-leaf fun-ref))
-                                (name (and (leaf-has-source-name-p leaf)
-                                           (leaf-source-name leaf))))
+                                (name (lvar-fun-name (combination-fun dest))))
                        ;; we're about to insert an m-s-f/logand between a ref to
                        ;; a variable and another m-s-f/logand. No point in doing
                        ;; that; the parent m-s-f/logand was already cut to width
@@ -2874,7 +2968,7 @@
                  (combination
                   (when (eq (basic-combination-kind node) :known)
                     (let* ((fun-ref (lvar-use (combination-fun node)))
-                           (fun-name (leaf-source-name (ref-leaf fun-ref)))
+                           (fun-name (lvar-fun-name (combination-fun node)))
                            (modular-fun (find-modular-version fun-name kind
                                                               signedp width)))
                       (when (and modular-fun
@@ -2988,11 +3082,11 @@
   (if (and (constant-lvar-p x)
            (not (constant-lvar-p y)))
       `(,(lvar-fun-name (basic-combination-fun node))
-        y
+        (truly-the ,(lvar-type y) y)
         ,(lvar-value x))
       (give-up-ir1-transform)))
 
-(dolist (x '(= char= + * logior logand logxor))
+(dolist (x '(= char= + * logior logand logxor logtest))
   (%deftransform x '(function * *) #'commutative-arg-swap
                  "place constant arg last"))
 
@@ -3268,6 +3362,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) *)
@@ -3277,6 +3425,25 @@
   "convert (* x 0) to 0"
   0)
 
+(deftransform %negate ((x) (rational))
+  "Eliminate %negate/%negate of rationals"
+  (splice-fun-args x '%negate 1)
+  '(the rational x))
+
+(deftransform %negate ((x) (number))
+  "Combine %negate/*"
+  (let ((use (lvar-uses x))
+        arg)
+    (unless (and (combination-p use)
+                 (eql '* (lvar-fun-name (combination-fun use)))
+                 (constant-lvar-p (setf arg (second (combination-args use))))
+                 (numberp (setf arg (lvar-value arg))))
+      (give-up-ir1-transform))
+    (splice-fun-args x '* 2)
+    `(lambda (x y)
+       (declare (ignore y))
+       (* x ,(- arg)))))
+
 ;;; Return T if in an arithmetic op including lvars X and Y, the
 ;;; result type is not affected by the type of X. That is, Y is at
 ;;; least as contagious as X.
@@ -3519,10 +3686,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)
@@ -4487,3 +4654,35 @@
                (policy-quality-name-p (lvar-value quality-name)))
     (give-up-ir1-transform))
   '(%policy-quality policy quality-name))
+
+(deftransform encode-universal-time
+    ((second minute hour date month year &optional time-zone)
+     ((constant-arg (mod 60)) (constant-arg (mod 60))
+      (constant-arg (mod 24))
+      (constant-arg (integer 1 31))
+      (constant-arg (integer 1 12))
+      (constant-arg (integer 1899))
+      (constant-arg (rational -24 24))))
+  (let ((second (lvar-value second))
+        (minute (lvar-value minute))
+        (hour (lvar-value hour))
+        (date (lvar-value date))
+        (month (lvar-value month))
+        (year (lvar-value year))
+        (time-zone (lvar-value time-zone)))
+    (if (zerop (rem time-zone 1/3600))
+        (encode-universal-time second minute hour date month year time-zone)
+        (give-up-ir1-transform))))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((integer 0 #.(expt 10 8))))
+  `(sb!unix:nanosleep seconds 0))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((constant-arg (real 0))))
+  (let ((seconds-value (lvar-value seconds)))
+    (multiple-value-bind (seconds nano)
+        (sb!impl::split-seconds-for-sleep seconds-value)
+      (if (> seconds (expt 10 8))
+          (give-up-ir1-transform)
+          `(sb!unix:nanosleep ,seconds ,nano)))))