X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=50d4d3c2b671498e0a19215fcb7b9e8ccf012edb;hb=dbe82b489260b2ef76e916d0aeaee8b3850f5f52;hp=22186ad7270fad7f2f7602ee8aadb1f2219c907b;hpb=38cf000d1082aa571d2f7245a7812023e1c8e065;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 22186ad..50d4d3c 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -1127,21 +1127,26 @@
     (t
      type-list)))
 
-;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
-;;; belong in the kernel's type logic, invoked always, instead of in
-;;; the compiler, invoked only during some type optimizations. (In
-;;; fact, as of 0.pre8.100 or so they probably are, under
-;;; MAKE-MEMBER-TYPE, so probably this code can be deleted)
-
 ;;; Take a list of types and return a canonical type specifier,
 ;;; combining any MEMBER types together. If both positive and negative
 ;;; MEMBER types are present they are converted to a float type.
 ;;; XXX This would be far simpler if the type-union methods could handle
 ;;; member/number unions.
-(defun make-canonical-union-type (type-list)
+;;;
+;;; If we're about to generate an overly complex union of numeric types, start
+;;; collapse the ranges together.
+;;;
+;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
+;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
+;;; invoked always, instead of in the compiler, invoked only during some type
+;;; optimizations.
+(defvar *derived-numeric-union-complexity-limit* 6)
+
+(defun make-derived-union-type (type-list)
   (let ((xset (alloc-xset))
         (fp-zeroes '())
-        (misc-types '()))
+        (misc-types '())
+        (numeric-type *empty-type*))
     (dolist (type type-list)
       (cond ((member-type-p type)
              (mapc-member-type-members
@@ -1151,11 +1156,19 @@
                       (pushnew member fp-zeroes))
                     (add-to-xset member xset)))
               type))
+            ((numeric-type-p type)
+             (let ((*approximate-numeric-unions*
+                    (when (and (union-type-p numeric-type)
+                               (nthcdr *derived-numeric-union-complexity-limit*
+                                       (union-type-types numeric-type)))
+                      t)))
+               (setf numeric-type (type-union type numeric-type))))
             (t
              (push type misc-types))))
     (if (and (xset-empty-p xset) (not fp-zeroes))
-        (apply #'type-union misc-types)
-        (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types))))
+        (apply #'type-union numeric-type misc-types)
+        (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes)
+               numeric-type misc-types))))
 
 ;;; Convert a member type with a single member to a numeric type.
 (defun convert-member-type (arg)
@@ -1220,7 +1233,7 @@
                   (setf results (append results result))
                   (push result results))))
           (if (rest results)
-              (make-canonical-union-type results)
+              (make-derived-union-type results)
               (first results)))))))
 
 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
@@ -1293,7 +1306,7 @@
                         (setf results (append results result))
                         (push result results))))))
           (if (rest results)
-              (make-canonical-union-type results)
+              (make-derived-union-type results)
               (first results)))))))
 
 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
@@ -1815,6 +1828,10 @@
                            (let* ((interval (numeric-type->interval n))
                                   (low      (interval-low interval))
                                   (high     (interval-high interval)))
+                             (when (consp low)
+                               (setf low (car low)))
+                             (when (consp high)
+                               (setf high (car high)))
                              (specifier-type
                               `(integer ,(if low
                                              (round low)
@@ -3952,7 +3969,7 @@
                            :format-arguments
                            (list nargs 'cerror y x (max max1 max2))))))))))))))
 
-(defoptimizer (coerce derive-type) ((value type))
+(defoptimizer (coerce derive-type) ((value type) node)
   (cond
     ((constant-lvar-p type)
      ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
@@ -3997,7 +4014,17 @@
              (type-union result-typeoid
                          (type-intersection (lvar-type value)
                                             (specifier-type 'rational))))))
-         (t result-typeoid))))
+         ((and (policy node (zerop safety))
+               (csubtypep result-typeoid (specifier-type '(array * (*)))))
+          ;; At zero safety the deftransform for COERCE can elide dimension
+          ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we
+          ;; need to simplify the type to drop the dimension information.
+          (let ((vtype (simplify-vector-type result-typeoid)))
+            (if vtype
+                (specifier-type vtype)
+                result-typeoid)))
+         (t
+          result-typeoid))))
     (t
      ;; OK, the result-type argument isn't constant.  However, there
      ;; are common uses where we can still do better than just