From 4bc9a2b01540f3a7cbf4499b4689b292fe406139 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 27 Jun 2003 10:07:44 +0000 Subject: [PATCH] 0.8.1.9: Implement slightly DWIMish behaviour for (TYPE (ARRAY FOO ..) ..) declarations, as discussed on the CLHS "Declaration TYPE" page, and on sbcl-help circa 2003-05-08 and with Fufie on #lisp around 2003-06-24 ... We need the target's UPGRADED-ARRAY-ELEMENT-TYPE, so move the definition and define it in SB!XC ... use it (carefully) in MAKE-ARRAY optimizers and transforms, because the declaration behaviour we're implementing doesn't extend to (MAKE-ARRAY .. :ELEMENT-TYPE 'FOO) ... insert appropriate THEs in HAIRY-DATA-VECTOR-{REF,SET} if the declared array element type isn't the same as the declared upgraded element type --- NEWS | 8 ++++++++ src/code/array.lisp | 9 --------- src/code/late-type.lisp | 5 ++++- src/cold/defun-load-or-cload-xcompiler.lisp | 1 + src/compiler/array-tran.lisp | 28 +++++++++++++++++++++++---- src/compiler/debug-dump.lisp | 2 ++ src/compiler/fndb.lisp | 2 +- src/compiler/generic/vm-tran.lisp | 21 ++++++++++++++------ src/compiler/generic/vm-type.lisp | 10 ++++++++++ tests/array.pure.lisp | 3 +++ tests/compiler-1.impure-cload.lisp | 8 +++++--- tests/compiler.pure.lisp | 5 +++++ version.lisp-expr | 2 +- 13 files changed, 79 insertions(+), 25 deletions(-) diff --git a/NEWS b/NEWS index d42783f..10ff16b 100644 --- a/NEWS +++ b/NEWS @@ -1890,6 +1890,14 @@ changes in sbcl-0.8.2 relative to sbcl-0.8.1: circumstances could go off-by-one. * improved MACHINE-VERSION, especially on Linux (thanks to Lars Brinkhoff) + * type declarations for array element types now obey the description + on the CLHS page "Declaration TYPE", as per discussions on + sbcl-help around 2003-05-08. This means that a declaration + (TYPE (ARRAY FOO) BAR) means that, within the scope of the + declaration, all references to BAR will be asserted or assumed + (with THE, so dependent on compiler policy) to involve objects of + type FOO. Note that no such declaration is implied in + (MAKE-ARRAY .. :ELEMENT-TYPE 'FOO). planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/array.lisp b/src/code/array.lisp index 5f0709f..d8d04e9 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -65,15 +65,6 @@ (bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?")) ;;;; MAKE-ARRAY -(defun upgraded-array-element-type (spec &optional environment) - #!+sb-doc - "Return the element type that will actually be used to implement an array - with the specifier :ELEMENT-TYPE Spec." - (declare (ignore environment)) - (if (unknown-type-p (specifier-type spec)) - (error "undefined type: ~S" spec) - (type-specifier (array-type-specialized-element-type - (specifier-type `(array ,spec)))))) (eval-when (:compile-toplevel :execute) (sb!xc:defmacro pick-vector-type (type &rest specs) `(cond ,@(mapcar (lambda (spec) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 8e07447..5e00418 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -2294,7 +2294,10 @@ (mapcar (lambda (x y) (if (eq x '*) y x)) dims1 dims2))) :complexp (if (eq complexp1 :maybe) complexp2 complexp1) - :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1)))) + :element-type (cond + ((eq eltype1 *wild-type*) eltype2) + ((eq eltype2 *wild-type*) eltype1) + (t (type-intersection eltype1 eltype2)))))) *empty-type*)) ;;; Check a supplied dimension list to determine whether it is legal, diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp index c61e18b..916b026 100644 --- a/src/cold/defun-load-or-cload-xcompiler.lisp +++ b/src/cold/defun-load-or-cload-xcompiler.lisp @@ -123,6 +123,7 @@ "STRUCTURE-CLASS" "SUBTYPEP" "TYPE-OF" "TYPEP" + "UPGRADED-ARRAY-ELEMENT-TYPE" "WITH-COMPILATION-UNIT")) (export (intern name package-name) package-name))) ;; don't watch: diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index d0f9baf..f9a4947 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -41,6 +41,12 @@ ;; 2002-08-21 *wild-type*))) +(defun extract-declared-element-type (array) + (let ((type (continuation-type array))) + (if (array-type-p type) + (array-type-element-type type) + *wild-type*))) + ;;; The ``new-value'' for array setters must fit in the array, and the ;;; return type is going to be the same as the new-value for SETF ;;; functions. @@ -136,7 +142,12 @@ `(,(if simple 'simple-array 'array) ,(cond ((not element-type) t) ((constant-continuation-p element-type) - (continuation-value element-type)) + (let ((ctype (careful-specifier-type + (continuation-value element-type)))) + (cond + ((or (null ctype) (unknown-type-p ctype)) '*) + (t (sb!xc:upgraded-array-element-type + (continuation-value element-type)))))) (t '*)) ,(cond ((constant-continuation-p dims) @@ -338,8 +349,14 @@ (len (if (constant-continuation-p length) (continuation-value length) '*)) - (result-type-spec `(simple-array ,eltype (,len))) (eltype-type (ir1-transform-specifier-type eltype)) + (result-type-spec + `(simple-array + ,(if (unknown-type-p eltype-type) + (give-up-ir1-transform + "ELEMENT-TYPE is an unknown type: ~S" eltype) + (sb!xc:upgraded-array-element-type eltype)) + (,len))) (saetp (find-if (lambda (saetp) (csubtypep eltype-type (saetp-ctype saetp))) *specialized-array-element-type-properties*))) @@ -415,8 +432,11 @@ (rank (length dims)) (spec `(simple-array ,(cond ((null element-type) t) - ((constant-continuation-p element-type) - (continuation-value element-type)) + ((and (constant-continuation-p element-type) + (ir1-transform-specifier-type + (continuation-value element-type))) + (sb!xc:upgraded-array-element-type + (continuation-value element-type))) (t '*)) ,(make-list rank :initial-element '*)))) `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank))) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 19f6a0f..bf9bfbb 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -303,6 +303,8 @@ ;; SIGNED-BYTE arrays, so better make it break now if it ever ;; will: #+sb-xc-host + ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are + ;; worried about whether the host's implementation of arrays. (aver (subtypep (upgraded-array-element-type specializer) 'unsigned-byte)) (coerce seq `(simple-array ,specializer (*))))))) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index e5d27c7..e394ac4 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -44,7 +44,7 @@ (defknown type-of (t) t (foldable flushable)) ;;; These can be affected by type definitions, so they're not FOLDABLE. -(defknown (upgraded-complex-part-type upgraded-array-element-type) +(defknown (upgraded-complex-part-type sb!xc:upgraded-array-element-type) (type-specifier &optional lexenv-designator) type-specifier (unsafely-flushable)) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 852a086..634e687 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -43,7 +43,8 @@ (deftransform hairy-data-vector-ref ((array index) (array t) * :important t) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array))) + (let ((element-ctype (extract-upgraded-element-type array)) + (declared-element-ctype (extract-declared-element-type array))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -56,7 +57,11 @@ `(multiple-value-bind (array index) (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array)) - (data-vector-ref array index))))) + ,(let ((bare-form '(data-vector-ref array index))) + (if (type= element-ctype declared-element-ctype) + bare-form + `(the ,(type-specifier declared-element-ctype) + ,bare-form))))))) (deftransform data-vector-ref ((array index) (simple-array t)) @@ -80,7 +85,8 @@ * :important t) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array))) + (let ((element-ctype (extract-upgraded-element-type array)) + (declared-element-ctype (extract-declared-element-type array))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -90,9 +96,12 @@ (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array) (type ,element-type-specifier new-value)) - (data-vector-set array - index - new-value))))) + ,(if (type= element-ctype declared-element-ctype) + '(data-vector-set array index new-value) + `(truly-the ,(type-specifier declared-element-ctype) + (data-vector-set array index + (the ,(type-specifier declared-element-ctype) + new-value)))))))) (deftransform data-vector-set ((array index new-value) (simple-array t t)) diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 9c50878..4b47009 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -150,6 +150,16 @@ (return stype)))))) type)) +(defun sb!xc:upgraded-array-element-type (spec &optional environment) + #!+sb-doc + "Return the element type that will actually be used to implement an array + with the specifier :ELEMENT-TYPE Spec." + (declare (ignore environment)) + (if (unknown-type-p (specifier-type spec)) + (error "undefined type: ~S" spec) + (type-specifier (array-type-specialized-element-type + (specifier-type `(array ,spec)))))) + ;;; Return the most specific integer type that can be quickly checked that ;;; includes the given type. (defun containing-integer-type (subtype) diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp index 21b5b69..1b7f9cd 100644 --- a/tests/array.pure.lisp +++ b/tests/array.pure.lisp @@ -127,3 +127,6 @@ (assert fail) (assert (raises-error? (funcall fun) type-error))) +(multiple-value-bind (fun warn fail) + (compile nil '(lambda () (make-array 5 :element-type 'undefined-type))) + (assert warn)) diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp index 6d61de0..8f89da4 100644 --- a/tests/compiler-1.impure-cload.lisp +++ b/tests/compiler-1.impure-cload.lisp @@ -103,12 +103,14 @@ ;;; bug 31 turned out to be a manifestation of non-ANSI array type ;;; handling, fixed by CSR in sbcl-0.7.3.8. (defun array-element-type-handling (x) + (declare (optimize safety)) (declare (type (vector cons) x)) (when (consp (aref x 0)) (aref x 0))) -(assert (eq (array-element-type-handling - (make-array 3 :element-type t :initial-element 0)) - nil)) +(assert (raises-error? + (array-element-type-handling + (make-array 3 :element-type t :initial-element 0)) + type-error)) ;;; bug 220: type check inserted after all arguments in MV-CALL caused ;;; failure of stack analysis diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 30cc9dc..64f425e 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -457,3 +457,8 @@ (assert (equal y #*00)) (funcall f y 1) (assert (equal y #*10)))) + +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x) + (declare (type (simple-array (simple-string 3) (5)) x)) + (aref (aref x 0) 0)))) diff --git a/version.lisp-expr b/version.lisp-expr index 2f31f00..0c26546 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".) -"0.8.1.8" +"0.8.1.9" -- 1.7.10.4