From: Nikodemus S. <de...@us...> - 2009-05-15 21:11:49
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv6113/src/compiler Modified Files: array-tran.lisp checkgen.lisp Log Message: 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. Index: array-tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v retrieving revision 1.88 retrieving revision 1.89 diff -u -d -r1.88 -r1.89 --- array-tran.lisp 12 May 2009 09:11:39 -0000 1.88 +++ array-tran.lisp 15 May 2009 21:11:45 -0000 1.89 @@ -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 Index: checkgen.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/checkgen.lisp,v retrieving revision 1.48 retrieving revision 1.49 diff -u -d -r1.48 -r1.49 --- checkgen.lisp 17 Dec 2007 13:34:28 -0000 1.48 +++ checkgen.lisp 15 May 2009 21:11:45 -0000 1.49 @@ -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)) |