"Construct a SIMPLE-VECTOR from the given objects."
(coerce (the list objects) 'simple-vector))
\f
+
;;;; accessor/setter functions
-(defun hairy-data-vector-ref (array index)
- (with-array-data ((vector array) (index index) (end))
- (declare (ignore end))
- (etypecase vector .
- #.(map 'list
- (lambda (saetp)
- (let* ((type (sb!vm:saetp-specifier saetp))
- (atype `(simple-array ,type (*))))
- `(,atype
- (data-vector-ref (the ,atype vector) index))))
- (sort
- (copy-seq
- sb!vm:*specialized-array-element-type-properties*)
- #'> :key #'sb!vm:saetp-importance)))))
+
+;;; Dispatch to an optimized routine the data vector accessors for
+;;; each different specialized vector type. Do dispatching by looking
+;;; up the widetag in the array rather than with the typecases, which
+;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
+;;; provide separate versions where bounds checking has been moved
+;;; from the callee to the caller, since it's much cheaper to do once
+;;; the type information is available. Finally, for each of these
+;;; routines also provide a slow path, taken for arrays that are not
+;;; vectors or not simple.
+(macrolet ((define (accessor-name slow-accessor-name table-name extra-params
+ check-bounds)
+ `(progn
+ (defvar ,table-name)
+ (defun ,accessor-name (array index ,@extra-params)
+ (declare (optimize speed
+ ;; (SAFETY 0) is ok. All calls to
+ ;; these functions are generated by
+ ;; the compiler, so argument count
+ ;; checking isn't needed. Type checking
+ ;; is done implicitly via the widetag
+ ;; dispatch.
+ (safety 0)))
+ #1=(funcall (the function
+ (let ((tag 0))
+ ;; WIDETAG-OF needs extra code to
+ ;; handle LIST and FUNCTION
+ ;; lowtags. We're only dispatching
+ ;; on other pointers, so let's do
+ ;; the lowtag extraction manually.
+ (when (sb!vm::%other-pointer-p array)
+ (setf tag (sb!sys:sap-ref-8
+ (int-sap (get-lisp-obj-address array))
+ (- sb!vm:other-pointer-lowtag))))
+ ;; SYMBOL-GLOBAL-VALUE is a performance hack
+ ;; for threaded builds.
+ (svref (sb!vm::symbol-global-value ',table-name)
+ tag)))
+ array index ,@extra-params))
+ (defun ,slow-accessor-name (array index ,@extra-params)
+ (declare (optimize speed (safety 0)))
+ (if (not (%array-displaced-p array))
+ ;; The reasonably quick path of non-displaced complex
+ ;; arrays.
+ (let ((array (%array-data-vector array)))
+ #1#)
+ ;; The real slow path.
+ (with-array-data
+ ((vector array)
+ (index (locally
+ (declare (optimize (speed 1) (safety 1)))
+ (,@check-bounds index)))
+ (end)
+ :force-inline t)
+ (declare (ignore end))
+ (,accessor-name vector index ,@extra-params)))))))
+ (define hairy-data-vector-ref slow-hairy-data-vector-ref
+ *data-vector-reffers* nil (progn))
+ (define hairy-data-vector-set slow-hairy-data-vector-set
+ *data-vector-setters* (new-value) (progn))
+ (define hairy-data-vector-ref/check-bounds
+ slow-hairy-data-vector-ref/check-bounds
+ *data-vector-reffers/check-bounds* nil
+ (%check-bound array (array-dimension array 0)))
+ (define hairy-data-vector-set/check-bounds
+ slow-hairy-data-vector-set/check-bounds
+ *data-vector-setters/check-bounds* (new-value)
+ (%check-bound array (array-dimension array 0))))
+
+(defun hairy-ref-error (array index &optional new-value)
+ (declare (ignore index new-value))
+ (error 'type-error
+ :datum array
+ :expected-type 'vector))
+
+;;; Populate the dispatch tables.
+(macrolet ((define-reffer (saetp check-form)
+ (let* ((type (sb!vm:saetp-specifier saetp))
+ (atype `(simple-array ,type (*))))
+ `(named-lambda optimized-data-vector-ref (vector index)
+ (declare (optimize speed (safety 0)))
+ (data-vector-ref (the ,atype vector)
+ (locally
+ (declare (optimize (safety 1)))
+ (the index
+ (,@check-form index)))))))
+ (define-setter (saetp check-form)
+ (let* ((type (sb!vm:saetp-specifier saetp))
+ (atype `(simple-array ,type (*))))
+ `(named-lambda optimized-data-vector-set (vector index new-value)
+ (declare (optimize speed (safety 0)))
+ (data-vector-set (the ,atype vector)
+ (locally
+ (declare (optimize (safety 1)))
+ (the index
+ (,@check-form index)))
+ (locally
+ ;; SPEED 1 needed to avoid the compiler
+ ;; from downgrading the type check to
+ ;; a cheaper one.
+ (declare (optimize (speed 1)
+ (safety 1)))
+ (the ,type new-value)))
+ ;; For specialized arrays, the return from
+ ;; data-vector-set would have to be reboxed to be a
+ ;; (Lisp) return value; instead, we use the
+ ;; already-boxed value as the return.
+ new-value)))
+ (define-reffers (symbol deffer check-form slow-path)
+ `(progn
+ (setf ,symbol (make-array sb!vm::widetag-mask
+ :initial-element #'hairy-ref-error))
+ ,@(loop for widetag in '(sb!vm:complex-vector-widetag
+ sb!vm:complex-vector-nil-widetag
+ sb!vm:complex-bit-vector-widetag
+ sb!vm:complex-character-string-widetag
+ sb!vm:complex-base-string-widetag
+ sb!vm:simple-array-widetag
+ sb!vm:complex-array-widetag)
+ collect `(setf (svref ,symbol ,widetag) ,slow-path))
+ ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ for widetag = (sb!vm:saetp-typecode saetp)
+ collect `(setf (svref ,symbol ,widetag)
+ (,deffer ,saetp ,check-form))))))
+ (defun !hairy-data-vector-reffer-init ()
+ (define-reffers *data-vector-reffers* define-reffer
+ (progn)
+ #'slow-hairy-data-vector-ref)
+ (define-reffers *data-vector-setters* define-setter
+ (progn)
+ #'slow-hairy-data-vector-set)
+ (define-reffers *data-vector-reffers/check-bounds* define-reffer
+ (%check-bound vector (length vector))
+ #'slow-hairy-data-vector-ref/check-bounds)
+ (define-reffers *data-vector-setters/check-bounds* define-setter
+ (%check-bound vector (length vector))
+ #'slow-hairy-data-vector-set/check-bounds)))
;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
(defun data-vector-ref (array index)
(hairy-data-vector-ref array index))
-(defun hairy-data-vector-set (array index new-value)
- (with-array-data ((vector array) (index index) (end))
- (declare (ignore end))
- (etypecase vector .
- #.(map 'list
- (lambda (saetp)
- (let* ((type (sb!vm:saetp-specifier saetp))
- (atype `(simple-array ,type (*))))
- `(,atype
- (data-vector-set (the ,atype vector) index
- (the ,type new-value))
- ;; For specialized arrays, the return from
- ;; data-vector-set would have to be
- ;; reboxed to be a (Lisp) return value;
- ;; instead, we use the already-boxed value
- ;; as the return.
- new-value)))
- (sort
- (copy-seq
- sb!vm:*specialized-array-element-type-properties*)
- #'> :key #'sb!vm:saetp-importance)))))
-
;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
(defun %array-row-major-index (array subscripts
&optional (invalid-index-error-p t))
(assert-array-rank array (1- (length stuff)))
(assert-new-value-type (car (last stuff)) array))
-(defoptimizer (hairy-data-vector-ref derive-type) ((array index))
- (extract-upgraded-element-type array))
-(defoptimizer (data-vector-ref derive-type) ((array index))
- (extract-upgraded-element-type array))
+(macrolet ((define (name)
+ `(defoptimizer (,name derive-type) ((array index))
+ (extract-upgraded-element-type array))))
+ (define hairy-data-vector-ref)
+ (define hairy-data-vector-ref/check-bounds)
+ (define data-vector-ref))
+
#!+x86
(defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset))
(extract-upgraded-element-type array))
-(defoptimizer (data-vector-set derive-type) ((array index new-value))
- (assert-new-value-type new-value array))
+(macrolet ((define (name)
+ `(defoptimizer (,name derive-type) ((array index new-value))
+ (assert-new-value-type new-value array))))
+ (define hairy-data-vector-set)
+ (define hairy-data-vector-set/check-bounds)
+ (define data-vector-set))
+
#!+x86
(defoptimizer (data-vector-set-with-offset derive-type) ((array index offset new-value))
(assert-new-value-type new-value array))
-(defoptimizer (hairy-data-vector-set derive-type) ((array index new-value))
- (assert-new-value-type new-value array))
;;; Figure out the type of the data vector if we know the argument
;;; element type.
(with-row-major-index (array indices 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
+;; without bloating the code.
+(deftransform aref ((array index) (t t) * :node node)
+ (if (policy node (zerop insert-array-bounds-checks))
+ `(hairy-data-vector-ref array index)
+ `(hairy-data-vector-ref/check-bounds array index)))
+
+(deftransform %aset ((array index new-value) (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)))
+
+;;; But if we find out later that there's some useful type information
+;;; available, switch back to the normal one to give other transforms
+;;; a stab at it.
+(macrolet ((define (name transform-to extra extra-type)
+ `(deftransform ,name ((array index ,@extra))
+ (let ((type (lvar-type array))
+ (element-type (extract-upgraded-element-type array)))
+ ;; 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
+ ;; not being simple).
+ (when (eql element-type *wild-type*)
+ (when (or (not (array-type-p type))
+ ;; If it's a simple array, we might be able
+ ;; to inline the access completely.
+ (not (null (array-type-complexp type))))
+ (give-up-ir1-transform
+ "Upgraded element type of array is not known at compile time."))))
+ `(,',transform-to array
+ (%check-bound array
+ (array-dimension array 0)
+ index)
+ ,@',extra))))
+ (define hairy-data-vector-ref/check-bounds
+ hairy-data-vector-ref nil nil)
+ (define hairy-data-vector-set/check-bounds
+ hairy-data-vector-set (new-value) (*)))
+
(deftransform aref ((array index) ((or simple-vector
- simple-unboxed-array)
+ (simple-unboxed-array 1))
index))
(let ((type (lvar-type array)))
(unless (array-type-p type)
projects / sbcl.git / commitdiff