(in-package "SB!IMPL")
#!-sb-fluid
-(declaim (inline fill-pointer array-has-fill-pointer-p adjustable-array-p
+(declaim (inline adjustable-array-p
array-displacement))
\f
;;;; miscellaneous accessor functions
(values #.sb!vm:simple-bit-vector-widetag 1))
;; OK, we have to wade into SUBTYPEPing after all.
(t
+ (unless *type-system-initialized*
+ (bug "SUBTYPEP dispatch for MAKE-ARRAY before the type system is ready"))
#.`(pick-vector-type type
,@(map 'list
(lambda (saetp)
(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%%)
+ ;; 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
(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))
-;;; Populate the dispatch tables.
(macrolet ((define-reffer (saetp check-form)
(let* ((type (sb!vm:saetp-specifier saetp))
(atype `(simple-array ,type (*))))
\f
;;;; fill pointer frobbing stuff
+(declaim (inline array-has-fill-pointer-p))
(defun array-has-fill-pointer-p (array)
#!+sb-doc
"Return T if the given ARRAY has a fill pointer, or NIL otherwise."
:format-control "~S is not an array with a fill pointer."
:format-arguments (list vector)))))
+(declaim (inline fill-pointer))
(defun fill-pointer (vector)
#!+sb-doc
"Return the FILL-POINTER of the given VECTOR."
to NEW-EL, and increment the fill pointer by one. If the fill pointer is
too large, NIL is returned, otherwise the index of the pushed element is
returned."
- (declare (vector array))
(let ((fill-pointer (fill-pointer array)))
(declare (fixnum fill-pointer))
(cond ((= fill-pointer (%array-available-elements array))
(setf (%array-fill-pointer array) (1+ fill-pointer))
fill-pointer))))
-(defun vector-push-extend (new-element
- vector
- &optional
- (min-extension
- (let ((length (length vector)))
- (min (1+ length)
- (- array-dimension-limit length)))))
- (declare (vector vector) (fixnum min-extension))
+(defun vector-push-extend (new-element vector &optional min-extension)
+ (declare (type (or null fixnum) min-extension))
(let ((fill-pointer (fill-pointer vector)))
(declare (fixnum fill-pointer))
(when (= fill-pointer (%array-available-elements vector))
- (adjust-array vector (+ fill-pointer (max 1 min-extension))))
+ (let ((min-extension
+ (or min-extension
+ (let ((length (length vector)))
+ (min (1+ length)
+ (- array-dimension-limit length))))))
+ (adjust-array vector (+ fill-pointer (max 1 min-extension)))))
;; disable bounds checking
(locally (declare (optimize (safety 0)))
(setf (aref vector fill-pointer) new-element))
#!+sb-doc
"Decrease the fill pointer by 1 and return the element pointed to by the
new fill pointer."
- (declare (vector array))
(let ((fill-pointer (fill-pointer array)))
(declare (fixnum fill-pointer))
(if (zerop fill-pointer)
;;;; ADJUST-ARRAY
(defun adjust-array (array dimensions &key
- (element-type (array-element-type array))
+ (element-type (array-element-type array) element-type-p)
(initial-element nil initial-element-p)
(initial-contents nil initial-contents-p)
fill-pointer
(cond ((/= (the fixnum (length (the list dimensions)))
(the fixnum (array-rank array)))
(error "The number of dimensions not equal to rank of array."))
- ((not (subtypep element-type (array-element-type array)))
+ ((and element-type-p
+ (not (subtypep element-type (array-element-type array))))
(error "The new element type, ~S, is incompatible with old type."
element-type))
((and fill-pointer (not (array-has-fill-pointer-p array)))
(%array-data-vector array))
array)))
\f
-;;;; used by SORT
-
-;;; temporary vector for stable sorting vectors, allocated for each new thread
-(defvar *merge-sort-temp-vector* (vector))
-(declaim (simple-vector *merge-sort-temp-vector*))
;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
-;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ.
-;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice. This is rebound
-;;; to length zero array in each new thread.
-;;;
-;;; DX is probably a bad idea, because a with a big array it would
-;;; be fairly easy to blow the stack.
-(defvar *zap-array-data-temp* (vector))
-(declaim (simple-vector *zap-array-data-temp*))
-
-(defun zap-array-data-temp (length initial-element initial-element-p)
- (declare (fixnum length))
- (let ((tmp *zap-array-data-temp*))
- (declare (simple-vector tmp))
- (cond ((> length (length tmp))
- (setf *zap-array-data-temp*
- (if initial-element-p
- (make-array length :initial-element initial-element)
- (make-array length))))
- (initial-element-p
- (fill tmp initial-element :end length))
- (t
- tmp))))
-
;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
;;; is a displaced offset to be added to computed indices of OLD-DATA.
(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
element-type initial-element initial-element-p)
- (declare (list old-dims new-dims))
+ (declare (list old-dims new-dims)
+ (fixnum new-length))
;; OLD-DIMS comes from array-dimensions, which returns a fresh list
;; at least in SBCL.
;; NEW-DIMS comes from the user.
(unless (typep initial-element element-type)
(error "~S can't be used to initialize an array of type ~S."
initial-element element-type)))
- (let ((temp (zap-array-data-temp new-length
- initial-element initial-element-p)))
+ (let ((temp (if initial-element-p
+ (make-array new-length :initial-element initial-element)
+ (make-array new-length))))
(declare (simple-vector temp))
(zap-array-data-aux old-data old-dims offset temp new-dims)
(dotimes (i new-length)
- (setf (aref new-data i) (aref temp i)
- ;; zero out any garbage right away
- (aref temp i) 0))))
+ (setf (aref new-data i) (aref temp i)))
+ ;; Kill the temporary vector to prevent garbage retention.
+ (%shrink-vector temp 0)))
(t
;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
;; already been filled with any
(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))))))