(values vector index))
(values array index)))
+(declaim (inline simple-vector-compare-and-swap))
+(defun simple-vector-compare-and-swap (vector index old new)
+ #!+(or x86 x86-64)
+ (%simple-vector-compare-and-swap vector
+ (%check-bound vector (length vector) index)
+ old
+ new)
+ #!-(or x86 x86-64)
+ (let ((n-old (svref vector index)))
+ (when (eq old n-old)
+ (setf (svref vector index) new))
+ n-old))
+
;;; It'd waste space to expand copies of error handling in every
;;; inline %WITH-ARRAY-DATA, so we have them call this function
;;; instead. This is just a wrapper which is known never to return.
"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 (table-name extra-params)
+ `(funcall
+ (the function
+ (let ((tag 0)
+ (offset
+ #.(ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (- sb!vm:other-pointer-lowtag))
+ (:big-endian
+ (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
+ ;; 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))
+ offset)))
+ ;; SYMBOL-GLOBAL-VALUE is a performance hack
+ ;; for threaded builds.
+ (svref (sb!vm::symbol-global-value ',table-name) tag)))
+ array index ,@extra-params))
+ (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)))
+ (%define ,table-name ,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)))
+ (%define ,table-name ,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
+ *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-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)))
;;; (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))
projects / sbcl.git / blobdiff