+;;; 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 ((def (name table-name)
+ `(progn
+ (defglobal ,table-name (make-array ,(1+ sb!vm:widetag-mask)))
+ (defmacro ,name (array-var)
+ `(the function
+ (let ((tag 0))
+ (when (sb!vm::%other-pointer-p ,array-var)
+ (setf tag (%other-pointer-widetag ,array-var)))
+ (svref ,',table-name tag)))))))
+ (def !find-data-vector-setter %%data-vector-setters%%)
+ (def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
+ (def !find-data-vector-reffer %%data-vector-reffers%%)
+ (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))
+
+(macrolet ((%ref (accessor-getter extra-params)
+ `(funcall (,accessor-getter array) array index ,@extra-params))
+ (define (accessor-name slow-accessor-name accessor-getter
+ extra-params check-bounds)
+ `(progn
+ (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)))
+ (%ref ,accessor-getter ,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)))
+ (%ref ,accessor-getter ,extra-params))
+ ;; 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
+ !find-data-vector-reffer
+ nil (progn))
+ (define hairy-data-vector-set slow-hairy-data-vector-set
+ !find-data-vector-setter
+ (new-value) (progn))
+ (define hairy-data-vector-ref/check-bounds
+ slow-hairy-data-vector-ref/check-bounds
+ !find-data-vector-reffer/check-bounds
+ nil (%check-bound array (array-dimension array 0)))
+ (define hairy-data-vector-set/check-bounds
+ slow-hairy-data-vector-set/check-bounds
+ !find-data-vector-setter/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
+ ;; FIXME/KLUDGE: can't just FILL here, because genesis doesn't
+ ;; preserve the binding, so re-initiaize as NS doesn't have
+ ;; the energy to figure out to change that right now.
+ (setf ,symbol (make-array (1+ 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-unicode 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)))