X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=2423b820764f2ee6d09dc19b35705f2e3ea22c2d;hb=1ce0ed2dc780758503d284e981768bd505564a88;hp=619920a065f3b1370e76e0518e7855916a762082;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 619920a..2423b82 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -242,11 +242,15 @@ ((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 (sb!vm:saetp-ctype saetp)) - eltype)) + (warn 'array-initial-element-mismatch + :format-control "~@<~S is not a ~S (which is the ~ + ~S of ~S).~@:>" + :format-arguments + (list + value + (type-specifier (sb!vm:saetp-ctype saetp)) + 'upgraded-array-element-type + eltype))) ((not (ctypep value eltype-type)) ;; this case will not cause an error at runtime, but ;; it's still worth STYLE-WARNing about. @@ -289,8 +293,7 @@ (give-up-ir1-transform "cannot open-code creation of ~S" result-type-spec)) #-sb-xc-host - (unless (csubtypep (ctype-of (sb!vm:saetp-initial-element-default saetp)) - eltype-type) + (unless (ctypep (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 ;; INITIAL-ELEMENT is not supplied, the consequences of later @@ -385,12 +388,41 @@ ;;; Transforms for various array properties. If the property is know ;;; at compile time because of a type spec, use that constant value. +;;; Most of this logic may end up belonging in code/late-type.lisp; +;;; however, here we also need the -OR-GIVE-UP for the transforms, and +;;; maybe this is just too sloppy for actual type logic. -- CSR, +;;; 2004-02-18 +(defun array-type-dimensions-or-give-up (type) + (typecase type + (array-type (array-type-dimensions type)) + (union-type + (let ((types (union-type-types type))) + ;; there are at least two types, right? + (aver (> (length types) 1)) + (let ((result (array-type-dimensions-or-give-up (car types)))) + (dolist (type (cdr types) result) + (unless (equal (array-type-dimensions-or-give-up type) result) + (give-up-ir1-transform)))))) + ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ] + (t (give-up-ir1-transform)))) + +(defun conservative-array-type-complexp (type) + (typecase type + (array-type (array-type-complexp type)) + (union-type + (let ((types (union-type-types type))) + (aver (> (length types) 1)) + (let ((result (conservative-array-type-complexp (car types)))) + (dolist (type (cdr types) result) + (unless (eq (conservative-array-type-complexp type) result) + (return-from conservative-array-type-complexp :maybe)))))) + ;; FIXME: intersection type + (t :maybe))) + ;;; If we can tell the rank from the type info, use it instead. (deftransform array-rank ((array)) (let ((array-type (lvar-type array))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions array-type))) + (let ((dims (array-type-dimensions-or-give-up array-type))) (if (not (listp dims)) (give-up-ir1-transform "The array rank is not known at compile time: ~S" @@ -407,9 +439,7 @@ (give-up-ir1-transform "The axis is not constant.")) (let ((array-type (lvar-type array)) (axis (lvar-value axis))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions array-type))) + (let ((dims (array-type-dimensions-or-give-up array-type))) (unless (listp dims) (give-up-ir1-transform "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime.")) @@ -421,7 +451,7 @@ (cond ((integerp dim) dim) ((= (length dims) 1) - (ecase (array-type-complexp array-type) + (ecase (conservative-array-type-complexp array-type) ((t) '(%array-dimension array 0)) ((nil) @@ -436,9 +466,7 @@ (deftransform length ((vector) ((simple-array * (*)))) (let ((type (lvar-type vector))) - (unless (array-type-p type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions type))) + (let ((dims (array-type-dimensions-or-give-up type))) (unless (and (listp dims) (integerp (car dims))) (give-up-ir1-transform "Vector length is unknown, must call LENGTH at runtime.")) @@ -455,12 +483,12 @@ ;;; compile-time constant. (deftransform vector-length ((vector)) (let ((vtype (lvar-type vector))) - (if (and (array-type-p vtype) - (not (array-type-complexp vtype))) - (let ((dim (first (array-type-dimensions vtype)))) - (when (eq dim '*) (give-up-ir1-transform)) - dim) - (give-up-ir1-transform)))) + (let ((dim (first (array-type-dimensions-or-give-up vtype)))) + (when (eq dim '*) + (give-up-ir1-transform)) + (when (conservative-array-type-complexp vtype) + (give-up-ir1-transform)) + dim))) ;;; Again, if we can tell the results from the type, just use it. ;;; Otherwise, if we know the rank, convert into a computation based @@ -470,9 +498,7 @@ (deftransform array-total-size ((array) (array)) (let ((array-type (lvar-type array))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions array-type))) + (let ((dims (array-type-dimensions-or-give-up array-type))) (unless (listp dims) (give-up-ir1-transform "can't tell the rank at compile time")) (if (member '* dims) @@ -485,12 +511,10 @@ ;;; Only complex vectors have fill pointers. (deftransform array-has-fill-pointer-p ((array)) (let ((array-type (lvar-type array))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions array-type))) + (let ((dims (array-type-dimensions-or-give-up array-type))) (if (and (listp dims) (not (= (length dims) 1))) nil - (ecase (array-type-complexp array-type) + (ecase (conservative-array-type-complexp array-type) ((t) t) ((nil) @@ -498,7 +522,7 @@ ((:maybe) (give-up-ir1-transform "The array type is ambiguous; must call ~ - ARRAY-HAS-FILL-POINTER-P at runtime."))))))) + ARRAY-HAS-FILL-POINTER-P at runtime."))))))) ;;; Primitive used to verify indices into arrays. If we can tell at ;;; compile-time or we are generating unsafe code, don't bother with @@ -613,7 +637,6 @@ ;; WHN, and also CSR 2002-05-26 ((or vector simple-array) index (or index null)) * - :important t :node node :policy (> speed space)) "inline non-SIMPLE-vector-handling logic" @@ -626,14 +649,20 @@ ;;; We convert all typed array accessors into AREF and %ASET with type ;;; assertions on the array. -(macrolet ((define-frob (reffer setter type) +(macrolet ((define-bit-frob (reffer setter simplep) `(progn (define-source-transform ,reffer (a &rest i) - `(aref (the ,',type ,a) ,@i)) + `(aref (the (,',(if simplep 'simple-array 'array) + bit + ,(mapcar (constantly '*) i)) + ,a) ,@i)) (define-source-transform ,setter (a &rest i) - `(%aset (the ,',type ,a) ,@i))))) - (define-frob sbit %sbitset (simple-array bit)) - (define-frob bit %bitset (array bit))) + `(%aset (the (,',(if simplep 'simple-array 'array) + bit + ,(cdr (mapcar (constantly '*) i))) + ,a) ,@i))))) + (define-bit-frob sbit %sbitset t) + (define-bit-frob bit %bitset nil)) (macrolet ((define-frob (reffer setter type) `(progn (define-source-transform ,reffer (a i) @@ -648,7 +677,7 @@ ;; given a set of indices. We wrap each index with a call ;; to %CHECK-BOUND to ensure that everything works out ;; correctly. We can wrap all the interior arithmetic with - ;; TRULY-THE INDEX because we know the the resultant + ;; TRULY-THE INDEX because we know the resultant ;; row-major index must be an index. (with-row-major-index ((array indices index &optional new-value) &rest body) @@ -728,7 +757,7 @@ (bit-vector bit-vector &optional null) * :policy (>= speed space)) `(,',fun bit-array-1 bit-array-2 - (make-array (length bit-array-1) :element-type 'bit))) + (make-array (array-dimension bit-array-1 0) :element-type 'bit))) ;; If result is T, make it the first arg. (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array) (bit-vector bit-vector (eql t)) *) @@ -749,7 +778,7 @@ (bit-vector &optional null) * :policy (>= speed space)) '(bit-not bit-array-1 - (make-array (length bit-array-1) :element-type 'bit))) + (make-array (array-dimension bit-array-1 0) :element-type 'bit))) (deftransform bit-not ((bit-array-1 result-bit-array) (bit-vector (eql t))) '(bit-not bit-array-1 bit-array-1)) @@ -758,6 +787,7 @@ (defoptimizer (array-header-p derive-type) ((array)) (let ((type (lvar-type array))) (cond ((not (array-type-p type)) + ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP nil) (t (let ((dims (array-type-dimensions type))) @@ -767,5 +797,7 @@ ((and (listp dims) (/= (length dims) 1)) ;; multi-dimensional array, will have a header (specifier-type '(eql t))) + ((eql (array-type-complexp type) t) + (specifier-type '(eql t))) (t nil)))))))