;; array type.
(if (array-type-p type)
(array-type-specialized-element-type type)
- *universal-type*)))
+ ;; KLUDGE: there is no good answer here, but at least
+ ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
+ ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
+ ;; 2002-08-21
+ *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
(defun assert-new-value-type (new-value array)
(let ((type (continuation-type array)))
(when (array-type-p type)
- (assert-continuation-type new-value
- (array-type-specialized-element-type type))))
+ (assert-continuation-type
+ new-value
+ (array-type-specialized-element-type type)
+ (lexenv-policy (node-lexenv (continuation-dest new-value))))))
(continuation-type new-value))
+(defun assert-array-complex (array)
+ (assert-continuation-type
+ array
+ (make-array-type :complexp t
+ :element-type *wild-type*)
+ (lexenv-policy (node-lexenv (continuation-dest array)))))
+
;;; Return true if ARG is NIL, or is a constant-continuation whose
;;; value is NIL, false otherwise.
(defun unsupplied-or-nil (arg)
(defun assert-array-rank (array rank)
(assert-continuation-type
array
- (specifier-type `(array * ,(make-list rank :initial-element '*)))))
+ (specifier-type `(array * ,(make-list rank :initial-element '*)))
+ (lexenv-policy (node-lexenv (continuation-dest array)))))
(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
(assert-array-rank array (length indices))
;; If the node continuation has a single use then assert its type.
(let ((cont (node-cont node)))
(when (= (length (find-uses cont)) 1)
- (assert-continuation-type cont (extract-upgraded-element-type array))))
+ (assert-continuation-type cont (extract-upgraded-element-type array)
+ (lexenv-policy (node-lexenv node)))))
(extract-upgraded-element-type array))
(defoptimizer (%aset derive-type) ((array &rest stuff))
(let ((simple (and (unsupplied-or-nil adjustable)
(unsupplied-or-nil displaced-to)
(unsupplied-or-nil fill-pointer))))
- (specifier-type
- `(,(if simple 'simple-array 'array)
- ,(cond ((not element-type) t)
- ((constant-continuation-p element-type)
- (continuation-value element-type))
- (t
- '*))
- ,(cond ((not simple)
- '*)
- ((constant-continuation-p dims)
- (let ((val (continuation-value dims)))
- (if (listp val) val (list val))))
- ((csubtypep (continuation-type dims)
- (specifier-type 'integer))
- '(*))
- (t
- '*))))))
+ (or (careful-specifier-type
+ `(,(if simple 'simple-array 'array)
+ ,(cond ((not element-type) t)
+ ((constant-continuation-p element-type)
+ (continuation-value element-type))
+ (t
+ '*))
+ ,(cond ((not simple)
+ '*)
+ ((constant-continuation-p dims)
+ (let ((val (continuation-value dims)))
+ (if (listp val) val (list val))))
+ ((csubtypep (continuation-type dims)
+ (specifier-type 'integer))
+ '(*))
+ (t
+ '*))))
+ (specifier-type 'array))))
+
+;;; Complex array operations should assert that their array argument
+;;; is complex. In SBCL, vectors with fill-pointers are complex.
+(defoptimizer (fill-pointer derive-type) ((vector))
+ (assert-array-complex vector))
+(defoptimizer (%set-fill-pointer derive-type) ((vector index))
+ (declare (ignorable index))
+ (assert-array-complex vector))
+
+(defoptimizer (vector-push derive-type) ((object vector))
+ (declare (ignorable object))
+ (assert-array-complex vector))
+(defoptimizer (vector-push-extend derive-type)
+ ((object vector &optional index))
+ (declare (ignorable object index))
+ (assert-array-complex vector))
+(defoptimizer (vector-pop derive-type) ((vector))
+ (assert-array-complex vector))
\f
;;;; constructors
"ELEMENT-TYPE is not constant."))
(t
(continuation-value element-type))))
- (eltype-type (specifier-type eltype))
+ (eltype-type (ir1-transform-specifier-type eltype))
(saetp (find-if (lambda (saetp)
(csubtypep eltype-type (saetp-ctype saetp)))
*specialized-array-element-type-properties*))
(unless saetp
(give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
-
+
(cond ((or (null initial-element)
(and (constant-continuation-p initial-element)
(eql (continuation-value initial-element)
;; elements before he reads elements (or to read manuals
;; before he writes code:-), we'll signal a STYLE-WARNING
;; in case he didn't realize this.
- (compiler-note "The default initial element ~S is not a ~S."
- (saetp-initial-element-default saetp)
- eltype))
+ (compiler-style-warn "The default initial element ~S is not a ~S."
+ (saetp-initial-element-default saetp)
+ eltype))
creation-form)
(t
`(let ((array ,creation-form))
(%data-vector-and-index array 0)
(fill vector initial-element))
array)))))
-
+
;;; The integer type restriction on the length ensures that it will be
;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and
;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
(continuation-value length)
'*))
(result-type-spec `(simple-array ,eltype (,len)))
- (eltype-type (specifier-type eltype))
+ (eltype-type (ir1-transform-specifier-type eltype))
(saetp (find-if (lambda (saetp)
(csubtypep eltype-type (saetp-ctype saetp)))
*specialized-array-element-type-properties*)))
`(if (<= ,n-svalue ,n-end ,n-len)
;; success
(values ,n-array ,n-svalue ,n-end 0)
- (failed-%with-array-data ,n-array ,n-svalue ,n-evalue))))
+ (failed-%with-array-data ,n-array
+ ,n-svalue
+ ,n-evalue))))
(,(if force-inline '%with-array-data-macro '%with-array-data)
,n-array ,n-svalue ,n-evalue))
,@forms)))
projects / sbcl.git / blobdiff