From a0238f83af553a3ff662824fc73aca3ba01112f6 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 7 May 2009 11:11:05 +0000 Subject: [PATCH] 1.0.28.24: better %ARRAY-DISPLACED-FROM handling James Knight pointed out that signalling an error at ADJUST-ARRAY time is not quite right, since the other array may be otherwise unreachable already -- we're following a weak pointer after all. Oops. Enter the twilight zone between clever by half and slightly horrible: When a potentially bogus ADJUST-ARRAY is detected, walk the chain of backpointers, and set FILL-POINTER, AVAILABLE-ELEMENTS, and all dimensions of the too-large displaced-from arrays to zero. This in turn causes any typecheck involving the array dimensions to trap, as well as any bounds-checked access. To make these errors more understandable, save the original dimensions of the array, punning them to the ARRAY-DISPLACED-P slot, and identify the bogus arrays in INVALID-ARRAY-INDEX-ERROR function, and the OBJECT-NOT-TYPE-ERROR internal error handler; signal an INVALID-ARRAY-ERROR instead, which explains what is going on. Whew. Oh, and a BIG THREAD SAFETY NOTE regarding the fundamental nature of our ADJUST-ARRAY implementation. It is not thread safe in parallel with accesses to the array being adjusted. Tentative idea is to add one more level of indirection to array headers, so that we can get atomic updates without locking. --- package-data-list.lisp-expr | 3 +- src/code/array.lisp | 117 +++++++++++++++++++++++++++++--------- src/code/condition.lisp | 15 +++++ src/code/interr.lisp | 14 +++-- src/code/pred.lisp | 3 +- src/compiler/generic/objdef.lisp | 6 +- tests/array.pure.lisp | 22 +++---- version.lisp-expr | 2 +- 8 files changed, 131 insertions(+), 51 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index dcfd780..73d7c1b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -877,7 +877,9 @@ possibly temporariliy, because it might be used internally." "COMPILED-PROGRAM-ERROR" "ENCAPSULATED-CONDITION" "INTERPRETED-PROGRAM-ERROR" + "INVALID-ARRAY-ERROR" "INVALID-ARRAY-INDEX-ERROR" + "INVALID-ARRAY-P" "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" "SIMPLE-PARSE-ERROR" "SIMPLE-PROGRAM-ERROR" "SIMPLE-READER-ERROR" @@ -1223,7 +1225,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%CHECK-GENERIC-SEQUENCE-BOUNDS" "%CHECK-VECTOR-SEQUENCE-BOUNDS" "%CLOSURE-FUN" "%CLOSURE-INDEX-REF" - "%COMPARE-AND-SWAP-ARRAY-DISPLACED-FROM" "%COMPARE-AND-SWAP-CAR" "%COMPARE-AND-SWAP-CDR" "%COMPARE-AND-SWAP-INSTANCE-REF" diff --git a/src/code/array.lisp b/src/code/array.lisp index 7df13d9..daedf8a 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -467,14 +467,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 @@ -837,6 +856,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))) @@ -1035,36 +1056,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) - (when (array-header-p data) - (let* ((old (%array-displaced-from data)) - (new (cons (make-weak-pointer array) old))) - (loop until (eq old (%compare-and-swap-array-displaced-from data old new)) - do (setf old (%array-displaced-from data) - new (rplacd new (remove-if-not #'weak-pointer-value old))))))) + (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 displacedp newp) (if newp (setf (%array-displaced-from array) nil) - ;; 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. - ;; - ;; so check the backpointers and signal an error if appropriate. - (dolist (p (%array-displaced-from array)) - (let ((from (weak-pointer-value p))) - (when from - (let ((requires (+ (%array-available-elements from) - (%array-displacement from)))) - (unless (>= length requires) - (error 'simple-reference-error - :format-control "Cannot shrink ~S to ~S elements: displaced array ~S requires at least ~S elements." - :format-arguments (list 'adjust-array length from requires)))))))) - (%save-displaced-array-backpointer array data) + (%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 diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 7cc8946..317d8bc 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1110,6 +1110,21 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) ;; Extract the bound from (INTEGER 0 (BOUND)) (caaddr (type-error-expected-type condition))))))) +(define-condition invalid-array-error (reference-condition type-error) () + (:report + (lambda (condition stream) + (let ((*print-array* nil)) + (format stream + "~@" + (type-error-expected-type condition) + (array-displacement (type-error-datum condition)))))) + (:default-initargs + :references + (list '(:ansi-cl :function adjust-array)))) + (define-condition index-too-large-error (type-error) () (:report diff --git a/src/code/interr.lisp b/src/code/interr.lisp index c3f039f..e00663d 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -236,12 +236,14 @@ :operands (list this that))) (deferr object-not-type-error (object type) - (error (if (and (%instancep object) - (layout-invalid (%instance-layout object))) - 'layout-invalid - 'type-error) - :datum object - :expected-type type)) + (if (invalid-array-p object) + (invalid-array-error object) + (error (if (and (%instancep object) + (layout-invalid (%instance-layout object))) + 'layout-invalid + 'type-error) + :datum object + :expected-type type))) (deferr layout-invalid-error (object layout) (error 'layout-invalid diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 1bd09c7..2830c51 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -176,7 +176,8 @@ (extended-char 'extended-char) ((member t) 'boolean) (keyword 'keyword) - ((or array complex) (type-specifier (ctype-of object))) + ((or array complex) + (type-specifier (ctype-of object))) (t (let* ((classoid (layout-classoid (layout-of object))) (name (classoid-name classoid))) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 9869837..6e9d5d4 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -126,7 +126,7 @@ :ref-known (flushable foldable) :set-trans (setf %array-displacement) :set-known (unsafe)) - (displaced-p :type (member t nil) + (displaced-p :type t :ref-trans %array-displaced-p :ref-known (flushable foldable) :set-trans (setf %array-displaced-p) @@ -135,9 +135,7 @@ :ref-trans %array-displaced-from :ref-known (flushable) :set-trans (setf %array-displaced-from) - :set-known (unsafe) - :cas-trans %compare-and-swap-array-displaced-from - :cas-known (unsafe)) + :set-known (unsafe)) (dimensions :rest-p t)) (define-primitive-object (vector :type vector diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp index 5141d41..4c605ed 100644 --- a/tests/array.pure.lisp +++ b/tests/array.pure.lisp @@ -164,16 +164,18 @@ ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP ;;; test suite. (locally (declare (optimize (safety 3) (speed 0))) - (let* ((x (make-array 10 :fill-pointer 4 :element-type 'character - :initial-element #\space :adjustable t)) - (y (make-array 10 :fill-pointer 4 :element-type 'character - :displaced-to x))) - (handler-case - (adjust-array x '(5)) - (error (e) - (assert (typep e 'sb-int:simple-reference-error)) - (assert (equal '((:ansi-cl function adjust-array)) - (sb-int:reference-condition-references e))))))) + (let* ((x (make-array 10 :fill-pointer 4 :element-type 'character + :initial-element #\space :adjustable t)) + (y (make-array 10 :fill-pointer 4 :element-type 'character + :displaced-to x))) + (assert (eq x (adjust-array x '(5)))) + (assert (eq :error (handler-case + (char y 0) + (sb-int:invalid-array-error (e) + (assert (eq y (type-error-datum e))) + (assert (equal `(vector character 10) + (type-error-expected-type e))) + :error)))))) ;;; MISC.527: bit-vector bitwise operations used LENGTH to get a size ;;; of a vector diff --git a/version.lisp-expr b/version.lisp-expr index 51377fb..e86b8dc 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.28.23" +"1.0.28.24" -- 1.7.10.4