X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=3d6448a701c94086c3312849e4741a907d30548d;hb=bfa4310e41dcd011ca9d139f29be1c5757b41378;hp=619920a065f3b1370e76e0518e7855916a762082;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 619920a..3d6448a 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. @@ -385,12 +389,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 +440,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 +452,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 +467,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 +484,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 +499,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 +512,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) @@ -758,6 +783,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)))