(assert-array-rank array (length indices))
(derive-aref-type array))
-(defoptimizer (%aset derive-type) ((array &rest stuff))
- (assert-array-rank array (1- (length stuff)))
- (assert-new-value-type (car (last stuff)) array))
+(defoptimizer ((setf aref) derive-type) ((new-value array &rest subscripts))
+ (assert-array-rank array (length subscripts))
+ (assert-new-value-type new-value array))
(macrolet ((define (name)
`(defoptimizer (,name derive-type) ((array index))
(defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
(assert-new-value-type new-value array))
-(defoptimizer (make-array derive-type)
- ((dims &key initial-element element-type initial-contents
- adjustable fill-pointer displaced-index-offset displaced-to))
+(defun derive-make-array-type (dims element-type adjustable
+ fill-pointer displaced-to)
(let* ((simple (and (unsupplied-or-nil adjustable)
(unsupplied-or-nil displaced-to)
(unsupplied-or-nil fill-pointer)))
(spec
- (or `(,(if simple 'simple-array 'array)
+ (or `(,(if simple 'simple-array 'array)
,(cond ((not element-type) t)
+ ((ctype-p element-type)
+ (type-specifier element-type))
((constant-lvar-p element-type)
(let ((ctype (careful-specifier-type
(lvar-value element-type))))
(cond
- ((or (null ctype) (unknown-type-p ctype)) '*)
+ ((or (null ctype) (contains-unknown-type-p ctype)) '*)
(t (sb!xc:upgraded-array-element-type
(lvar-value element-type))))))
(t
'(*))
(t
'*)))
- 'array)))
+ 'array)))
(if (and (not simple)
(or (supplied-and-true adjustable)
(supplied-and-true displaced-to)
(supplied-and-true fill-pointer)))
(careful-specifier-type `(and ,spec (not simple-array)))
(careful-specifier-type spec))))
+
+(defoptimizer (make-array derive-type)
+ ((dims &key element-type adjustable fill-pointer displaced-to))
+ (derive-make-array-type dims element-type adjustable
+ fill-pointer displaced-to))
+
+(defoptimizer (%make-array derive-type)
+ ((dims widetag n-bits &key adjustable fill-pointer displaced-to))
+ (declare (ignore n-bits))
+ (let ((saetp (and (constant-lvar-p widetag)
+ (find (lvar-value widetag)
+ sb!vm:*specialized-array-element-type-properties*
+ :key #'sb!vm:saetp-typecode))))
+ (derive-make-array-type dims (if saetp
+ (sb!vm:saetp-ctype saetp)
+ *wild-type*)
+ adjustable fill-pointer displaced-to)))
+
\f
;;;; constructors
(t
(let ((n-elements-per-word (/ sb!vm:n-word-bits n-bits)))
(declare (type index n-elements-per-word)) ; i.e., not RATIO
- `(ceiling ,padded-length-form ,n-elements-per-word)))))))
+ `(ceiling (truly-the index ,padded-length-form)
+ ,n-elements-per-word)))))))
(result-spec
`(simple-array ,(sb!vm:saetp-specifier saetp) (,(or c-length '*))))
(alloc-form
- `(truly-the ,result-spec
- (allocate-vector ,typecode (the index length) ,n-words-form))))
+ `(truly-the ,result-spec
+ (allocate-vector ,typecode (the index length) ,n-words-form))))
(cond ((and initial-element initial-contents)
(abort-ir1-transform "Both ~S and ~S specified."
:initial-contents :initial-element))
(deftransform make-array ((dims &key initial-element element-type
adjustable fill-pointer)
- (t &rest *))
- (when (null initial-element)
- (give-up-ir1-transform))
+ (t &rest *) *
+ :node node)
+ (delay-ir1-transform node :constraint)
(let* ((eltype (cond ((not element-type) t)
((not (constant-lvar-p element-type))
(give-up-ir1-transform
(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))
+ (saetp (if (unknown-type-p eltype-type)
+ (give-up-ir1-transform
+ "ELEMENT-TYPE ~s is not a known type"
+ eltype-type)
+ (find eltype-type
+ sb!vm:*specialized-array-element-type-properties*
+ :key #'sb!vm:saetp-ctype
+ :test #'csubtypep)))
+ (creation-form `(%make-array
+ dims
+ ,(if saetp
+ (sb!vm:saetp-typecode saetp)
+ (give-up-ir1-transform))
+ ,(sb!vm:saetp-n-bits saetp)
,@(when fill-pointer
- '(:fill-pointer 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)))
+ '(:adjustable adjustable)))))
+ (cond ((or (not initial-element)
+ (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
(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)))))
+ (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,
(element-type-ctype (and (constant-lvar-p element-type)
(ir1-transform-specifier-type
(lvar-value element-type)))))
- (when (unknown-type-p element-type-ctype)
+ (when (contains-unknown-type-p element-type-ctype)
(give-up-ir1-transform))
(unless (every #'integerp dims)
(give-up-ir1-transform
(t :maybe)))
;;; If we can tell the rank from the type info, use it instead.
-(deftransform array-rank ((array))
+(deftransform array-rank ((array) (array) * :node node)
(let ((array-type (lvar-type array)))
(let ((dims (array-type-dimensions-or-give-up array-type)))
(cond ((listp dims)
(length dims))
- ((eq t (array-type-complexp array-type))
+ ((eq t (and (array-type-p array-type)
+ (array-type-complexp array-type)))
'(%array-rank array))
(t
+ (delay-ir1-transform node :constraint)
`(if (array-header-p array)
(%array-rank array)
1))))))
\f
;;;; array accessors
-;;; We convert all typed array accessors into AREF and %ASET with type
+;;; We convert all typed array accessors into AREF and (SETF AREF) with type
;;; assertions on the array.
-(macrolet ((define-bit-frob (reffer setter simplep)
+(macrolet ((define-bit-frob (reffer simplep)
`(progn
(define-source-transform ,reffer (a &rest i)
`(aref (the (,',(if simplep 'simple-array 'array)
bit
,(mapcar (constantly '*) i))
,a) ,@i))
- (define-source-transform ,setter (a &rest i)
- `(%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))
+ (define-source-transform (setf ,reffer) (value a &rest i)
+ `(setf (aref (the (,',(if simplep 'simple-array 'array)
+ bit
+ ,(mapcar (constantly '*) i))
+ ,a) ,@i)
+ ,value)))))
+ (define-bit-frob sbit t)
+ (define-bit-frob bit nil))
+
(macrolet ((define-frob (reffer setter type)
`(progn
(define-source-transform ,reffer (a i)
`(aref (the ,',type ,a) ,i))
(define-source-transform ,setter (a i v)
- `(%aset (the ,',type ,a) ,i ,v)))))
+ `(setf (aref (the ,',type ,a) ,i) ,v)))))
(define-frob schar %scharset simple-string)
(define-frob char %charset string))
(define-source-transform svref (vector index)
(let ((elt-type (or (when (symbolp vector)
(let ((var (lexenv-find vector vars)))
- (when var
+ (when (lambda-var-p var)
(type-specifier
(array-type-declared-element-type (lambda-var-type var))))))
t)))
(define-source-transform %svset (vector index value)
(let ((elt-type (or (when (symbolp vector)
(let ((var (lexenv-find vector vars)))
- (when var
+ (when (lambda-var-p var)
(type-specifier
(array-type-declared-element-type (lambda-var-type var))))))
t)))
(push (make-symbol (format nil "DIM-~D" i)) dims))
(setf n-indices (nreverse n-indices))
(setf dims (nreverse dims))
- `(lambda (,',array ,@n-indices
- ,@',(when new-value (list new-value)))
+ `(lambda (,@',(when new-value (list new-value))
+ ,',array ,@n-indices)
+ (declare (ignorable ,',array))
(let* (,@(let ((,index -1))
(mapcar (lambda (name)
`(,name (array-dimension
(with-row-major-index (array indices index)
index))
- ;; Convert AREF and %ASET into a HAIRY-DATA-VECTOR-REF (or
+ ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or
;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
;; expression for the row major index.
(deftransform aref ((array &rest indices))
(with-row-major-index (array indices index)
(hairy-data-vector-ref array index)))
- (deftransform %aset ((array &rest stuff))
- (let ((indices (butlast stuff)))
- (with-row-major-index (array indices index new-value)
- (hairy-data-vector-set array index new-value)))))
+ (deftransform (setf aref) ((new-value array &rest subscripts))
+ (with-row-major-index (array subscripts index new-value)
+ (hairy-data-vector-set array index new-value))))
;; For AREF of vectors we do the bounds checking in the callee. This
;; lets us do a significantly more efficient check for simple-arrays
`(hairy-data-vector-ref array index))
(t `(hairy-data-vector-ref/check-bounds array index)))))
-(deftransform %aset ((array index new-value) (t t t) * :node node)
+(deftransform (setf aref) ((new-value array index) (t t t) * :node node)
(if (policy node (zerop insert-array-bounds-checks))
`(hairy-data-vector-set array index new-value)
`(hairy-data-vector-set/check-bounds array index new-value)))
projects / sbcl.git / blobdiff