1.0.18.2: more conservative interval artihmetic

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

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 5ae92be..764e617 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -342,6 +342,37 @@
                nil
                (set-bound y (consp x)))))))
 
+(defun safe-double-coercion-p (x)
+  (or (typep x 'double-float)
+      (<= most-negative-double-float x most-positive-double-float)))
+
+(defun safe-single-coercion-p (x)
+  (or (typep x 'single-float)
+      ;; Fix for bug 420, and related issues: during type derivation we often
+      ;; end up deriving types for both
+      ;;
+      ;;   (some-op <int> <single>)
+      ;; and
+      ;;   (some-op (coerce <int> 'single-float) <single>)
+      ;;
+      ;; or other equivalent transformed forms. The problem with this is that
+      ;; on some platforms like x86 (+ <int> <single>) is on the machine level
+      ;; equivalent of
+      ;;
+      ;;   (coerce (+ (coerce <int> 'double-float)
+      ;;              (coerce <single> 'double-float))
+      ;;           'single-float)
+      ;;
+      ;; so if the result of (coerce <int> 'single-float) is not exact, the
+      ;; derived types for the transformed forms will have an empty
+      ;; intersection -- which in turn means that the compiler will conclude
+      ;; that the call never returns, and all hell breaks lose when it *does*
+      ;; return at runtime. (This affects not just +, but other operators are
+      ;; well.)
+      (and (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
+                              (integer (,most-positive-exactly-single-float-fixnum) *))))
+           (<= most-negative-single-float x most-positive-single-float))))
+
 ;;; Apply a binary operator OP to two bounds X and Y. The result is
 ;;; NIL if either is NIL. Otherwise bound is computed and the result
 ;;; is open if either X or Y is open.
@@ -355,21 +386,19 @@
 
 (defmacro safely-binop (op x y)
   `(cond
-    ((typep ,x 'single-float)
-     (if (or (typep ,y 'single-float)
-             (<= most-negative-single-float ,y most-positive-single-float))
-         (,op ,x ,y)))
-    ((typep ,x 'double-float)
-     (if (or (typep ,y 'double-float)
-             (<= most-negative-double-float ,y most-positive-double-float))
-         (,op ,x ,y)))
-    ((typep ,y 'single-float)
-     (if (<= most-negative-single-float ,x most-positive-single-float)
-         (,op ,x ,y)))
-    ((typep ,y 'double-float)
-     (if (<= most-negative-double-float ,x most-positive-double-float)
-         (,op ,x ,y)))
-    (t (,op ,x ,y))))
+     ((typep ,x 'double-float)
+      (when (safe-double-coercion-p ,y)
+        (,op ,x ,y)))
+     ((typep ,y 'double-float)
+      (when (safe-double-coercion-p ,x)
+        (,op ,x ,y)))
+     ((typep ,x 'single-float)
+      (when (safe-single-coercion-p ,y)
+        (,op ,x ,y)))
+     ((typep ,y 'single-float)
+      (when (safe-single-coercion-p ,x)
+        (,op ,x ,y)))
+     (t (,op ,x ,y))))
 
 (defmacro bound-binop (op x y)
   `(and ,x ,y