From: Nikodemus Siivola Date: Mon, 18 Oct 2010 11:42:47 +0000 (+0000) Subject: 1.0.43.67: COERCE: don't trust vector dimensions in unsafe code X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7619132f587e6d30935a38cd19da7d0d80dbc7a3;p=sbcl.git 1.0.43.67: COERCE: don't trust vector dimensions in unsafe code Fixes bug 655872. Our deftransform for COERCE takes advantage of ANSI's allowance to generate faster code, and open codes (COERCE X '(SIMPLE-VECTOR 5)) in a way that doesn't verify the length of the simple-vector. 1. Previously we did that for SAFETY < 3, but that doesn't really fit with our general policy, so enable it only for SAFETY = 0. 2. Make the corresponding DERIVE-TYPE optimizer aware of this, so that it can drop the dimensions from the type when necessary. --- diff --git a/NEWS b/NEWS index 24422fb..97e9aca 100644 --- a/NEWS +++ b/NEWS @@ -76,6 +76,9 @@ changes relative to sbcl-1.0.43: under different names. (lp#661631, regression from 1.0.29.24) * bug fix: source-locations of DEFGENERIC forms weren't getting recorded properly. (lp#384801) + * bug fix: (COERCE X '(SIMPLE-VECTOR 5)) and similar coercions to vectors + of specified length could confuse the type derivation in unsafe code. + (lp#655872) changes in sbcl-1.0.43 relative to sbcl-1.0.42: * incompatible change: FD-STREAMS no longer participate in the serve-event diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 72c2695..76d880a 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3956,7 +3956,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), @@ -4001,7 +4001,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 diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 4f1fa05..3c000d5 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -623,6 +623,30 @@ (constant-fold-call node) t)))) +;;; Drops dimension information from vector types. +(defun simplify-vector-type (type) + (aver (csubtypep type (specifier-type '(array * (*))))) + (let* ((array-type + (if (csubtypep type (specifier-type 'simple-array)) + 'simple-array + 'array)) + (complexp + (not + (or (eq 'simple-array array-type) + (neq *empty-type* + (type-intersection type (specifier-type 'simple-array))))))) + (dolist (etype + #+sb-xc-host '(t bit character) + #-sb-xc-host sb!kernel::*specialized-array-element-types* + #+sb-xc-host (values nil nil nil) + #-sb-xc-host (values `(,array-type * (*)) t complexp)) + (when etype + (let ((simplified (specifier-type `(,array-type ,etype (*))))) + (when (csubtypep type simplified) + (return (values (type-specifier simplified) + etype + complexp)))))))) + (deftransform coerce ((x type) (* *) * :node node) (unless (constant-lvar-p type) (give-up-ir1-transform)) @@ -630,65 +654,55 @@ (tspec (ir1-transform-specifier-type tval))) (if (csubtypep (lvar-type x) tspec) 'x - ;; Note: The THE here makes sure that specifiers like - ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR. - `(the ,(lvar-value type) - ,(cond - ((csubtypep tspec (specifier-type 'double-float)) - '(%double-float x)) - ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) - ((csubtypep tspec (specifier-type 'float)) - '(%single-float x)) - ;; Special case STRING and SIMPLE-STRING as they are union types - ;; in SBCL. - ((member tval '(string simple-string)) - `(if (typep x ',tval) + ;; Note: The THE forms we use to wrap the results make sure that + ;; specifiers like (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR. + (cond + ((csubtypep tspec (specifier-type 'double-float)) + `(the ,tval (%double-float x))) + ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) + ((csubtypep tspec (specifier-type 'float)) + `(the ,tval (%single-float x))) + ;; Special case STRING and SIMPLE-STRING as they are union types + ;; in SBCL. + ((member tval '(string simple-string)) + `(the ,tval + (if (typep x ',tval) x - (replace (make-array (length x) :element-type 'character) x))) - ;; Special case VECTOR - ((eq tval 'vector) - `(if (vectorp x) + (replace (make-array (length x) :element-type 'character) x)))) + ;; Special case VECTOR + ((eq tval 'vector) + `(the ,tval + (if (vectorp x) x - (replace (make-array (length x)) x))) - ;; Handle specialized element types for 1D arrays. - ((csubtypep tspec (specifier-type '(array * (*)))) - ;; Can we avoid checking for dimension issues like (COERCE FOO - ;; '(SIMPLE-VECTOR 5)) returning a vector of length 6? - (if (or (policy node (< safety 3)) ; no need in unsafe code - (and (array-type-p tspec) ; no need when no dimensions - (equal (array-type-dimensions tspec) '(*)))) - ;; We can! - (let ((array-type - (if (csubtypep tspec (specifier-type 'simple-array)) - 'simple-array - 'array))) - (dolist (etype - #+sb-xc-host '(t bit character) - #-sb-xc-host sb!kernel::*specialized-array-element-types* - (give-up-ir1-transform)) - (when etype - (let ((spec `(,array-type ,etype (*)))) - (when (csubtypep tspec (specifier-type spec)) - ;; Is the result required to be non-simple? - (let ((result-simple - (or (eq 'simple-array array-type) - (neq *empty-type* - (type-intersection - tspec (specifier-type 'simple-array)))))) - (return - `(if (typep x ',spec) - x - (replace - (make-array (length x) :element-type ',etype - ,@(unless result-simple - (list :fill-pointer t - :adjustable t))) - x))))))))) - ;; No, duh. Dimension checking required. - (give-up-ir1-transform - "~@<~S specifies dimensions other than (*) in safe code.~:@>" - tval))) - (t - (give-up-ir1-transform - "~@" - tval))))))) + (replace (make-array (length x)) x)))) + ;; Handle specialized element types for 1D arrays. + ((csubtypep tspec (specifier-type '(array * (*)))) + ;; Can we avoid checking for dimension issues like (COERCE FOO + ;; '(SIMPLE-VECTOR 5)) returning a vector of length 6? + ;; + ;; CLHS actually allows this for all code with SAFETY < 3, + ;; but we're a conservative bunch. + (if (or (policy node (zerop safety)) ; no need in unsafe code + (and (array-type-p tspec) ; no need when no dimensions + (equal (array-type-dimensions tspec) '(*)))) + ;; We can! + (multiple-value-bind (vtype etype complexp) (simplify-vector-type tspec) + (unless vtype + (give-up-ir1-transform)) + `(the ,vtype + (if (typep x ',vtype) + x + (replace + (make-array (length x) :element-type ',etype + ,@(when complexp + (list :fill-pointer t + :adjustable t))) + x)))) + ;; No, duh. Dimension checking required. + (give-up-ir1-transform + "~@<~S specifies dimensions other than (*) in safe code.~:@>" + tval))) + (t + (give-up-ir1-transform + "~@" + tval)))))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 074ef9a..c74f9b4 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3599,3 +3599,24 @@ (declare (type (integer 0 0) x)) (ash x 100))))) (assert (zerop (funcall fun 0))))) + +(with-test (:name :bug-655872) + (let ((f (compile nil `(lambda (x) + (declare (optimize (safety 3))) + (aref (locally (declare (optimize (safety 0))) + (coerce x '(simple-vector 128))) + 60)))) + (long (make-array 100 :element-type 'fixnum))) + (dotimes (i 100) + (setf (aref long i) i)) + ;; 1. COERCE doesn't check the length in unsafe code. + (assert (eql 60 (funcall f long))) + ;; 2. The compiler doesn't trust the length from COERCE + (assert (eq :caught + (handler-case + (funcall f (list 1 2 3)) + (sb-int:invalid-array-index-error (e) + (assert (eql 60 (type-error-datum e))) + (assert (equal '(integer 0 (3)) (type-error-expected-type e))) + :caught)))))) + diff --git a/version.lisp-expr b/version.lisp-expr index db56d29..f38d76c 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.43.66" +"1.0.43.67"