Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code array.lisp, 1.83, 1.84 condition.lisp, 1.96, 1.97 fop.lisp, 1.48, 1.49 stream.lisp, 1.110, 1.111
|
From: Nikodemus S. <de...@us...> - 2009-05-06 16:28:11
|
Update of /cvsroot/sbcl/sbcl/src/code In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv2238/src/code Modified Files: array.lisp condition.lisp fop.lisp stream.lisp Log Message: 1.0.28.19: faster ARRAY-DIMENSION for non-vectors Previously each ARRAY-DIMENSION call for a non-vector resulted in checking (1) if the array was a displaced array (2) if the array it was displaced to was still big enough for it. This sucks pretty badly, because we use ARRAY-DIMENSION in bounds checking -- especially given how rare it is to have an array displaced to an adjustable array. Add a new slot, ARRAY-DISPLACED-FROM, to array-headers, and store a list of weak backpointers to arrays displaced to the array in question there. SET-ARRAY-HEADER (as part of ADJUST-ARRAY) now checks this list, and signals an error if any of the displaced-from arrays is larger than the new size. This also allows us to open code ARRAY-DIMENSION as long as the array rank is known. Index: array.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/array.lisp,v retrieving revision 1.83 retrieving revision 1.84 diff -u -d -r1.83 -r1.84 --- array.lisp 23 Apr 2009 12:26:57 -0000 1.83 +++ array.lisp 6 May 2009 16:28:03 -0000 1.84 @@ -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)) @@ -217,6 +218,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 +228,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)) @@ -699,25 +702,7 @@ (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 "~@<The displaced-to array is too small. ~S ~ - elements after offset required, ~S available.~:@>" - :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 @@ -894,7 +879,7 @@ (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 +906,7 @@ (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 +936,7 @@ (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 +962,12 @@ 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 +1047,36 @@ vector) (t (subseq vector 0 new-length)))) +(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))))))) + ;;; 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) + ;; 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) (setf (%array-data-vector array) data) (setf (%array-available-elements array) length) (cond (fill-pointer Index: condition.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v retrieving revision 1.96 retrieving revision 1.97 diff -u -d -r1.96 -r1.97 --- condition.lisp 12 Jan 2009 11:26:42 -0000 1.96 +++ condition.lisp 6 May 2009 16:28:03 -0000 1.97 @@ -954,12 +954,6 @@ '(:ansi-cl :function make-array) '(:ansi-cl :function sb!xc:upgraded-array-element-type)))) -(define-condition displaced-to-array-too-small-error - (reference-condition simple-error) - () - (:default-initargs - :references (list '(:ansi-cl :function adjust-array)))) - (define-condition type-warning (reference-condition simple-warning) () (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) Index: fop.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/fop.lisp,v retrieving revision 1.48 retrieving revision 1.49 diff -u -d -r1.48 -r1.49 --- fop.lisp 24 Apr 2009 10:06:20 -0000 1.48 +++ fop.lisp 6 May 2009 16:28:03 -0000 1.49 @@ -417,7 +417,8 @@ (dimensions () (cons (pop-stack) dimensions))) ((zerop i) dimensions) (declare (type index i))) - nil) + nil + t) res)) (define-fop (fop-single-float-vector 84) Index: stream.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/stream.lisp,v retrieving revision 1.110 retrieving revision 1.111 diff -u -d -r1.110 -r1.111 --- stream.lisp 22 Apr 2009 15:42:41 -0000 1.110 +++ stream.lisp 6 May 2009 16:28:03 -0000 1.111 @@ -1604,7 +1604,7 @@ (setf workspace new-workspace offset-current current) (set-array-header buffer workspace new-length - current+1 0 new-length nil)) + current+1 0 new-length nil nil)) (setf (fill-pointer buffer) current+1)) (setf (char workspace offset-current) character)))) current+1)) @@ -1638,7 +1638,7 @@ offset-current current offset-dst-end dst-end) (set-array-header buffer workspace new-length - dst-end 0 new-length nil)) + dst-end 0 new-length nil nil)) (setf (fill-pointer buffer) dst-end)) (replace workspace string :start1 offset-current :start2 start :end2 end))) |