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 (file)
--- 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 (file)
--- 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 (file)
--- 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
-               "~@<open coding coercion to ~S not implemented.~:@>"
-               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
+             "~@<open coding coercion to ~S not implemented.~:@>"
+             tval))))))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 074ef9a..c74f9b4 100644 (file)
--- 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 (file)
--- 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"