-(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
- ;; I'm not completely sure of what this
- ;; 3 represents symbolically. It's
- ;; just what all the LOAD-TYPE vops
- ;; are doing.
- (- 3 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)))))))
+(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%%)
+ ;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
+ ;; meaning we can have post-build dependences on this.
+ (def %find-data-vector-reffer %%data-vector-reffers%%)
+ (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))
+
+;;; Like DOVECTOR, but more magical -- can't use this on host.
+(defmacro do-vector-data ((elt vector &optional result) &body body)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (with-unique-names (index vec start end ref)
+ `(with-array-data ((,vec ,vector)
+ (,start)
+ (,end)
+ :check-fill-pointer t)
+ (let ((,ref (%find-data-vector-reffer ,vec)))
+ (do ((,index ,start (1+ ,index)))
+ ((>= ,index ,end)
+ (let ((,elt nil))
+ ,@(filter-dolist-declarations decls)
+ ,elt
+ ,result))
+ (let ((,elt (funcall ,ref ,vec ,index)))
+ ,@decls
+ (tagbody ,@forms))))))))
+
+(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)))))))