From: Nikodemus Siivola Date: Wed, 6 May 2009 16:28:03 +0000 (+0000) Subject: 1.0.28.19: faster ARRAY-DIMENSION for non-vectors X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7306e23c5a4687bef98fdfb3459aaf15fe79d5ca;p=sbcl.git 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. --- diff --git a/NEWS b/NEWS index 6abc921..b2e3e45 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,8 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- * optimization: compiler now generates faster typechecking code for array dimensions. + * optimization: ARRAY-DIMENSION is now faster for multidimensional and + non-simple arrays. * optimization: multidimensional array accesses in the absence of type information regarding array rank are approximately 10% faster due to open coding of ARRAY-RANK. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 50175f8..39cac6f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1200,6 +1200,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%ADJOIN-TEST-NOT" "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" + "%ARRAY-DISPLACED-FROM" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" "%ASSOC" @@ -1222,6 +1223,7 @@ 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" @@ -1377,7 +1379,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "DEFINE-STRUCTURE-SLOT-ADDRESSOR" "DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P" "!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO" - "DISPLACED-TO-ARRAY-TOO-SMALL-ERROR" "DIVISION-BY-ZERO-ERROR" "DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-HIGH-BITS" "DOUBLE-FLOAT-INT-EXPONENT" "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-SIGNIFICAND" @@ -2381,6 +2382,7 @@ structure representations" "*ALLOC-SIGNAL*" "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET" "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT" + "ARRAY-DISPLACED-FROM-SLOT" "ARRAY-ELEMENTS-SLOT" "ARRAY-FILL-POINTER-P-SLOT" "ARRAY-FILL-POINTER-SLOT" "ATOMIC-FLAG" "CHARACTER-REG-SC-NUMBER" diff --git a/src/code/array.lisp b/src/code/array.lisp index 2d4ab67..9dc3dfc 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -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 @@ 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 @@ -894,7 +879,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 +906,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 +936,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 +962,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 +1047,36 @@ of specialized arrays is supported." 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 diff --git a/src/code/condition.lisp b/src/code/condition.lisp index a4fbb97..7cc8946 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -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")))) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index d9acdd5..999faa3 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -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) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index e795f01..4158071 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1604,7 +1604,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (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 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") 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))) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index dadb0dc..1aeb26e 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -414,6 +414,7 @@ ,@(when element-type '(:element-type element-type)))) (setf (%array-displaced-p header) nil) + (setf (%array-displaced-from header) nil) ,@(let ((axis -1)) (mapcar (lambda (dim) `(setf (%array-dimension header ,(incf axis)) @@ -498,10 +499,11 @@ ((t) '(%array-dimension array 0)) ((nil) - '(length array)) + '(vector-length array)) ((:maybe) - (give-up-ir1-transform - "can't tell whether array is simple")))) + `(if (array-header-p array) + (%array-dimension array axis) + (vector-length array))))) (t '(%array-dimension array axis))))))) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index af7bb4f..4b8a53a 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2265,6 +2265,7 @@ core and return a descriptor to it." (write-wordindexed result sb!vm:array-data-slot data-vector) (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*) (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*) + (write-wordindexed result sb!vm:array-displaced-from-slot *nil-descriptor*) (let ((total-elements 1)) (dotimes (axis rank) (let ((dim (pop-stack))) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 09c331f..9869837 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -131,6 +131,13 @@ :ref-known (flushable foldable) :set-trans (setf %array-displaced-p) :set-known (unsafe)) + (displaced-from :type list + :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)) (dimensions :rest-p t)) (define-primitive-object (vector :type vector diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp index 0cf064f..5141d41 100644 --- a/tests/array.pure.lisp +++ b/tests/array.pure.lisp @@ -163,16 +163,17 @@ ;;; BUG 315: "no bounds check for access to displaced array" ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP ;;; test suite. -(multiple-value-bind (val err) - (ignore-errors - (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))) - (adjust-array x '(5)) - (char y 5)))) - (assert (and (not val) (typep err 'sb-kernel:displaced-to-array-too-small-error)))) +(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))))))) ;;; 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 24dc46d..a7d709f 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.18" +"1.0.28.19"