(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)
(coerce (the list objects) 'simple-vector))
\f
-;;;; accessor/setter functions
+;;;; accessor/setter and subseq 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
- (defvar ,table-name)
+ (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)))
- ;; SYMBOL-GLOBAL-VALUE is a performance hack
- ;; for threaded builds.
- (svref (sb!vm::symbol-global-value ',',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*))
+ `(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%%)
+ (def !find-vector-subseq-fun %%vector-subseq-funs%%))
(macrolet ((%ref (accessor-getter extra-params)
`(funcall (,accessor-getter array) array index ,@extra-params))
: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 (*))))
new-value)))
(define-reffers (symbol deffer check-form slow-path)
`(progn
- (setf ,symbol (make-array sb!vm::widetag-mask
+ ;; 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
collect `(setf (svref ,symbol ,widetag)
(,deffer ,saetp ,check-form))))))
(defun !hairy-data-vector-reffer-init ()
- (define-reffers *data-vector-reffers* define-reffer
+ (define-reffers %%data-vector-reffers%% define-reffer
(progn)
#'slow-hairy-data-vector-ref)
- (define-reffers *data-vector-setters* define-setter
+ (define-reffers %%data-vector-setters%% define-setter
(progn)
#'slow-hairy-data-vector-set)
- (define-reffers *data-vector-reffers/check-bounds* define-reffer
+ (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
+ (define-reffers %%data-vector-setters/check-bounds%% define-setter
(%check-bound vector (length vector))
#'slow-hairy-data-vector-set/check-bounds)))
(defun array-in-bounds-p (array &rest subscripts)
#!+sb-doc
- "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
+ "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
(if (%array-row-major-index array subscripts nil)
t))
\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))
(let ((length (length vector)))
(min (1+ length)
(- array-dimension-limit length)))))
- (declare (vector vector) (fixnum min-extension))
+ (declare (fixnum min-extension))
(let ((fill-pointer (fill-pointer vector)))
(declare (fixnum fill-pointer))
(when (= fill-pointer (%array-available-elements vector))
#!+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)
(%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
projects / sbcl.git / blobdiff