diff --git a/NEWS b/NEWS index bad4a4bcb..00245a4c6 100644 --- a/NEWS +++ b/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 diff --git a/doc/manual/compiler.texinfo b/doc/manual/compiler.texinfo index a3cb00c91..0c03d9874 100644 --- a/doc/manual/compiler.texinfo +++ b/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. diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 899b43e78..580bda619 100644 --- a/src/compiler/array-tran.lisp +++ b/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 diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 5bcdee08c..addf02547 100644 --- a/src/compiler/checkgen.lisp +++ b/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)) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 06f52a516..151f4002e 100644 --- a/tests/compiler.impure.lisp +++ b/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)) diff --git a/version.lisp-expr b/version.lisp-expr index 5056fe21a..0a1e0672f 100644 --- a/version.lisp-expr +++ b/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"