From 0152c2971917eed5117f5d6b53653bd8424b6b1f Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sat, 1 Dec 2007 18:06:11 +0000
Subject: [PATCH] 1.0.12.12: sequence optimizations: SUBSEQ, part 2

* New function: STRING-SUBSEQ*, and a compile-time dispatch to it with
  the element-type or simplicity is uncertain.

* Slightly better VECTOR-SUBSEQ*.
---
 package-data-list.lisp-expr |  1 +
 src/code/seq.lisp           | 43 +++++++++++++++++++++++++++++--------------
 src/compiler/seqtran.lisp   |  2 ++
 version.lisp-expr           |  2 +-
 4 files changed, 33 insertions(+), 15 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 5d6cfb927..246ce9b89 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1502,6 +1502,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE"
                "SPECIALIZABLE" "SPECIALIZABLE-VECTOR" "SPECIFIER-TYPE"
                "STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR"
+               "STRING-SUBSEQ*"
                "STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" "SUB-GC"
                "SYMBOLS-DESIGNATOR"
                "%INSTANCE-LENGTH"
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index eba838997..a5173aa1b 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -358,21 +358,36 @@
 ;;;; so we worry about dealing with END being supplied or defaulting
 ;;;; to NIL at this level.
 
-(defun vector-subseq* (sequence start &optional end)
+(defun string-subseq* (sequence start end)
+  (with-array-data ((data sequence)
+                    (start start)
+                    (end end)
+                    :force-inline t
+                    :check-fill-pointer t)
+    (declare (optimize (speed 3) (safety 0)))
+    (string-dispatch ((simple-array character (*))
+                      (simple-array base-char (*))
+                      (vector nil))
+        data
+        (subseq data start end))))
+
+(defun vector-subseq* (sequence start end)
   (declare (type vector sequence))
-  (declare (type index start))
-  (declare (type (or null index) end))
-  (when (null end)
-    (setf end (length sequence)))
-  (unless (<= 0 start end (length sequence))
-    (sequence-bounding-indices-bad-error sequence start end))
-  (do ((old-index start (1+ old-index))
-       (new-index 0 (1+ new-index))
-       (copy (%make-sequence-like sequence (- end start))))
-      ((= old-index end) copy)
-    (declare (fixnum old-index new-index))
-    (setf (aref copy new-index)
-          (aref sequence old-index))))
+  (declare (type index start)
+           (type (or null index) end))
+  (with-array-data ((data sequence)
+                    (start start)
+                    (end end)
+                    :check-fill-pointer t
+                    :force-inline t)
+    (let ((copy (%make-sequence-like sequence (- end start))))
+      (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))))))
 
 (defun list-subseq* (sequence start end)
   (declare (type list sequence)
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 3efefa24a..e26574747 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -805,6 +805,8 @@
                                                        'start)
                                               'result 0 'size element-type)
               result))))
+      ((csubtypep type (specifier-type 'string))
+       '(string-subseq* seq start end))
       (t
        '(vector-subseq* seq start end)))))
 
diff --git a/version.lisp-expr b/version.lisp-expr
index fb35f9616..8ae861047 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.12.11"
+"1.0.12.12"
-- 
2.11.4.GIT