(coerce (the list objects) 'simple-vector))
\f
-;;;; accessor/setter and subseq functions
+;;;; accessor/setter functions
;;; Dispatch to an optimized routine the data vector accessors for
;;; each different specialized vector type. Do dispatching by looking
;;; 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.
-;;;
-;;; Similarly for SUBSEQ, except we don't have the slow-path at all:
-;;; VECTOR-SUBEQ* takes care of that.
(macrolet ((def (name table-name)
`(progn
(defglobal ,table-name (make-array ,(1+ sb!vm:widetag-mask)))
(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%%)
- (def !find-vector-subseq-fun %%vector-subseq-funs%%))
+ ;; 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))
(declare (ignore end))
(,accessor-name vector index ,@extra-params)))))))
(define hairy-data-vector-ref slow-hairy-data-vector-ref
- !find-data-vector-reffer
+ %find-data-vector-reffer
nil (progn))
(define hairy-data-vector-set slow-hairy-data-vector-set
!find-data-vector-setter
:datum array
:expected-type 'vector))
-(defun hairy-subseq-error (array start end)
- (declare (ignore start end))
- (error 'type-error
- :datum array
- :expected-type '(simple-array * (*))))
-
-;;; Populate the dispatch tables.
-(macrolet ((def-subseq-funs ()
- `(progn
- (set '%%vector-subseq-funs%%
- (make-array (1+ sb!vm:widetag-mask)
- :initial-element #'hairy-subseq-error))
- ,@(map 'list
- (lambda (saetp)
- (let ((name (symbolicate "SUBSEQ/"
- (sb!vm:saetp-primitive-type-name saetp))))
- `(progn
- (defun ,name (vector start end)
- (declare (type (simple-array ,(sb!vm:saetp-specifier saetp) (*))
- vector)
- (index start end)
- (optimize speed (safety 0)))
- (subseq vector start end))
- (setf (svref %%vector-subseq-funs%%
- ,(sb!vm:saetp-typecode saetp))
- #',name))))
- sb!vm:*specialized-array-element-type-properties*))))
- (def-subseq-funs))
(macrolet ((define-reffer (saetp check-form)
(let* ((type (sb!vm:saetp-specifier saetp))
(atype `(simple-array ,type (*))))
(declare (type index src-index dst-index))
(setf (sbit dst dst-index)
(logxor (sbit src src-index) 1))))))))
+
+;;;; array type dispatching
+
+;;; Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated),
+;;; defines the functions
+;;;
+;;; DISPATCH-FOO/SIMPLE-BASE-STRING
+;;; DISPATCH-FOO/SIMPLE-CHARACTER-STRING
+;;; DISPATCH-FOO/SIMPLE-ARRAY-SINGLE-FLOAT
+;;; ...
+;;;
+;;; PARAMS are the function parameters in the definition of each
+;;; specializer function. The array being specialized must be the
+;;; first parameter in PARAMS. A type declaration for this parameter
+;;; is automatically inserted into the body of each function.
+;;;
+;;; The dispatch table %%FOO-FUNS%% is defined and populated by these
+;;; functions. The table is padded by the function
+;;; HAIRY-FOO-DISPATCH-ERROR, also defined by DEFINE-ARRAY-DISPATCH.
+;;;
+;;; Finally, the DISPATCH-FOO macro is defined which does the actual
+;;; dispatching when called. It expects arguments that match PARAMS.
+;;;
+(defmacro define-array-dispatch (dispatch-name params &body body)
+ (let ((table-name (symbolicate "%%" dispatch-name "-FUNS%%"))
+ (error-name (symbolicate "HAIRY-" dispatch-name "-ERROR")))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun ,error-name (&rest args)
+ (error 'type-error
+ :datum (first args)
+ :expected-type '(simple-array * (*)))))
+ (defglobal ,table-name (make-array ,(1+ sb!vm:widetag-mask)
+ :initial-element #',error-name))
+ ,@(loop for info across sb!vm:*specialized-array-element-type-properties*
+ for typecode = (sb!vm:saetp-typecode info)
+ for specifier = (sb!vm:saetp-specifier info)
+ for primitive-type-name = (sb!vm:saetp-primitive-type-name info)
+ collect (let ((fun-name (symbolicate (string dispatch-name)
+ "/" primitive-type-name)))
+ `(progn
+ (defun ,fun-name ,params
+ (declare (type (simple-array ,specifier (*))
+ ,(first params)))
+ ,@body)
+ (setf (svref ,table-name ,typecode) #',fun-name))))
+ (defmacro ,dispatch-name (&rest args)
+ (check-type (first args) symbol)
+ (let ((tag (gensym "TAG")))
+ `(funcall
+ (the function
+ (let ((,tag 0))
+ (when (sb!vm::%other-pointer-p ,(first args))
+ (setf ,tag (%other-pointer-widetag ,(first args))))
+ (svref ,',table-name ,tag)))
+ ,@args))))))