X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=231ce84ebe5aa8b1f7ea5dd5bdf8711ade2cff17;hb=74a1797f60e26c7adbc491840f89bbaab08e504d;hp=37c3a73e627a212f83f5b3b5add71561e37fbcf0;hpb=4413876742e64de8a5925c98d1925ba9e5f75d8d;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 37c3a73..231ce84 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -123,10 +123,15 @@
     (t (values nil t))))
 
 ;;; And similarly for LIST*.
-(define-source-transform list* (&rest args)
-  (case (length args)
-    (2 `(cons ,(first args) ,(second args)))
-    (t (values nil t))))
+(define-source-transform list* (arg &rest others)
+  (cond ((not others) arg)
+        ((not (cdr others)) `(cons ,arg ,(car others)))
+        (t (values nil t))))
+
+(defoptimizer (list* derive-type) ((arg &rest args))
+  (if args
+      (specifier-type 'cons)
+      (lvar-type arg)))
 
 ;;; Translate RPLACx to LET and SETF.
 (define-source-transform rplaca (x y)
@@ -337,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.
@@ -350,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
@@ -3956,7 +3990,7 @@
                           (eq (first (second good-cons-type)) 'member))
                      `(,(second (second good-cons-type))
                        ,@(unconsify-type (caddr good-cons-type))))))
-            (coerceable-p (c-type)
+            (coerceable-p (part)
               ;; Can the value be coerced to the given type?  Coerce is
               ;; complicated, so we don't handle every possible case
               ;; here---just the most common and easiest cases:
@@ -3978,13 +4012,14 @@
               ;; the requested type, because (by assumption) COMPLEX
               ;; (and other difficult types like (COMPLEX INTEGER)
               ;; aren't specialized types.
-              (let ((coerced-type c-type))
-                (or (and (subtypep coerced-type 'float)
-                         (csubtypep value-type (specifier-type 'real)))
-                    (and (subtypep coerced-type
-                                   '(or (complex single-float)
-                                        (complex double-float)))
-                         (csubtypep value-type (specifier-type 'number))))))
+              (let ((coerced-type (careful-specifier-type part)))
+                (when coerced-type
+                  (or (and (csubtypep coerced-type (specifier-type 'float))
+                           (csubtypep value-type (specifier-type 'real)))
+                      (and (csubtypep coerced-type
+                                      (specifier-type `(or (complex single-float)
+                                                           (complex double-float))))
+                          (csubtypep value-type (specifier-type 'number)))))))
             (process-types (type)
               ;; FIXME: This needs some work because we should be able
               ;; to derive the resulting type better than just the