X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=b6b7c512bbd24d836fc8e5a1a0f6dd05496aa488;hb=68612b8227bdd1a9e70962201f54231c82affa17;hp=df886903a7bd170f8ae6c7179fe6f8e28631fcf7;hpb=b34c64b50e8ade72fabb565a38841c4710ee8f40;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index df88690..b6b7c51 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) @@ -197,77 +208,6 @@ ,@(when initial-element '(:initial-element initial-element))))) -(defstruct (specialized-array-element-type-properties - (:conc-name saetp-) - (:constructor !make-saetp (ctype - initial-element-default - n-bits - typecode - &key - (n-pad-elements 0))) - (:copier nil)) - ;; the element type, e.g. # or - ;; # - (ctype (missing-arg) :type ctype :read-only t) - ;; what we get when the low-level vector-creation logic zeroes all - ;; the bits (which also serves as the default value of MAKE-ARRAY's - ;; :INITIAL-ELEMENT keyword) - (initial-element-default (missing-arg) :read-only t) - ;; how many bits per element - (n-bits (missing-arg) :type index :read-only t) - ;; the low-level type code - (typecode (missing-arg) :type index :read-only t) - ;; the number of extra elements we use at the end of the array for - ;; low level hackery (e.g., one element for arrays of BASE-CHAR, - ;; which is used for a fixed #\NULL so that when we call out to C - ;; we don't need to cons a new copy) - (n-pad-elements (missing-arg) :type index :read-only t)) - -(defparameter *specialized-array-element-type-properties* - (map 'simple-vector - (lambda (args) - (destructuring-bind (type-spec &rest rest) args - (let ((ctype (specifier-type type-spec))) - (apply #'!make-saetp ctype rest)))) - `(;; Erm. Yeah. There aren't a lot of things that make sense - ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07 - (nil '#:mu 0 ,sb!vm:simple-array-nil-widetag) - (base-char ,(code-char 0) 8 ,sb!vm:simple-base-string-widetag - ;; (SIMPLE-STRINGs are stored with an extra trailing - ;; #\NULL for convenience in calling out to C.) - :n-pad-elements 1) - (single-float 0.0f0 32 ,sb!vm:simple-array-single-float-widetag) - (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-widetag) - #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128 - ,sb!vm:simple-array-long-float-widetag) - (bit 0 1 ,sb!vm:simple-bit-vector-widetag) - ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come - ;; before their SIGNED-BYTE partners is significant in the - ;; implementation of the compiler; some of the cross-compiler - ;; code (see e.g. COERCE-TO-SMALLEST-ELTYPE in - ;; src/compiler/debug-dump.lisp) attempts to create an array - ;; specialized on (UNSIGNED-BYTE FOO), where FOO could be 7; - ;; (UNSIGNED-BYTE 7) is SUBTYPEP (SIGNED-BYTE 8), so if we're - ;; not careful we could get the wrong specialized array when - ;; we try to FIND-IF, below. -- CSR, 2002-07-08 - ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag) - ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag) - ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag) - ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-widetag) - ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-widetag) - ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-byte-8-widetag) - ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-widetag) - ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-widetag) - ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-widetag) - ((complex single-float) #C(0.0f0 0.0f0) 64 - ,sb!vm:simple-array-complex-single-float-widetag) - ((complex double-float) #C(0.0d0 0.0d0) 128 - ,sb!vm:simple-array-complex-double-float-widetag) - #!+long-float ((complex long-float) #C(0.0L0 0.0L0) - #!+x86 192 #!+sparc 256 - ,sb!vm:simple-array-complex-long-float-widetag) - (t 0 32 ,sb!vm:simple-vector-widetag)))) - (deftransform make-array ((dims &key initial-element element-type adjustable fill-pointer) (t &rest *)) @@ -281,10 +221,10 @@ (continuation-value element-type)))) (eltype-type (ir1-transform-specifier-type eltype)) (saetp (find-if (lambda (saetp) - (csubtypep eltype-type (saetp-ctype saetp))) - *specialized-array-element-type-properties*)) + (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) + sb!vm:*specialized-array-element-type-properties*)) (creation-form `(make-array dims - :element-type ',(type-specifier (saetp-ctype saetp)) + :element-type ',(type-specifier (sb!vm:saetp-ctype saetp)) ,@(when fill-pointer '(:fill-pointer fill-pointer)) ,@(when adjustable @@ -295,7 +235,7 @@ (cond ((and (constant-continuation-p initial-element) (eql (continuation-value initial-element) - (saetp-initial-element-default saetp))) + (sb!vm:saetp-initial-element-default saetp))) creation-form) (t ;; error checking for target, disabled on the host because @@ -304,13 +244,13 @@ (when (constant-continuation-p initial-element) (let ((value (continuation-value initial-element))) (cond - ((not (ctypep value (saetp-ctype saetp))) + ((not (ctypep value (sb!vm:saetp-ctype saetp))) ;; this case will cause an error at runtime, so we'd ;; better WARN about it now. (compiler-warn "~@<~S is not a ~S (which is the ~ UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>" value - (type-specifier (saetp-ctype saetp)) + (type-specifier (sb!vm:saetp-ctype saetp)) eltype)) ((not (ctypep value eltype-type)) ;; this case will not cause an error at runtime, but @@ -339,16 +279,22 @@ (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*))) + (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) + sb!vm:*specialized-array-element-type-properties*))) (unless saetp (give-up-ir1-transform "cannot open-code creation of ~S" result-type-spec)) #-sb-xc-host - (unless (csubtypep (ctype-of (saetp-initial-element-default saetp)) + (unless (csubtypep (ctype-of (sb!vm:saetp-initial-element-default saetp)) eltype-type) ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If @@ -361,11 +307,11 @@ ;; he writes code:-), we'll signal a STYLE-WARNING in case he ;; didn't realize this. (compiler-style-warn "The default initial element ~S is not a ~S." - (saetp-initial-element-default saetp) + (sb!vm:saetp-initial-element-default saetp) eltype)) - (let* ((n-bits-per-element (saetp-n-bits saetp)) - (typecode (saetp-typecode saetp)) - (n-pad-elements (saetp-n-pad-elements saetp)) + (let* ((n-bits-per-element (sb!vm:saetp-n-bits saetp)) + (typecode (sb!vm:saetp-typecode saetp)) + (n-pad-elements (sb!vm:saetp-n-pad-elements saetp)) (padded-length-form (if (zerop n-pad-elements) 'length `(+ length ,n-pad-elements))) @@ -416,8 +362,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))) @@ -566,7 +515,7 @@ (give-up-ir1-transform)) (t (let ((dim (continuation-value dimension))) - `(the (integer 0 ,dim) index))))) + `(the (integer 0 (,dim)) index))))) ;;;; WITH-ARRAY-DATA @@ -814,16 +763,17 @@ ;;; value? ;;; Pick off some constant cases. -(deftransform array-header-p ((array) (array)) +(defoptimizer (array-header-p derive-type) ((array)) (let ((type (continuation-type array))) - (unless (array-type-p type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions type))) - (cond ((csubtypep type (specifier-type '(simple-array * (*)))) - ;; no array header - nil) - ((and (listp dims) (/= (length dims) 1)) - ;; multi-dimensional array, will have a header - t) - (t - (give-up-ir1-transform)))))) + (cond ((not (array-type-p type)) + nil) + (t + (let ((dims (array-type-dimensions type))) + (cond ((csubtypep type (specifier-type '(simple-array * (*)))) + ;; no array header + (specifier-type 'null)) + ((and (listp dims) (/= (length dims) 1)) + ;; multi-dimensional array, will have a header + (specifier-type '(eql t))) + (t + nil)))))))