Merge branch 'master' into mswinmt

NEWS

@@ -1,4 +1,7 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-1.0.55:
+  * bug fix: compiler errors when weakening hairy integer types. (lp#913232)
+
 changes in sbcl-1.0.55 relative to sbcl-1.0.54:
   * enhancements to building SBCL using make.sh:
     ** --fancy can be specified to enable all supported feature enhancements.

src/compiler/array-tran.lisp

@@ -180,9 +180,11 @@
         (flet ((subscript-bounds (subscript)
                  (let* ((type1 (lvar-type subscript))
                         (type2 (if (csubtypep type1 (specifier-type 'integer))
-                                   (weaken-integer-type type1)
+                                   (weaken-integer-type type1 :range-only t)
                                    (give-up)))
-                        (low (numeric-type-low type2))
+                        (low (if (integer-type-p type2)
+                                 (numeric-type-low type2)
+                                 (give-up)))
                         (high (numeric-type-high type2)))
                    (cond
                      ((and (or (not (bound-known-p low)) (minusp low))

src/compiler/checkgen.lisp

@@ -77,27 +77,58 @@
         (t
          (fun-guessed-cost 'typep)))))
 
-(defun weaken-integer-type (type)
-  (cond ((union-type-p type)
-         (let* ((types (union-type-types type))
-                (one (pop types))
-                (low (numeric-type-low one))
-                (high (numeric-type-high one)))
-           (flet ((maximize (bound)
-                    (if (and bound high)
-                        (setf high (max high bound))
-                        (setf high nil)))
-                  (minimize (bound)
-                    (if (and bound low)
-                        (setf low (min low bound))
-                        (setf low nil))))
-             (dolist (a types)
-               (minimize (numeric-type-low a))
-               (maximize (numeric-type-high a))))
-           (specifier-type `(integer ,(or low '*) ,(or high '*)))))
-        (t
-         (aver (integer-type-p type))
-         type)))
+(defun weaken-integer-type (type &key range-only)
+  ;; FIXME: Our canonicalization isn't quite ideal for this. We get
+  ;; types such as:
+  ;;
+  ;;      (OR (AND (SATISFIES FOO) (INTEGER -100 -50))
+  ;;          (AND (SATISFIES FOO) (INTEGER 100 200)))
+  ;;
+  ;; here, and weakening that into
+  ;;
+  ;;     (AND (SATISFIES FOO) (INTEGER -100 200))
+  ;;
+  ;; is too much work to do here ... but if we canonicalized things
+  ;; differently, we could get it for free with trivial changes here.
+  (labels ((weaken-integer-type-part (type base)
+             (cond ((intersection-type-p type)
+                    (let ((new (specifier-type base)))
+                      (dolist (part (intersection-type-types type))
+                        (when (if range-only
+                                  (numeric-type-p part)
+                                  (not (unknown-type-p part)))
+                          (setf new (type-intersection
+                                     new (weaken-integer-type-part part t)))))
+                      new))
+                   ((union-type-p type)
+                    (let ((low t) (high t) (rest *empty-type*))
+                      (flet ((maximize (bound)
+                               (if (and bound high)
+                                   (setf high (if (eq t high)
+                                                  bound
+                                                  (max high bound)))
+                                   (setf high nil)))
+                             (minimize (bound)
+                               (if (and bound low)
+                                   (setf low (if (eq t low)
+                                                 bound
+                                                 (min low bound)))
+                                   (setf low nil))))
+                        (dolist (part (union-type-types type))
+                          (let ((weak (weaken-integer-type-part part t)))
+                            (cond ((numeric-type-p weak)
+                                   (minimize (numeric-type-low weak))
+                                   (maximize (numeric-type-high weak)))
+                                  ((not range-only)
+                                   (setf rest (type-union rest weak)))))))
+                      (if (eq t low)
+                          rest
+                          (type-union rest
+                                      (specifier-type
+                                       `(integer ,(or low '*) ,(or high '*)))))))
+                   (t
+                    type))))
+    (weaken-integer-type-part type 'integer)))
 
 (defun-cached
     (weaken-type :hash-bits 8
@@ -108,9 +139,10 @@
   (cond ((named-type-p type)
          type)
         ((csubtypep type (specifier-type 'integer))
-         ;; KLUDGE: Simple range checks are not that expensive, and we *don't*
-         ;; want to accidentally lose eg. array bounds checks due to weakening,
-         ;; so for integer types we simply collapse all ranges into one.
+         ;; Simple range checks are not that expensive, and we *don't*
+         ;; want to accidentally lose eg. array bounds checks due to
+         ;; weakening, so for integer types we simply collapse all
+         ;; ranges into one.
          (weaken-integer-type type))
         (t
          (let ((min-cost (type-test-cost type))

tests/compiler.pure.lisp

@@ -4167,3 +4167,15 @@
                   (declare (type (integer -1 -1) d))
                   (let ((i (unwind-protect 32 (shiftf d -1))))
                     (or (if (= d c)  2 (= 3 b)) 4)))))
+
+(with-test (:name :bug-913232)
+  (compile nil `(lambda (x)
+                  (declare (optimize speed)
+                           (type (or (and (or (integer -100 -50)
+                                              (integer 100 200)) (satisfies foo))
+                                     (and (or (integer 0 10) (integer 20 30)) a)) x))
+                  x))
+  (compile nil `(lambda (x)
+                  (declare (optimize speed)
+                           (type (and fixnum a) x))
+                  x)))