Fix EQL constraint propagation on constant assigned closure variables

[sbcl.git] / src / compiler / float-tran.lisp

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 6efa676..68c1ccd 100644 (file)
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -102,10 +102,36 @@
 ;;;; float accessors
 
 (defknown make-single-float ((signed-byte 32)) single-float
-  (movable foldable flushable))
+  (movable flushable))
 
 (defknown make-double-float ((signed-byte 32) (unsigned-byte 32)) double-float
-  (movable foldable flushable))
+  (movable flushable))
+
+#-sb-xc-host
+(deftransform make-single-float ((bits)
+                                 ((signed-byte 32)))
+  "Conditional constant folding"
+  (unless (constant-lvar-p bits)
+    (give-up-ir1-transform))
+  (let* ((bits  (lvar-value bits))
+         (float (make-single-float bits)))
+    (when (float-nan-p float)
+      (give-up-ir1-transform))
+    float))
+
+#-sb-xc-host
+(deftransform make-double-float ((hi lo)
+                                 ((signed-byte 32) (unsigned-byte 32)))
+  "Conditional constant folding"
+  (unless (and (constant-lvar-p hi)
+               (constant-lvar-p lo))
+    (give-up-ir1-transform))
+  (let* ((hi    (lvar-value hi))
+         (lo    (lvar-value lo))
+         (float (make-double-float hi lo)))
+    (when (float-nan-p float)
+      (give-up-ir1-transform))
+    float))
 
 (defknown single-float-bits (single-float) (signed-byte 32)
   (movable foldable flushable))
@@ -305,8 +331,11 @@
   ;; problem, but in the context of evaluated and compiled (+ <int> <single>)
   ;; giving different result if we fail to check for this.
   (or (not (csubtypep x (specifier-type 'integer)))
+      #!+x86
       (csubtypep x (specifier-type `(integer ,most-negative-exactly-single-float-fixnum
-                                             ,most-positive-exactly-single-float-fixnum)))))
+                                             ,most-positive-exactly-single-float-fixnum)))
+      #!-x86
+      (csubtypep x (specifier-type 'fixnum))))
 
 ;;; Do some stuff to recognize when the loser is doing mixed float and
 ;;; rational arithmetic, or different float types, and fix it up. If
@@ -922,11 +951,9 @@
                    (int-hi (if hi
                                (ceiling (type-bound-number hi))
                                '*))
-                   (f-lo (if lo
-                             (bound-func #'float lo)
+                   (f-lo (or (bound-func #'float lo)
                              '*))
-                   (f-hi (if hi
-                             (bound-func #'float hi)
+                   (f-hi (or (bound-func #'float hi)
                              '*)))
               (specifier-type `(or (rational ,int-lo ,int-hi)
                                 (single-float ,f-lo, f-hi)))))
@@ -956,11 +983,9 @@
                    (int-hi (if hi
                                (ceiling (type-bound-number hi))
                                '*))
-                   (f-lo (if lo
-                             (bound-func #'float lo)
+                   (f-lo (or (bound-func #'float lo)
                              '*))
-                   (f-hi (if hi
-                             (bound-func #'float hi)
+                   (f-hi (or (bound-func #'float hi)
                              '*)))
               (specifier-type `(or (rational ,int-lo ,int-hi)
                                 (single-float ,f-lo, f-hi)))))
@@ -1522,16 +1547,19 @@
                                         (,type
                                          &optional (or ,type ,@other-float-arg-types integer))
                                         * :result result)
-                  (let ((result-type (lvar-derived-type result)))
+                  (let* ((result-type (and result
+                                           (lvar-derived-type result)))
+                         (compute-all (and (values-type-p result-type)
+                                           (not (type-single-value-p result-type)))))
                     (if (or (not y)
                             (and (constant-lvar-p y) (= 1 (lvar-value y))))
-                        (if (values-type-p result-type)
+                        (if compute-all
                             `(let ((res (,',unary x)))
                                (values res (- x (,',coerce res))))
                             `(let ((res (,',unary x)))
                                ;; Dummy secondary value!
                                (values res x)))
-                        (if (values-type-p result-type)
+                        (if compute-all
                             `(let* ((f (,',coerce y))
                                     (res (,',unary (/ x f))))
                                (values res (- x (* f (,',coerce res)))))