X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=c4a0e266fb34ece32eb36ce4578b1b64a1ad1bce;hb=f0da2f63aa0b4e6d4dbf884854a4bf2dfdd01fc0;hp=4a9e054db00eb35ff33957f712a71739be626ba1;hpb=2e33f2df9a6eb5a84d71726b88f06d92241e44da;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 4a9e054..c4a0e26 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -12,7 +12,7 @@ (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)) ;;;; miscellaneous accessor functions @@ -96,6 +96,8 @@ (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) @@ -315,7 +317,7 @@ of specialized arrays is supported." (coerce (the list objects) 'simple-vector)) -;;;; 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 @@ -326,6 +328,9 @@ of specialized arrays is supported." ;;; 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))) @@ -338,7 +343,8 @@ of specialized arrays is supported." (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-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)) @@ -393,7 +399,34 @@ of specialized arrays is supported." :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 (*)))) @@ -753,6 +786,7 @@ of specialized arrays is supported." ;;;; 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." @@ -775,6 +809,7 @@ of specialized arrays is supported." :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." @@ -802,7 +837,6 @@ of specialized arrays is supported." 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)) @@ -820,7 +854,7 @@ of specialized arrays is supported." (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)) @@ -835,7 +869,6 @@ of specialized arrays is supported." #!+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) @@ -1168,44 +1201,17 @@ function to be removed without further warning." (%array-data-vector array)) array))) -;;;; 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. @@ -1222,14 +1228,15 @@ function to be removed without further warning." (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