X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=565c0861a1027283ef001c85ce7ee429ddc20fbc;hb=0c0d8909984b5b33bb6b59b350b2d5cee6dc1715;hp=2d4ab67a7029f3529c7a927af855a22488b4fbca;hpb=512be7140b2fa9c12ba905c27c7569c0b5c44257;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 2d4ab67..565c086 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 @@ -30,7 +30,8 @@ (def %array-available-elements) (def %array-data-vector) (def %array-displacement) - (def %array-displaced-p)) + (def %array-displaced-p) + (def %array-diplaced-from)) (defun %array-rank (array) (%array-rank array)) @@ -95,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) @@ -217,6 +220,7 @@ (setf (%array-fill-pointer-p array) nil))) (setf (%array-available-elements array) total-size) (setf (%array-data-vector array) data) + (setf (%array-displaced-from array) nil) (cond (displaced-to (when (or initial-element-p initial-contents-p) (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ @@ -226,7 +230,8 @@ (array-total-size displaced-to)) (error "~S doesn't have enough elements." displaced-to)) (setf (%array-displacement array) offset) - (setf (%array-displaced-p array) t))) + (setf (%array-displaced-p array) t) + (%save-displaced-array-backpointer array data))) (t (setf (%array-displaced-p array) nil))) (let ((axis 0)) @@ -325,31 +330,17 @@ of specialized arrays is supported." ;;; vectors or not simple. (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) - (offset - #.(ecase sb!c:*backend-byte-order* - (:little-endian - (- sb!vm:other-pointer-lowtag)) - (:big-endian - (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag))))) - ;; WIDETAG-OF needs extra code to handle LIST and - ;; FUNCTION lowtags. We're only dispatching on - ;; other pointers, so let's do the lowtag - ;; extraction manually. - (when (sb!vm::%other-pointer-p ,array-var) - (setf tag - (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address ,array-var)) - offset))) - ;; 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%%)) (macrolet ((%ref (accessor-getter extra-params) `(funcall (,accessor-getter array) array index ,@extra-params)) @@ -439,7 +430,10 @@ of specialized arrays is supported." 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 @@ -454,16 +448,16 @@ of specialized arrays is supported." 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))) @@ -476,14 +470,33 @@ of specialized arrays is supported." (defun data-vector-ref-with-offset (array index offset) (hairy-data-vector-ref array (+ index offset))) +(defun invalid-array-p (array) + (and (array-header-p array) + (consp (%array-displaced-p array)))) + +(declaim (ftype (function (array) nil) invalid-array-error)) +(defun invalid-array-error (array) + (aver (array-header-p array)) + ;; Array invalidation stashes the original dimensions here... + (let ((dims (%array-displaced-p array)) + (et (array-element-type array))) + (error 'invalid-array-error + :datum array + :expected-type + (if (cdr dims) + `(array ,et ,dims) + `(vector ,et ,@dims))))) + (declaim (ftype (function (array integer integer &optional t) nil) invalid-array-index-error)) (defun invalid-array-index-error (array index bound &optional axis) - (error 'invalid-array-index-error - :array array - :axis axis - :datum index - :expected-type `(integer 0 (,bound)))) + (if (invalid-array-p array) + (invalid-array-error array) + (error 'invalid-array-index-error + :array array + :axis axis + :datum index + :expected-type `(integer 0 (,bound))))) ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed (defun %array-row-major-index (array subscripts @@ -520,7 +533,7 @@ of specialized arrays is supported." (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)) @@ -699,25 +712,7 @@ of specialized arrays is supported." (error "Axis number ~W is too big; ~S only has ~D dimension~:P." axis-number array (%array-rank array))) (t - ;; ANSI sayeth (ADJUST-ARRAY dictionary entry): - ;; - ;; "If A is displaced to B, the consequences are - ;; unspecified if B is adjusted in such a way that it no - ;; longer has enough elements to satisfy A. - ;; - ;; In situations where this matters we should be doing a - ;; bounds-check, which in turn uses ARRAY-DIMENSION -- so - ;; this seems like a good place to signal an error. - (multiple-value-bind (target offset) (array-displacement array) - (when (and target - (> (array-total-size array) - (- (array-total-size target) offset))) - (error 'displaced-to-array-too-small-error - :format-control "~@" - :format-arguments (list (array-total-size array) - (- (array-total-size target) offset)))) - (%array-dimension array axis-number))))) + (%array-dimension array axis-number)))) (defun array-dimensions (array) #!+sb-doc @@ -760,6 +755,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." @@ -782,6 +778,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." @@ -809,7 +806,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)) @@ -827,7 +823,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)) @@ -842,7 +838,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) @@ -864,6 +859,8 @@ of specialized arrays is supported." displaced-to displaced-index-offset) #!+sb-doc "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff." + (when (invalid-array-p array) + (invalid-array-error array)) (let ((dimensions (if (listp dimensions) dimensions (list dimensions)))) (cond ((/= (the fixnum (length (the list dimensions))) (the fixnum (array-rank array))) @@ -894,7 +891,7 @@ of specialized arrays is supported." (set-array-header array array-data array-size (get-new-fill-pointer array array-size fill-pointer) - 0 dimensions nil) + 0 dimensions nil nil) (if (array-header-p array) ;; simple multidimensional or single dimensional array (make-array dimensions @@ -921,7 +918,7 @@ of specialized arrays is supported." (set-array-header array displaced-to array-size (get-new-fill-pointer array array-size fill-pointer) - displacement dimensions t) + displacement dimensions t nil) ;; simple multidimensional or single dimensional array (make-array dimensions :element-type element-type @@ -951,7 +948,7 @@ of specialized arrays is supported." (set-array-header array new-data new-length (get-new-fill-pointer array new-length fill-pointer) - 0 dimensions nil) + 0 dimensions nil nil) new-data)))) (t (let ((old-length (%array-available-elements array)) @@ -977,12 +974,12 @@ of specialized arrays is supported." initial-element-p)) (if (adjustable-array-p array) (set-array-header array new-data new-length - nil 0 dimensions nil) + nil 0 dimensions nil nil) (let ((new-array (make-array-header sb!vm:simple-array-widetag array-rank))) (set-array-header new-array new-data new-length - nil 0 dimensions nil))))))))))) + nil 0 dimensions nil t))))))))))) (defun get-new-fill-pointer (old-array new-array-size fill-pointer) @@ -1062,9 +1059,76 @@ of specialized arrays is supported." vector) (t (subseq vector 0 new-length)))) +;;; BIG THREAD SAFETY NOTE +;;; +;;; ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very +;;; thread unsafe. They are nonatomic, and can mess with parallel +;;; code using the same arrays. +;;; +;;; A likely seeming fix is an additional level of indirection: +;;; ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would +;;; hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO +;;; would hold everything ARRAY-HEADER now holds. This allows +;;; consing up a new ARRAY-INFO and replacing it atomically in +;;; the ARRAY-HEADER. +;;; +;;; %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty +;;; one: not only is it needed extremely rarely, which makes +;;; any thread safety bugs involving it look like rare random +;;; corruption, but because it walks the chain *upwards*, which +;;; may violate user expectations. + +(defun %save-displaced-array-backpointer (array data) + (flet ((purge (pointers) + (remove-if (lambda (value) + (or (not value) (eq array value))) + pointers + :key #'weak-pointer-value))) + ;; Add backpointer to the new data vector if it has a header. + (when (array-header-p data) + (setf (%array-displaced-from data) + (cons (make-weak-pointer array) + (purge (%array-displaced-from data))))) + ;; Remove old backpointer, if any. + (let ((old-data (%array-data-vector array))) + (when (and (neq data old-data) (array-header-p old-data)) + (setf (%array-displaced-from old-data) + (purge (%array-displaced-from old-data))))))) + +(defun %walk-displaced-array-backpointers (array new-length) + (dolist (p (%array-displaced-from array)) + (let ((from (weak-pointer-value p))) + (when (and from (eq array (%array-data-vector from))) + (let ((requires (+ (%array-available-elements from) + (%array-displacement from)))) + (unless (>= new-length requires) + ;; ANSI sayeth (ADJUST-ARRAY dictionary entry): + ;; + ;; "If A is displaced to B, the consequences are unspecified if B is + ;; adjusted in such a way that it no longer has enough elements to + ;; satisfy A. + ;; + ;; since we're hanging on a weak pointer here, we can't signal an + ;; error right now: the array that we're looking at might be + ;; garbage. Instead, we set all dimensions to zero so that next + ;; safe access to the displaced array will trap. Additionally, we + ;; save the original dimensions, so we can signal a more + ;; understandable error when the time comes. + (%walk-displaced-array-backpointers from 0) + (setf (%array-fill-pointer from) 0 + (%array-available-elements from) 0 + (%array-displaced-p from) (array-dimensions array)) + (dotimes (i (%array-rank from)) + (setf (%array-dimension from i) 0)))))))) + ;;; Fill in array header with the provided information, and return the array. (defun set-array-header (array data length fill-pointer displacement dimensions - &optional displacedp) + displacedp newp) + (if newp + (setf (%array-displaced-from array) nil) + (%walk-displaced-array-backpointers array length)) + (when displacedp + (%save-displaced-array-backpointer array data)) (setf (%array-data-vector array) data) (setf (%array-available-elements array) length) (cond (fill-pointer @@ -1106,44 +1170,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. @@ -1160,14 +1197,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