0.8.13.32:

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

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 869f684..e4084c3 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -1620,6 +1620,13 @@
                       #'%unary-truncate-derive-type-aux
                       #'%unary-truncate))
 
+(defoptimizer (%unary-ftruncate derive-type) ((number))
+  (let ((divisor (specifier-type '(integer 1 1))))
+    (one-arg-derive-type number
+                         #'(lambda (n)
+                             (ftruncate-derive-type-quot-aux n divisor nil))
+                         #'%unary-ftruncate)))
+
 ;;; Define optimizers for FLOOR and CEILING.
 (macrolet
     ((def (name q-name r-name)
@@ -2658,7 +2665,7 @@
   (let* ((y (lvar-value y))
         (y-abs (abs y))
         (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len))
+    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
       (give-up-ir1-transform))
     (if (minusp y)
        `(- (ash x ,len))
@@ -2673,7 +2680,7 @@
         (let* ((y (lvar-value y))
                (y-abs (abs y))
                (len (1- (integer-length y-abs))))
-          (unless (= y-abs (ash 1 len))
+          (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
             (give-up-ir1-transform))
           (let ((shift (- len))
                 (mask (1- y-abs))
@@ -2699,7 +2706,7 @@
   (let* ((y (lvar-value y))
         (y-abs (abs y))
         (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len))
+    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
       (give-up-ir1-transform))
     (let ((mask (1- y-abs)))
       (if (minusp y)
@@ -2714,7 +2721,7 @@
   (let* ((y (lvar-value y))
         (y-abs (abs y))
         (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len))
+    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
       (give-up-ir1-transform))
     (let* ((shift (- len))
           (mask (1- y-abs)))
@@ -2736,7 +2743,7 @@
   (let* ((y (lvar-value y))
         (y-abs (abs y))
         (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len))
+    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
       (give-up-ir1-transform))
     (let ((mask (1- y-abs)))
       `(if (minusp x)