X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=7122723bd80803f15a79510bcb0d5c76939bcf9f;hb=79721a8731b8582ad8df664c2c4e04bd3d6090c6;hp=efd993ed0e3ccf2727b5019a7002dfe5b222b86c;hpb=5762f26aae78beaead9919074963f67d92794599;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index efd993e..7122723 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -133,6 +133,28 @@ (bit #.sb!vm:complex-bit-vector-widetag) (t #.sb!vm:complex-vector-widetag))))) +(defglobal %%simple-array-n-bits%% (make-array (1+ sb!vm:widetag-mask))) +#.(loop for info across sb!vm:*specialized-array-element-type-properties* + collect `(setf (aref %%simple-array-n-bits%% ,(sb!vm:saetp-typecode info)) + ,(sb!vm:saetp-n-bits info)) into forms + finally (return `(progn ,@forms))) + +(defun allocate-vector-with-widetag (widetag length &optional n-bits) + (declare (type (unsigned-byte 8) widetag) + (type index length)) + (let ((n-bits (or n-bits (aref %%simple-array-n-bits%% widetag)))) + (declare (type (integer 0 256) n-bits)) + (allocate-vector widetag length + (ceiling + (* (if (or (= widetag sb!vm:simple-base-string-widetag) + #!+sb-unicode + (= widetag + sb!vm:simple-character-string-widetag)) + (1+ length) + length) + n-bits) + sb!vm:n-word-bits)))) + (defun make-array (dimensions &key (element-type t) (initial-element nil initial-element-p) @@ -159,18 +181,7 @@ (declare (type (unsigned-byte 8) type) (type (integer 0 256) n-bits)) (let* ((length (car dimensions)) - (array (allocate-vector - type - length - (ceiling - (* (if (or (= type sb!vm:simple-base-string-widetag) - #!+sb-unicode - (= type - sb!vm:simple-character-string-widetag)) - (1+ length) - length) - n-bits) - sb!vm:n-word-bits)))) + (array (allocate-vector-with-widetag type length n-bits))) (declare (type index length)) (when initial-element-p (fill array initial-element)) @@ -189,7 +200,7 @@ (let* ((total-size (reduce #'* dimensions)) (data (or displaced-to (data-vector-from-inits - dimensions total-size element-type + dimensions total-size element-type nil initial-contents initial-contents-p initial-element initial-element-p))) (array (make-array-header @@ -289,18 +300,23 @@ of specialized arrays is supported." ;;; specified array characteristics. Dimensions is only used to pass ;;; to FILL-DATA-VECTOR for error checking on the structure of ;;; initial-contents. -(defun data-vector-from-inits (dimensions total-size element-type +(defun data-vector-from-inits (dimensions total-size + element-type widetag initial-contents initial-contents-p initial-element initial-element-p) (when (and initial-contents-p initial-element-p) (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to either MAKE-ARRAY or ADJUST-ARRAY.")) - (let ((data (if initial-element-p - (make-array total-size - :element-type element-type - :initial-element initial-element) - (make-array total-size - :element-type element-type)))) + (let ((data (cond + (widetag + (allocate-vector-with-widetag widetag total-size)) + (initial-element-p + (make-array total-size + :element-type element-type + :initial-element initial-element)) + (t + (make-array total-size + :element-type element-type))))) (cond (initial-element-p (unless (simple-vector-p data) (unless (typep initial-element element-type) @@ -339,9 +355,30 @@ of specialized arrays is supported." (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 @@ -375,7 +412,7 @@ of specialized arrays is supported." (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 @@ -815,18 +852,17 @@ of specialized arrays is supported." (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 (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)) @@ -851,7 +887,7 @@ of specialized arrays is supported." ;;;; 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 @@ -864,7 +900,8 @@ of specialized arrays is supported." (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))) @@ -883,7 +920,7 @@ of specialized arrays is supported." the :INITIAL-ELEMENT or :DISPLACED-TO option.")) (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits - dimensions array-size element-type + dimensions array-size element-type nil initial-contents initial-contents-p initial-element initial-element-p))) (if (adjustable-array-p array) @@ -937,9 +974,13 @@ of specialized arrays is supported." (setf new-data (data-vector-from-inits dimensions new-length element-type + (widetag-of old-data) initial-contents initial-contents-p initial-element initial-element-p)) + ;; Provide :END1 to avoid full call to LENGTH + ;; inside REPLACE. (replace new-data old-data + :end1 new-length :start2 old-start :end2 old-end)) (t (setf new-data (shrink-vector old-data new-length)))) @@ -961,7 +1002,8 @@ of specialized arrays is supported." (> new-length old-length)) (data-vector-from-inits dimensions new-length - element-type () nil + element-type + (widetag-of old-data) () nil initial-element initial-element-p) old-data))) (if (or (zerop old-length) (zerop new-length)) @@ -1346,20 +1388,6 @@ function to be removed without further warning." ;;;; array type dispatching -;;; Store some saetp fields for DEFINE-ARRAY-DISPATCH since -;;; sb!vm:*specialized-array-element-type-properties* is not always -;;; available. -(macrolet - ((define-saetp-info () - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defglobal %%saetp-info%% - ',(loop for saetp - across sb!vm:*specialized-array-element-type-properties* - collect `(,(sb!vm:saetp-typecode saetp) - ,(sb!vm:saetp-specifier saetp) - ,(sb!vm:saetp-primitive-type-name saetp))))))) - (define-saetp-info)) - ;;; Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated), ;;; defines the functions ;;; @@ -1391,7 +1419,10 @@ function to be removed without further warning." :expected-type '(simple-array * (*))))) (defglobal ,table-name (make-array ,(1+ sb!vm:widetag-mask) :initial-element #',error-name)) - ,@(loop for (typecode specifier primitive-type-name) in %%saetp-info%% + ,@(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