Better calls to static functions on x86-64.

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 90d1077..c90ca44 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -178,7 +178,10 @@
                   do
                   (let ((lvar-type (lvar-type arg)))
                     (unless (or (csubtypep list-type lvar-type)
-                                (csubtypep lvar-type list-type))
+                                (csubtypep lvar-type list-type)
+                                ;; Check for NIL specifically, because
+                                ;; SYMBOL or ATOM won't satisfie the above
+                                (csubtypep null-type lvar-type))
                       (assert-lvar-type arg list-type
                                         (lexenv-policy *lexenv*))
                       (return *empty-type*))))
@@ -2823,16 +2826,17 @@
     "Convert %ASH/RIGHT by constant back to ASH"
     `(ash integer ,(- (lvar-value amount))))
 
-  (deftransform %ash/right ((integer amount) * (member -1 0) :node node)
-    ;; constant-fold large shifts
+  (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
-             (aver (csubtypep (lvar-type integer) (specifier-type 'sb!vm:signed-word)))
-             `(ash integer ,(- 1 sb!vm:n-word-bits))))))
+             (give-up-ir1-transform)))))
 
   (defun %ash/right-derive-type-aux (n-type shift same-arg)
     (declare (ignore same-arg))
@@ -2933,7 +2937,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)
@@ -3081,11 +3086,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"))
 
@@ -3429,6 +3434,20 @@
   (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.
@@ -4639,3 +4658,22 @@
                (policy-quality-name-p (lvar-value quality-name)))
     (give-up-ir1-transform))
   '(%policy-quality policy quality-name))
+\f
+(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))))