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 (file)
--- 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 (file)
--- 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 (file)
--- 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 "~@<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 @@ 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"