1.0.4.92: faster generic array access

        * Replace the typecase-based HAIRY-DATA-VECTOR-* with a table-driven
          dispatch on widetags
        * Move bounds checking of one-dimension AREFs into HAIRY-DATA-VECTOR-*
          from the caller, so that we can avoid doing a full ARRAY-DIMENSION
          in the common case.
        * 3-5x speedup on generic array accesses

NEWS

@@ -18,6 +18,11 @@ changes in sbcl-1.0.5 relative to sbcl-1.0.4:
     variants no longer cons.
   * optimization: Direct calls to CHAR-{EQUAL,LESSP,GREATERP} and
     their NOT- variants no longer cons.
+  * optimization: EQUAL hash tables no longer use SXHASH for objects
+    of all data types, but instead use an EQL hash for types for which
+    EQUAL is the same as EQL
+  * optimization: the non-inlined generic versions of AREF and (SETF AREF)
+    are significantly faster
   * enhancement: XREF information is now collected to references made
     to global variables using SYMBOL-VALUE and a constant argument.
   * enhancement: SIGINT now causes a specific condition
@@ -54,9 +59,6 @@ changes in sbcl-1.0.5 relative to sbcl-1.0.4:
   * bug fix: modifying the contents of an array could change the return
     value of SXHASH on that array, which is only allowed for strings 
     and bit vectors (bug introduced in 0.9.16)
-  * optimization: EQUAL hash tables no longer use SXHASH for objects
-    of all data types, but instead use an EQL hash for types for which
-    EQUAL is the same as EQL
   * improvement: the x86-64/darwin port now passes all tests and
     should be considered non-experimental.
   * improvement: a style-warning is signaled for CASE (etc) clauses with

package-data-list.lisp-expr

@@ -1262,7 +1262,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "GET-CLOSURE-LENGTH" "GET-HEADER-DATA"
                "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF" "WIDETAG-OF"
                "GET-MACHINE-VERSION" "HAIRY-DATA-VECTOR-REF"
-               "HAIRY-DATA-VECTOR-SET" "HAIRY-TYPE"
+               "HAIRY-DATA-VECTOR-REF/CHECK-BOUNDS"  "HAIRY-DATA-VECTOR-SET"
+               "HAIRY-DATA-VECTOR-SET/CHECK-BOUNDS""HAIRY-TYPE"
                "HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER"
                "HANDLE-CIRCULARITY" "HOST" "IGNORE-IT" "ILL-BIN"
                "ILL-BOUT" "ILL-IN" "ILL-OUT" "INDEX-OR-MINUS-1"
@@ -1542,6 +1543,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%NUMERATOR" "CLASSOID-TYPEP" "DSD-READ-ONLY"
                "DSD-DEFAULT" "LAYOUT-INHERITS" "DD-LENGTH"
                "%CODE-ENTRY-POINTS" "%DENOMINATOR" "%SIMPLE-FUN-XREFS"
+               "%OTHER-POINTER-P"
 
                "STANDARD-CLASSOID" "CLASSOID-OF"
                "MAKE-STANDARD-CLASSOID" "CLASSOID-CELL-TYPEP"

src/code/array.lisp

