(assert-array-rank array (length indices))
*universal-type*)
+(deftransform array-in-bounds-p ((array &rest subscripts))
+ (flet ((give-up ()
+ (give-up-ir1-transform
+ "~@<lower array bounds unknown or negative and upper bounds not ~
+ negative~:@>"))
+ (bound-known-p (x)
+ (integerp x))) ; might be NIL or *
+ (block nil
+ (let ((dimensions (array-type-dimensions-or-give-up
+ (lvar-conservative-type array))))
+ ;; shortcut for zero dimensions
+ (when (some (lambda (dim)
+ (and (bound-known-p dim) (zerop dim)))
+ dimensions)
+ (return nil))
+ ;; we first collect the subscripts LVARs' bounds and see whether
+ ;; we can already decide on the result of the optimization without
+ ;; even taking a look at the dimensions.
+ (flet ((subscript-bounds (subscript)
+ (let* ((type (lvar-type subscript))
+ (low (numeric-type-low type))
+ (high (numeric-type-high type)))
+ (cond
+ ((and (or (not (bound-known-p low)) (minusp low))
+ (or (not (bound-known-p high)) (not (minusp high))))
+ ;; can't be sure about the lower bound and the upper bound
+ ;; does not give us a definite clue either.
+ (give-up))
+ ((and (bound-known-p high) (minusp high))
+ (return nil)) ; definitely below lower bound (zero).
+ (t
+ (cons low high))))))
+ (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts))
+ (subscripts-lower-bound (mapcar #'car subscripts-bounds))
+ (subscripts-upper-bound (mapcar #'cdr subscripts-bounds))
+ (in-bounds 0))
+ (mapcar (lambda (low high dim)
+ (cond
+ ;; first deal with infinite bounds
+ ((some (complement #'bound-known-p) (list low high dim))
+ (when (and (bound-known-p dim) (bound-known-p low) (<= dim low))
+ (return nil)))
+ ;; now we know all bounds
+ ((>= low dim)
+ (return nil))
+ ((< high dim)
+ (aver (not (minusp low)))
+ (incf in-bounds))
+ (t
+ (give-up))))
+ subscripts-lower-bound
+ subscripts-upper-bound
+ dimensions)
+ (if (eql in-bounds (length dimensions))
+ t
+ (give-up))))))))
+
(defoptimizer (aref derive-type) ((array &rest indices) node)
(assert-array-rank array (length indices))
(derive-aref-type array))
;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments,
;;; so that we can pick them apart.
-(define-source-transform make-array (&whole form &rest args)
- (declare (ignore args))
+(define-source-transform make-array (&whole form dimensions &rest keyargs
+ &environment env)
(if (and (fun-lexically-notinline-p 'list)
(fun-lexically-notinline-p 'vector))
(values nil t)
`(locally (declare (notinline list vector))
- ,form)))
+ ;; Transform '(3) style dimensions to integer args directly.
+ ,(if (sb!xc:constantp dimensions env)
+ (let ((dims (constant-form-value dimensions env)))
+ (if (and (listp dims) (= 1 (length dims)))
+ `(make-array ',(car dims) ,@keyargs)
+ form))
+ form))))
;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
;;; call which creates a vector with a known element type -- and tries
(truly-the ,result-spec
(initialize-vector ,alloc-form
,@(map 'list (lambda (elt)
- `(the ,elt-spec ,elt))
+ `(the ,elt-spec ',elt))
contents)))))))
;; any other :INITIAL-CONTENTS
(initial-contents
(not (eql default-initial-element (lvar-value initial-element)))))
(let ((parameters (eliminate-keyword-args
call 1 '((:element-type element-type)
- (:initial-element initial-element)))))
+ (:initial-element initial-element))))
+ (init (if (constant-lvar-p initial-element)
+ (list 'quote (lvar-value initial-element))
+ 'initial-element)))
`(lambda (length ,@parameters)
(declare (ignorable ,@parameters))
(truly-the ,result-spec
- (fill ,alloc-form (the ,elt-spec initial-element))))))
+ (fill ,alloc-form (the ,elt-spec ,init))))))
;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
;; default
(t
default-initial-element
elt-spec)))
(let ((parameters (eliminate-keyword-args
- call 1 '((:element-type element-type)))))
+ call 1 '((:element-type element-type)
+ (:initial-element initial-element)))))
`(lambda (length ,@parameters)
(declare (ignorable ,@parameters))
,alloc-form))))))
-(deftransform make-array ((dims &key
- element-type initial-element initial-contents)
- (integer &key
- (:element-type (constant-arg *))
- (:initial-element *)
- (:initial-contents *))
- *
- :node call)
- (transform-make-array-vector dims
- element-type
- initial-element
- initial-contents
- call))
+;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
+;;; specific must come first, otherwise suboptimal transforms will result for
+;;; some forms.
+
+(deftransform make-array ((dims &key initial-element element-type
+ adjustable fill-pointer)
+ (t &rest *))
+ (when (null initial-element)
+ (give-up-ir1-transform))
+ (let* ((eltype (cond ((not element-type) t)
+ ((not (constant-lvar-p element-type))
+ (give-up-ir1-transform
+ "ELEMENT-TYPE is not constant."))
+ (t
+ (lvar-value element-type))))
+ (eltype-type (ir1-transform-specifier-type eltype))
+ (saetp (find-if (lambda (saetp)
+ (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
+ sb!vm:*specialized-array-element-type-properties*))
+ (creation-form `(make-array dims
+ :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
+ ,@(when fill-pointer
+ '(:fill-pointer fill-pointer))
+ ,@(when adjustable
+ '(:adjustable adjustable)))))
+
+ (unless saetp
+ (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
+
+ (cond ((and (constant-lvar-p initial-element)
+ (eql (lvar-value initial-element)
+ (sb!vm:saetp-initial-element-default saetp)))
+ creation-form)
+ (t
+ ;; error checking for target, disabled on the host because
+ ;; (CTYPE-OF #\Null) is not possible.
+ #-sb-xc-host
+ (when (constant-lvar-p initial-element)
+ (let ((value (lvar-value initial-element)))
+ (cond
+ ((not (ctypep value (sb!vm:saetp-ctype saetp)))
+ ;; this case will cause an error at runtime, so we'd
+ ;; better WARN about it now.
+ (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.
+ (compiler-style-warn "~S is not a ~S."
+ value eltype)))))
+ `(let ((array ,creation-form))
+ (multiple-value-bind (vector)
+ (%data-vector-and-index array 0)
+ (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element)))
+ array)))))
;;; The list type restriction does not ensure that the result will be a
;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
dims))
(truly-the ,spec header)))))))
-(deftransform make-array ((dims &key initial-element element-type
- adjustable fill-pointer)
- (t &rest *))
- (when (null initial-element)
- (give-up-ir1-transform))
- (let* ((eltype (cond ((not element-type) t)
- ((not (constant-lvar-p element-type))
- (give-up-ir1-transform
- "ELEMENT-TYPE is not constant."))
- (t
- (lvar-value element-type))))
- (eltype-type (ir1-transform-specifier-type eltype))
- (saetp (find-if (lambda (saetp)
- (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
- sb!vm:*specialized-array-element-type-properties*))
- (creation-form `(make-array dims
- :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
- ,@(when fill-pointer
- '(:fill-pointer fill-pointer))
- ,@(when adjustable
- '(:adjustable adjustable)))))
-
- (unless saetp
- (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
-
- (cond ((and (constant-lvar-p initial-element)
- (eql (lvar-value initial-element)
- (sb!vm:saetp-initial-element-default saetp)))
- creation-form)
- (t
- ;; error checking for target, disabled on the host because
- ;; (CTYPE-OF #\Null) is not possible.
- #-sb-xc-host
- (when (constant-lvar-p initial-element)
- (let ((value (lvar-value initial-element)))
- (cond
- ((not (ctypep value (sb!vm:saetp-ctype saetp)))
- ;; this case will cause an error at runtime, so we'd
- ;; better WARN about it now.
- (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.
- (compiler-style-warn "~S is not a ~S."
- value eltype)))))
- `(let ((array ,creation-form))
- (multiple-value-bind (vector)
- (%data-vector-and-index array 0)
- (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element)))
- array)))))
+(deftransform make-array ((dims &key element-type initial-element initial-contents)
+ (integer &key
+ (:element-type (constant-arg *))
+ (:initial-element *)
+ (:initial-contents *))
+ *
+ :node call)
+ (transform-make-array-vector dims
+ element-type
+ initial-element
+ initial-contents
+ call))
\f
;;;; miscellaneous properties of arrays
(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))))))
+ (give-up-ir1-transform
+ "~@<dimensions of arrays in union type ~S do not match~:@>"
+ (type-specifier type)))))))
;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ]
- (t (give-up-ir1-transform))))
+ (t
+ (give-up-ir1-transform
+ "~@<don't know how to extract array dimensions from type ~S~:@>"
+ (type-specifier type)))))
(defun conservative-array-type-complexp (type)
(typecase type
projects / sbcl.git / blobdiff