1.0.28.48: fix regressions from 1.0.28.47

  * Assert the declared element-type in the
    HAIRY-DATA-VECTOR-(REF|SET)/CHECK-BOUNDS transform, since
    HAIRY-DATA-VECTOR-(REF|SET) transforms no longer fire for
    non-simple arrays.

  * Turns out that %DATA-VECTOR-AND-INDEX was the only place where the
    index was checked being non-negative on some code paths -- not
    taking that route meant that type check weakening from INDEX to
    FIXNUM allowed negative indexes to slip in under the the radar in
    SAFETY 1 code.

    While this follows what we say in the manual, being more careful
    about bounds checks is probably a good idea, so be more
    conservative about weakenin integer types: collapse unions of
    intervals into a single interval, but dont' eliminate the most
    extreme bounds.

    Adjust one test that checked for the old behaviour, and
    update documentation.

NEWS

@@ -1,4 +1,6 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
+  * minor incompatible change: under weak type checking policy integer
+    types are weakened less aggressively.
   * minor incompatible change: SAVE-LISP-AND-DIE :TOPLEVEL function is now
     allowed to return, which causes SBCL to quit with exit status 0. Previously
     if the function returned with a small integer return value, that value

doc/manual/compiler.texinfo

@@ -528,8 +528,9 @@ provides full type checks.
 Used when @code{(or (>= safety 2) (>= safety speed 1))}.
 
 @item Weak Type Checks
-Declared types may be simplified into faster to check supertypes: for example,
-@code{(and unsigned-byte fixnum)} is simplified into @code{fixnum}.
+Declared types may be simplified into faster to check supertypes: for
+example, @code{(or (integer -17 -7) (integer 7 17))} is simplified
+into @code{(integer -17 17)}.
 
 @strong{Note}: it is relatively easy to corrupt the heap when weak
 type checks are used if the program contains type-errors.

src/compiler/array-tran.lisp

@@ -845,7 +845,8 @@
              (declare (ignore extra-type))
              `(deftransform ,name ((array index ,@extra))
                 (let ((type (lvar-type array))
-                      (element-type (extract-upgraded-element-type array)))
+                      (element-type (extract-upgraded-element-type array))
+                      (declared-type (extract-declared-element-type array)))
                   ;; If an element type has been declared, we want to
                   ;; use that information it for type checking (even
                   ;; if the access can't be optimized due to the array
@@ -860,12 +861,19 @@
                               ;; to inline the access completely.
                               (not (null (array-type-complexp type))))
                       (give-up-ir1-transform
-                       "Upgraded element type of array is not known at compile time."))))
-                `(,',transform-to array
-                                  (%check-bound array
-                                                (array-dimension array 0)
-                                                index)
-                                  ,@',extra))))
+                       "Upgraded element type of array is not known at compile time.")))
+                  ,(if extra
+                       ``(truly-the ,declared-type
+                                    (,',transform-to array
+                                                     (%check-bound array
+                                                                   (array-dimension array 0)
+                                                                   index)
+                                                     (the ,declared-type ,@',extra)))
+                       ``(the ,declared-type
+                           (,',transform-to array
+                                            (%check-bound array
+                                                          (array-dimension array 0)
+                                                          index))))))))
   (define hairy-data-vector-ref/check-bounds
       hairy-data-vector-ref nil nil)
   (define hairy-data-vector-set/check-bounds

src/compiler/checkgen.lisp

@@ -77,39 +77,69 @@
         (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-cached
     (weaken-type :hash-bits 8
                  :hash-function (lambda (x)
                                   (logand (type-hash-value x) #xFF)))
     ((type eq))
   (declare (type ctype type))
-  (let ((min-cost (type-test-cost type))
-        (min-type type)
-        (found-super nil))
-    (dolist (x *backend-type-predicates*)
-      (let* ((stype (car x))
-             (samep (type= stype type)))
-        (when (or samep
-                  (and (csubtypep type stype)
-                       (not (union-type-p stype))))
-          (let ((stype-cost (type-test-cost stype)))
-            (when (or (< stype-cost min-cost)
-                      samep)
-              ;; If the supertype is equal in cost to the type, we
-              ;; prefer the supertype. This produces a closer
-              ;; approximation of the right thing in the presence of
-              ;; poor cost info.
-              (setq found-super t
-                    min-type stype
-                    min-cost stype-cost))))))
-    ;; This used to return the *UNIVERSAL-TYPE* if no supertype was found,
-    ;; but that's too liberal: it's far too easy for the user to create
-    ;; a union type (which are excluded above), and then trick the compiler
-    ;; into trusting the union type... and finally ending up corrupting the
-    ;; heap once a bad object sneaks past the missing type check.
-    (if found-super
-        min-type
-        type)))
+  (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.
+         (weaken-integer-type type))
+        (t
+         (let ((min-cost (type-test-cost type))
+               (min-type type)
+               (found-super nil))
+           (dolist (x *backend-type-predicates*)
+             (let* ((stype (car x))
+                    (samep (type= stype type)))
+               (when (or samep
+                         (and (csubtypep type stype)
+                              (not (union-type-p stype))))
+                 (let ((stype-cost (type-test-cost stype)))
+                   (when (or (< stype-cost min-cost)
+                             samep)
+                     ;; If the supertype is equal in cost to the type, we
+                     ;; prefer the supertype. This produces a closer
+                     ;; approximation of the right thing in the presence of
+                     ;; poor cost info.
+                     (setq found-super t
+                           min-type stype
+                           min-cost stype-cost))))))
+           ;; This used to return the *UNIVERSAL-TYPE* if no supertype was found,
+           ;; but that's too liberal: it's far too easy for the user to create
+           ;; a union type (which are excluded above), and then trick the compiler
+           ;; into trusting the union type... and finally ending up corrupting the
+           ;; heap once a bad object sneaks past the missing type check.
+           (if found-super
+               min-type
+               type)))))
 
 (defun weaken-values-type (type)
   (declare (type ctype type))

tests/compiler.impure.lisp

@@ -618,7 +618,7 @@
 (assert (equal (check-embedded-thes 3 0  2 :a) '(2 :a)))
 (assert (typep (check-embedded-thes 3 0  4 2.5f0) 'type-error))
 
-(assert (equal (check-embedded-thes 1 0  4 :b) '(4 :b)))
+(assert (equal (check-embedded-thes 1 0  3 :b) '(3 :b)))
 (assert (typep (check-embedded-thes 1 0  1.0 2.5f0) 'type-error))
 
 

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.28.47"
+"1.0.28.48"