@@ -316,50 +316,152 @@ of specialized arrays is supported."
   "Construct a SIMPLE-VECTOR from the given objects."
   (coerce (the list objects) 'simple-vector))
 
+
 ;;;; accessor/setter functions
-(defun hairy-data-vector-ref (array index)
-  (with-array-data ((vector array) (index index) (end))
-    (declare (ignore end))
-    (etypecase vector .
-               #.(map 'list
-                      (lambda (saetp)
-                        (let* ((type (sb!vm:saetp-specifier saetp))
-                               (atype `(simple-array ,type (*))))
-                          `(,atype
-                            (data-vector-ref (the ,atype vector) index))))
-                      (sort
-                       (copy-seq
-                        sb!vm:*specialized-array-element-type-properties*)
-                       #'> :key #'sb!vm:saetp-importance)))))
+
+;;; Dispatch to an optimized routine the data vector accessors for
+;;; each different specialized vector type. Do dispatching by looking
+;;; up the widetag in the array rather than with the typecases, which
+;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
+;;; provide separate versions where bounds checking has been moved
+;;; from the callee to the caller, since it's much cheaper to do once
+;;; the type information is available. Finally, for each of these
+;;; routines also provide a slow path, taken for arrays that are not
+;;; vectors or not simple.
+(macrolet ((define (accessor-name slow-accessor-name table-name extra-params
+                                  check-bounds)
+             `(progn
+                (defvar ,table-name)
+                (defun ,accessor-name (array index ,@extra-params)
+                  (declare (optimize speed
+                                     ;; (SAFETY 0) is ok. All calls to
+                                     ;; these functions are generated by
+                                     ;; the compiler, so argument count
+                                     ;; checking isn't needed. Type checking
+                                     ;; is done implicitly via the widetag
+                                     ;; dispatch.
+                                     (safety 0)))
+                  #1=(funcall (the function
+                                (let ((tag 0))
+                                  ;; 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)
+                                    (setf tag (sb!sys:sap-ref-8
+                                               (int-sap (get-lisp-obj-address array))
+                                               (- sb!vm:other-pointer-lowtag))))
+                                  ;; SYMBOL-GLOBAL-VALUE is a performance hack
+                                  ;; for threaded builds.
+                                  (svref (sb!vm::symbol-global-value ',table-name)
+                                         tag)))
+                                array index ,@extra-params))
+                (defun ,slow-accessor-name (array index ,@extra-params)
+                  (declare (optimize speed (safety 0)))
+                  (if (not (%array-displaced-p array))
+                      ;; The reasonably quick path of non-displaced complex
+                      ;; arrays.
+                      (let ((array (%array-data-vector array)))
+                        #1#)
+                      ;; The real slow path.
+                      (with-array-data
+                          ((vector array)
+                           (index (locally
+                                      (declare (optimize (speed 1) (safety 1)))
+                                    (,@check-bounds index)))
+                           (end)
+                           :force-inline t)
+                        (declare (ignore end))
+                        (,accessor-name vector index ,@extra-params)))))))
+  (define hairy-data-vector-ref slow-hairy-data-vector-ref
+    *data-vector-reffers* nil (progn))
+  (define hairy-data-vector-set slow-hairy-data-vector-set
+    *data-vector-setters* (new-value) (progn))
+  (define hairy-data-vector-ref/check-bounds
+      slow-hairy-data-vector-ref/check-bounds
+    *data-vector-reffers/check-bounds* nil
+    (%check-bound array (array-dimension array 0)))
+  (define hairy-data-vector-set/check-bounds
+      slow-hairy-data-vector-set/check-bounds
+    *data-vector-setters/check-bounds* (new-value)
+    (%check-bound array (array-dimension array 0))))
+
+(defun hairy-ref-error (array index &optional new-value)
+  (declare (ignore index new-value))
+  (error 'type-error
+         :datum array
+         :expected-type 'vector))
+
+;;; Populate the dispatch tables.
+(macrolet ((define-reffer (saetp check-form)
+             (let* ((type (sb!vm:saetp-specifier saetp))
+                    (atype `(simple-array ,type (*))))
+               `(named-lambda optimized-data-vector-ref (vector index)
+                  (declare (optimize speed (safety 0)))
+                  (data-vector-ref (the ,atype vector)
+                                   (locally
+                                       (declare (optimize (safety 1)))
+                                     (the index
+                                       (,@check-form index)))))))
+           (define-setter (saetp check-form)
+             (let* ((type (sb!vm:saetp-specifier saetp))
+                    (atype `(simple-array ,type (*))))
+               `(named-lambda optimized-data-vector-set (vector index new-value)
+                  (declare (optimize speed (safety 0)))
+                  (data-vector-set (the ,atype vector)
+                                   (locally
+                                       (declare (optimize (safety 1)))
+                                     (the index
+                                       (,@check-form index)))
+                                   (locally
+                                       ;; SPEED 1 needed to avoid the compiler
+                                       ;; from downgrading the type check to
+                                       ;; a cheaper one.
+                                       (declare (optimize (speed 1)
+                                                          (safety 1)))
+                                     (the ,type new-value)))
+                  ;; For specialized arrays, the return from
+                  ;; data-vector-set would have to be reboxed to be a
+                  ;; (Lisp) return value; instead, we use the
+                  ;; already-boxed value as the return.
+                  new-value)))
+           (define-reffers (symbol deffer check-form slow-path)
+             `(progn
+                (setf ,symbol (make-array sb!vm::widetag-mask
+                                          :initial-element #'hairy-ref-error))
+                ,@(loop for widetag in '(sb!vm:complex-vector-widetag
+                                         sb!vm:complex-vector-nil-widetag
+                                         sb!vm:complex-bit-vector-widetag
+                                         sb!vm:complex-character-string-widetag
+                                         sb!vm:complex-base-string-widetag
+                                         sb!vm:simple-array-widetag
+                                         sb!vm:complex-array-widetag)
+                        collect `(setf (svref ,symbol ,widetag) ,slow-path))
+                ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
+                        for widetag = (sb!vm:saetp-typecode saetp)
+                        collect `(setf (svref ,symbol ,widetag)
+                                       (,deffer ,saetp ,check-form))))))
+  (defun !hairy-data-vector-reffer-init ()
+    (define-reffers *data-vector-reffers* define-reffer
+      (progn)
+      #'slow-hairy-data-vector-ref)
+    (define-reffers *data-vector-setters* define-setter
+      (progn)
+      #'slow-hairy-data-vector-set)
+    (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
+      (%check-bound vector (length vector))
+      #'slow-hairy-data-vector-set/check-bounds)))
 
 ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
 ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
 ;;; definition is needed for the compiler to use in constant folding.)
 (defun data-vector-ref (array index)
   (hairy-data-vector-ref array index))
 
-(defun hairy-data-vector-set (array index new-value)
-  (with-array-data ((vector array) (index index) (end))
-    (declare (ignore end))
-    (etypecase vector .
-               #.(map 'list
-                      (lambda (saetp)
-                        (let* ((type (sb!vm:saetp-specifier saetp))
-                               (atype `(simple-array ,type (*))))
-                          `(,atype
-                            (data-vector-set (the ,atype vector) index
-                                             (the ,type new-value))
-                            ;; For specialized arrays, the return from
-                            ;; data-vector-set would have to be
-                            ;; reboxed to be a (Lisp) return value;
-                            ;; instead, we use the already-boxed value
-                            ;; as the return.
-                            new-value)))
-                      (sort
-                       (copy-seq
-                        sb!vm:*specialized-array-element-type-properties*)
-                       #'> :key #'sb!vm:saetp-importance)))))
-
 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
 (defun %array-row-major-index (array subscripts
                                      &optional (invalid-index-error-p t))

src/code/cold-init.lisp

@@ -117,6 +117,9 @@
   ;; this to be initialized, so we initialize it right away.
   (show-and-call !random-cold-init)
 
+  ;; Must be done before any non-opencoded array references are made.
+  (show-and-call !hairy-data-vector-reffer-init)
+
   (show-and-call !character-database-cold-init)
   (show-and-call !character-name-database-cold-init)
 

src/compiler/array-tran.lisp

@@ -112,21 +112,27 @@
   (assert-array-rank array (1- (length stuff)))
   (assert-new-value-type (car (last stuff)) array))
 
-(defoptimizer (hairy-data-vector-ref derive-type) ((array index))
-  (extract-upgraded-element-type array))
-(defoptimizer (data-vector-ref derive-type) ((array index))
-  (extract-upgraded-element-type array))
+(macrolet ((define (name)
+             `(defoptimizer (,name derive-type) ((array index))
+                (extract-upgraded-element-type array))))
+  (define hairy-data-vector-ref)
+  (define hairy-data-vector-ref/check-bounds)
+  (define data-vector-ref))
+
 #!+x86
 (defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset))
   (extract-upgraded-element-type array))
 
-(defoptimizer (data-vector-set derive-type) ((array index new-value))
-  (assert-new-value-type new-value array))
+(macrolet ((define (name)
+             `(defoptimizer (,name derive-type) ((array index new-value))
+                (assert-new-value-type new-value array))))
+  (define hairy-data-vector-set)
+  (define hairy-data-vector-set/check-bounds)
+  (define data-vector-set))
+
 #!+x86
 (defoptimizer (data-vector-set-with-offset derive-type) ((array index offset new-value))
   (assert-new-value-type new-value array))
-(defoptimizer (hairy-data-vector-set derive-type) ((array index new-value))
-  (assert-new-value-type new-value array))
 
 ;;; Figure out the type of the data vector if we know the argument
 ;;; element type.
@@ -753,8 +759,49 @@
       (with-row-major-index (array indices index new-value)
         (hairy-data-vector-set array index new-value)))))
 
+;; For AREF of vectors we do the bounds checking in the callee. This
+;; lets us do a significantly more efficient check for simple-arrays
+;; without bloating the code.
+(deftransform aref ((array index) (t t) * :node node)
+  (if (policy node (zerop insert-array-bounds-checks))
+      `(hairy-data-vector-ref array index)
+      `(hairy-data-vector-ref/check-bounds array index)))
+
+(deftransform %aset ((array index new-value) (t t t) * :node node)
+  (if (policy node (zerop insert-array-bounds-checks))
+      `(hairy-data-vector-set array index new-value)
+      `(hairy-data-vector-set/check-bounds array index new-value)))
+
+;;; But if we find out later that there's some useful type information
+;;; available, switch back to the normal one to give other transforms
+;;; a stab at it.
+(macrolet ((define (name transform-to extra extra-type)
+             `(deftransform ,name ((array index ,@extra))
+                (let ((type (lvar-type array))
+                      (element-type (extract-upgraded-element-type array)))
+                  ;; If an element type has been declared, we want to
+                  ;; use that information it for type checking (even
+                  ;; if the access can't be optimized due to the array
+                  ;; not being simple).
+                  (when (eql element-type *wild-type*)
+                    (when (or (not (array-type-p type))
+                              ;; If it's a simple array, we might be able
+                              ;; to inline the access completely.
+                              (not (null (array-type-complexp type))))
+                      (give-up-ir1-transform
+                       "Upgraded element type of array is not known at compile time."))))
+                `(,',transform-to array
+                                  (%check-bound array
+                                                (array-dimension array 0)
+                                                index)
+                                  ,@',extra))))
+  (define hairy-data-vector-ref/check-bounds
+      hairy-data-vector-ref nil nil)
+  (define hairy-data-vector-set/check-bounds
+      hairy-data-vector-set (new-value) (*)))
+
 (deftransform aref ((array index) ((or simple-vector
-                                       simple-unboxed-array)
+                                       (simple-unboxed-array 1))
                                    index))
   (let ((type (lvar-type array)))
     (unless (array-type-p type)

src/compiler/fndb.lisp

@@ -1444,6 +1444,11 @@
 (defknown hairy-data-vector-ref (array index) t
   (foldable explicit-check))
 (defknown hairy-data-vector-set (array index t) t (unsafe explicit-check))
+(defknown hairy-data-vector-ref/check-bounds (array index) t
+  (foldable explicit-check))
+(defknown hairy-data-vector-set/check-bounds (array index t)
+  t
+  (unsafe explicit-check))
 (defknown %caller-frame-and-pc () (values t t) (flushable))
 (defknown %with-array-data (array index (or index null))
   (values (simple-array * (*)) index index index)

src/compiler/generic/late-type-vops.lisp

@@ -29,6 +29,10 @@
   (instance-pointer-lowtag)
   :mask lowtag-mask)
 
+(!define-type-vops %other-pointer-p nil nil nil
+  (other-pointer-lowtag)
+  :mask lowtag-mask)
+
 (!define-type-vops bignump check-bignum bignum object-not-bignum-error
   (bignum-widetag))
 

src/compiler/generic/parms.lisp

@@ -59,6 +59,12 @@
     #!-sb-thread
     *stepping*
 
+    ;; Dispatch tables for generic array access
+    sb!impl::*data-vector-reffers*
+    sb!impl::*data-vector-setters*
+    sb!impl::*data-vector-reffers/check-bounds*
+    sb!impl::*data-vector-setters/check-bounds*
+
     ;; hash table weaknesses
     :key
     :value

src/compiler/generic/vm-fndb.lisp

@@ -20,7 +20,7 @@
            complex-rational-p complex-float-p complex-single-float-p
            complex-double-float-p #!+long-float complex-long-float-p
            complex-vector-p
-           base-char-p %standard-char-p %instancep
+           base-char-p %standard-char-p %instancep %other-pointer-p
            base-string-p simple-base-string-p
            #!+sb-unicode character-string-p
            #!+sb-unicode simple-character-string-p

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.4.91"
+"1.0.4.92"