1.0.11.29: Faster CONCATENATE on strings

[sbcl.git] / src / code / array.lisp

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 4b01135..817bdb7 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -328,61 +328,59 @@ 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 (accessor-name slow-accessor-name table-name extra-params
+(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)))
-                  #1=(funcall
-                      (the function
-                        (let ((tag 0)
-                              (offset
-                               #.(ecase sb!c:*backend-byte-order*
-                                   (:little-endian
-                                    (- sb!vm:other-pointer-lowtag))
-                                   (:big-endian
-                                    ;; I'm not completely sure of what this
-                                    ;; 3 represents symbolically. It's
-                                    ;; just what all the LOAD-TYPE vops
-                                    ;; are doing.
-                                    (- 3 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))
-                (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)))))))
+               `(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)))))))
   (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
@@ -442,7 +440,7 @@ of specialized arrays is supported."
                 ,@(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-unicode sb!vm:complex-character-string-widetag
                                          sb!vm:complex-base-string-widetag
                                          sb!vm:simple-array-widetag
                                          sb!vm:complex-array-widetag)
@@ -471,6 +469,9 @@ of specialized arrays is supported."
 (defun data-vector-ref (array index)
   (hairy-data-vector-ref array index))
 
+(defun data-vector-ref-with-offset (array index offset)
+  (hairy-data-vector-ref array (+ index offset)))
+
 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
 (defun %array-row-major-index (array subscripts
                                      &optional (invalid-index-error-p t))