1.0.12.13: sequence optimizations: SUBSEQ, part 3

* Split the optimized data-vector accessor fetching logic into a
  global macro, so that sequence functions can fetch the appropriate
  setter/getter just once, instead of doing the dispatch per access.

* Use this to optimize VECTOR-SUBSEQ*.

diff --git a/NEWS b/NEWS
index bd55399..1f3ead3 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,9 @@ changes in sbcl-1.0.13 relative to sbcl-1.0.12:
     unparsing of directory pathnames as files. Analogously,
     SB-EXT:PARSE-NATIVE-NAMESTRING takes an AS-DIRECTORY, forcing a
     filename to parse into a directory pathname.
+  * optimization: SUBSEQ is 30-80% faster for strings and vectors
+    whose element-type or simplicity is not fully known at
+    compile-time.
   * bug fix: some sequence functions elided bounds checking when
     SPEED > SAFETY.
   * bug fix: too liberal weakening of union-type checks when SPEED >

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 3a9d703..4268f55 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -323,71 +323,80 @@ of specialized arrays is supported."
 ;;; 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 (table-name extra-params)
-             `(funcall
-               (the function
-                 (let ((tag 0)
-                       (offset
-                        #.(ecase sb!c:*backend-byte-order*
-                            (:little-endian
-                             (- sb!vm:other-pointer-lowtag))
-                            (:big-endian
-                             (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
-                   ;; 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))
-                                             offset)))
-                   ;; SYMBOL-GLOBAL-VALUE is a performance hack
-                   ;; for threaded builds.
-                   (svref (sb!vm::symbol-global-value ',table-name) tag)))
-               array index ,@extra-params))
-           (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)))
-                   (%define ,table-name ,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)))
-                         (%define ,table-name ,extra-params))
-                       ;; 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)))))))
+(macrolet ((def (name table-name)
+             `(progn
+                (defvar ,table-name)
+                (defmacro ,name (array-var)
+                 `(the function
+                    (let ((tag 0)
+                          (offset
+                           #.(ecase sb!c:*backend-byte-order*
+                               (:little-endian
+                                (- sb!vm:other-pointer-lowtag))
+                               (:big-endian
+                                (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
+                      ;; 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-var)
+                        (setf tag
+                              (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address ,array-var))
+                                                offset)))
+                      ;; SYMBOL-GLOBAL-VALUE is a performance hack
+                      ;; for threaded builds.
+                      (svref (sb!vm::symbol-global-value ',',table-name) tag)))))))
+  (def !find-data-vector-setter *data-vector-setters*)
+  (def !find-data-vector-setter/check-bounds *data-vector-setters/check-bounds*)
+  (def !find-data-vector-reffer *data-vector-reffers*)
+  (def !find-data-vector-reffer/check-bounds *data-vector-reffers/check-bounds*))
+
+(macrolet ((%ref (accessor-getter extra-params)
+             `(funcall (,accessor-getter array) array index ,@extra-params))
+           (define (accessor-name slow-accessor-name accessor-getter
+                                  extra-params check-bounds)
+             `(progn
+                (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)))
+                  (%ref ,accessor-getter ,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)))
+                        (%ref ,accessor-getter ,extra-params))
+                      ;; 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))
+    !find-data-vector-reffer
+    nil (progn))
   (define hairy-data-vector-set slow-hairy-data-vector-set
-    *data-vector-setters* (new-value) (progn))
+    !find-data-vector-setter
+    (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)))
+    !find-data-vector-reffer/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))))
+    !find-data-vector-setter/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))

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index a5173aa..cefc59b 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -380,14 +380,16 @@
                     (end end)
                     :check-fill-pointer t
                     :force-inline t)
-    (let ((copy (%make-sequence-like sequence (- end start))))
+    (let* ((copy (%make-sequence-like sequence (- end start)))
+           (setter (!find-data-vector-setter copy))
+           (reffer (!find-data-vector-reffer data)))
       (declare (optimize (speed 3) (safety 0)))
       (do ((old-index start (1+ old-index))
            (new-index 0 (1+ new-index)))
           ((= old-index end) copy)
         (declare (index old-index new-index))
-        (setf (aref copy new-index)
-              (aref data old-index))))))
+        (funcall setter copy new-index
+                 (funcall reffer data old-index))))))
 
 (defun list-subseq* (sequence start end)
   (declare (type list sequence)

diff --git a/version.lisp-expr b/version.lisp-expr
index 8ae8610..7e93b12 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.12.12"
+"1.0.12.13"