(apply #'type-intersection element-supertypes)))))
(union-type
(let ((union-types (union-type-types type))
- (element-type *empty-type*)
+ (element-type nil)
(element-supertypes nil))
(dolist (union-type union-types)
(multiple-value-bind (cur-type cur-supertype)
(cond
((eq element-type *wild-type*)
nil)
- ((eq element-type *empty-type*)
+ ((eq element-type nil)
(setf element-type cur-type))
((or (eq cur-type *wild-type*)
;; If each of the two following tests fail, it is not
(values element-type
(when (eq *wild-type* element-type)
(apply #'type-union element-supertypes)))))
+ (member-type
+ ;; Convert member-type to an union-type.
+ (array-type-upgraded-element-type
+ (apply #'type-union (mapcar #'ctype-of (member-type-members type)))))
(t
;; KLUDGE: there is no good answer here, but at least
;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
(lexenv-policy (node-lexenv (lvar-dest new-value))))))
(lvar-type new-value))
-(defun assert-array-complex (array)
- (assert-lvar-type
- array
- (make-array-type :complexp t
- :element-type *wild-type*)
- (lexenv-policy (node-lexenv (lvar-dest array))))
- nil)
-
;;; Return true if ARG is NIL, or is a constant-lvar whose
;;; value is NIL, false otherwise.
(defun unsupplied-or-nil (arg)
(or (not arg)
(and (constant-lvar-p arg)
(not (lvar-value arg)))))
+
+(defun supplied-and-true (arg)
+ (and arg
+ (constant-lvar-p arg)
+ (lvar-value arg)
+ t))
\f
;;;; DERIVE-TYPE optimizers
(block nil
(let ((dimensions (array-type-dimensions-or-give-up
(lvar-conservative-type array))))
+ ;; Might be *. (Note: currently this is never true, because the type
+ ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but
+ ;; let's keep this future proof.)
+ (when (eq '* dimensions)
+ (give-up-ir1-transform "array bounds unknown"))
;; shortcut for zero dimensions
(when (some (lambda (dim)
(and (bound-known-p dim) (zerop dim)))
;; 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)))
+ (let* ((type1 (lvar-type subscript))
+ (type2 (if (csubtypep type1 (specifier-type 'integer))
+ (weaken-integer-type type1 :range-only t)
+ (give-up)))
+ (low (if (integer-type-p type2)
+ (numeric-type-low type2)
+ (give-up)))
+ (high (numeric-type-high type2)))
(cond
((and (or (not (bound-known-p low)) (minusp low))
(or (not (bound-known-p high)) (not (minusp high))))
(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 (make-array derive-type)
((dims &key initial-element element-type initial-contents
adjustable fill-pointer displaced-index-offset displaced-to))
- (let ((simple (and (unsupplied-or-nil adjustable)
- (unsupplied-or-nil displaced-to)
- (unsupplied-or-nil fill-pointer))))
- (or (careful-specifier-type
- `(,(if simple 'simple-array 'array)
- ,(cond ((not element-type) t)
- ((constant-lvar-p element-type)
- (let ((ctype (careful-specifier-type
- (lvar-value element-type))))
- (cond
- ((or (null ctype) (unknown-type-p ctype)) '*)
- (t (sb!xc:upgraded-array-element-type
- (lvar-value element-type))))))
- (t
- '*))
- ,(cond ((constant-lvar-p dims)
- (let* ((val (lvar-value dims))
- (cdims (if (listp val) val (list val))))
- (if simple
- cdims
- (length cdims))))
- ((csubtypep (lvar-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))
+ (let* ((simple (and (unsupplied-or-nil adjustable)
+ (unsupplied-or-nil displaced-to)
+ (unsupplied-or-nil fill-pointer)))
+ (spec
+ (or `(,(if simple 'simple-array 'array)
+ ,(cond ((not element-type) t)
+ ((constant-lvar-p element-type)
+ (let ((ctype (careful-specifier-type
+ (lvar-value element-type))))
+ (cond
+ ((or (null ctype) (unknown-type-p ctype)) '*)
+ (t (sb!xc:upgraded-array-element-type
+ (lvar-value element-type))))))
+ (t
+ '*))
+ ,(cond ((constant-lvar-p dims)
+ (let* ((val (lvar-value dims))
+ (cdims (if (listp val) val (list val))))
+ (if simple
+ cdims
+ (length cdims))))
+ ((csubtypep (lvar-type dims)
+ (specifier-type 'integer))
+ '(*))
+ (t
+ '*)))
+ '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))))
\f
;;;; constructors
,@(when initial-element
'(:initial-element initial-element)))))
-;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments,
-;;; so that we can pick them apart.
-(define-source-transform make-array (&whole form dimensions &rest keyargs
- &environment env)
- (if (and (fun-lexically-notinline-p 'list)
- (fun-lexically-notinline-p 'vector))
+(defun rewrite-initial-contents (rank initial-contents env)
+ (if (plusp rank)
+ (if (and (consp initial-contents)
+ (member (car initial-contents) '(list vector sb!impl::backq-list)))
+ `(list ,@(mapcar (lambda (dim)
+ (rewrite-initial-contents (1- rank) dim env))
+ (cdr initial-contents)))
+ initial-contents)
+ ;; This is the important bit: once we are past the level of
+ ;; :INITIAL-CONTENTS that relates to the array structure, reinline LIST
+ ;; and VECTOR so that nested DX isn't screwed up.
+ `(locally (declare (inline list vector))
+ ,initial-contents)))
+
+;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments, so that we
+;;; can pick them apart in the DEFTRANSFORMS, and transform '(3) style
+;;; dimensions to integer args directly.
+(define-source-transform make-array (dimensions &rest keyargs &environment env)
+ (if (or (and (fun-lexically-notinline-p 'list)
+ (fun-lexically-notinline-p 'vector))
+ (oddp (length keyargs)))
(values nil t)
- `(locally (declare (notinline list vector))
- ;; 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))))
+ (multiple-value-bind (new-dimensions rank)
+ (flet ((constant-dims (dimensions)
+ (let* ((dims (constant-form-value dimensions env))
+ (canon (if (listp dims) dims (list dims)))
+ (rank (length canon)))
+ (values (if (= rank 1)
+ (list 'quote (car canon))
+ (list 'quote canon))
+ rank))))
+ (cond ((sb!xc:constantp dimensions env)
+ (constant-dims dimensions))
+ ((and (consp dimensions) (eq 'list dimensions))
+ (values dimensions (length (cdr dimensions))))
+ (t
+ (values dimensions nil))))
+ (let ((initial-contents (getf keyargs :initial-contents)))
+ (when (and initial-contents rank)
+ (setf keyargs (copy-list keyargs)
+ (getf keyargs :initial-contents)
+ (rewrite-initial-contents rank initial-contents env))))
+ `(locally (declare (notinline list vector))
+ (make-array ,new-dimensions ,@keyargs)))))
;;; 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
(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))
(unless (constant-lvar-p dims)
(give-up-ir1-transform
"The dimension list is not constant; cannot open code array creation."))
- (let ((dims (lvar-value dims)))
+ (let ((dims (lvar-value dims))
+ (element-type-ctype (and (constant-lvar-p element-type)
+ (ir1-transform-specifier-type
+ (lvar-value element-type)))))
+ (when (unknown-type-p element-type-ctype)
+ (give-up-ir1-transform))
(unless (every #'integerp dims)
(give-up-ir1-transform
"The dimension list contains something other than an integer: ~S"
(rank (length dims))
(spec `(simple-array
,(cond ((null element-type) t)
- ((and (constant-lvar-p element-type)
- (ir1-transform-specifier-type
- (lvar-value element-type)))
+ (element-type-ctype
(sb!xc:upgraded-array-element-type
(lvar-value element-type)))
(t '*))
(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)))))
- (define-frob svref %svset simple-vector)
+ `(setf (aref (the ,',type ,a) ,i) ,v)))))
(define-frob schar %scharset simple-string)
(define-frob char %charset string))
+;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is
+;;; around 100 times faster than going through the general-purpose AREF
+;;; transform which ends up doing a lot of work -- and introducing many
+;;; intermediate lambdas, each meaning a new trip through the compiler -- to
+;;; get the same result.
+;;;
+;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar
+;;; treatment.
+(define-source-transform svref (vector index)
+ (let ((elt-type (or (when (symbolp vector)
+ (let ((var (lexenv-find vector vars)))
+ (when (lambda-var-p var)
+ (type-specifier
+ (array-type-declared-element-type (lambda-var-type var))))))
+ t)))
+ (with-unique-names (n-vector)
+ `(let ((,n-vector ,vector))
+ (the ,elt-type (data-vector-ref
+ (the simple-vector ,n-vector)
+ (%check-bound ,n-vector (length ,n-vector) ,index)))))))
+
+(define-source-transform %svset (vector index value)
+ (let ((elt-type (or (when (symbolp vector)
+ (let ((var (lexenv-find vector vars)))
+ (when (lambda-var-p var)
+ (type-specifier
+ (array-type-declared-element-type (lambda-var-type var))))))
+ t)))
+ (with-unique-names (n-vector)
+ `(let ((,n-vector ,vector))
+ (truly-the ,elt-type (data-vector-set
+ (the simple-vector ,n-vector)
+ (%check-bound ,n-vector (length ,n-vector) ,index)
+ (the ,elt-type ,value)))))))
+
(macrolet (;; This is a handy macro for computing the row-major index
;; given a set of indices. We wrap each index with a call
;; to %CHECK-BOUND to ensure that everything works out
(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)))
`(deftransform ,name ((array index ,@extra))
(let* ((type (lvar-type array))
(element-type (array-type-upgraded-element-type type))
- (declared-type (array-type-declared-element-type type)))
+ (declared-type (type-specifier
+ (array-type-declared-element-type type))))
;; If an element type has been declared, we want to
;; use that information it for type checking (even
;; if the access can't be optimized due to the array
projects / sbcl.git / blobdiff