From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 21 Mar 2001 05:30:53 +0000 (+0000)
Subject: Further optimize string-copying code.
X-Git-Tag: 20090517-FFI~2881
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6ef31864c91416f9c253668ae713d085d3494492;p=mit-scheme.git

Further optimize string-copying code.
---

diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index 692dc46d4..255191d10 100644
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.40 2001/03/21 05:30:07 cph Exp $
+$Id: string.scm,v 14.41 2001/03/21 05:30:53 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
 |#
 
 ;;;; Character String Operations
@@ -203,7 +204,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (declare (integrate-operator %substring))
 (define (%substring string start end)
   (let ((result (string-allocate (fix:- end start))))
-    (substring-move-left! string start end result 0)
+    (%substring-move! string start end result 0)
     result))
 
 (define (substring string start end)
@@ -257,7 +258,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (guarantee-string string 'STRING-COPY)
   (let ((size (string-length string)))
     (let ((result (string-allocate size)))
-      (substring-move-left! string 0 size result 0)
+      (%substring-move! string 0 size result 0)
       result)))
 
 (define (string-move! string1 string2 start2)
@@ -276,28 +277,56 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (if (not (fix:<= (fix:+ start2 (fix:- end1 start1)) (string-length string2)))
       (error:bad-range-argument start2 'SUBSTRING-MOVE!))
   (%substring-move! string1 start1 end1 string2 start2))
-
+
 (define (%substring-move! string1 start1 end1 string2 start2)
-  (let ((n (fix:- end1 start1)))
-    (if (fix:< n 32)
-	;; When transferring less than 32 bytes, it's faster to do
-	;; inline than to call the primitive.
-	(if (or (not (eq? string2 string1)) (fix:< start2 start1))
-	    (let loop ((i1 start1) (i2 start2))
-	      (if (fix:< i1 end1)
-		  (begin
-		    (string-set! string2 i2 (string-ref string1 i1))
-		    (loop (fix:+ i1 1) (fix:+ i2 1)))))
-	    (let loop ((i1 end1) (i2 (fix:+ start2 n)))
-	      (if (fix:> i1 start1)
-		  (let ((i1 (fix:+ i1 1))
-			(i2 (fix:+ i2 1)))
-		    (string-set! string2 i2 (string-ref string1 i1))
-		    (loop i1 i2)))))
-	(if (or (not (eq? string2 string1)) (fix:< start2 start1))
-	    (substring-move-left! string1 start1 end1 string2 start2)
-	    (substring-move-right! string1 start1 end1 string2 start2)))
-    (fix:+ start2 n)))
+  ;; Calling the primitive is expensive, so avoid it for small copies.
+  (let-syntax
+      ((unrolled-move-left
+	(lambda (n)
+	  `(BEGIN
+	     (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1))
+	     ,@(let loop ((i 1))
+		 (if (< i n)
+		     `((STRING-SET! STRING2 (FIX:+ START2 ,i)
+				    (STRING-REF STRING1 (FIX:+ START1 ,i)))
+		       ,@(loop (+ i 1))))))))
+       (unrolled-move-right
+	(lambda (n)
+	  `(BEGIN
+	     ,@(let loop ((i 1))
+		 (if (< i n)
+		     `(,@(loop (+ i 1))
+		       (STRING-SET! STRING2 (FIX:+ START2 ,i)
+				    (STRING-REF STRING1 (FIX:+ START1 ,i))))))
+	     (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1))))))
+    (let ((n (fix:- end1 start1)))
+      (if (or (not (eq? string2 string1)) (fix:< start2 start1))
+	  (cond ((fix:> n 4)
+		 (if (fix:> n 32)
+		     (substring-move-left! string1 start1 end1 string2 start2)
+		     (let loop ((i1 start1) (i2 start2))
+		       (if (fix:< i1 end1)
+			   (begin
+			     (string-set! string2 i2 (string-ref string1 i1))
+			     (loop (fix:+ i1 1) (fix:+ i2 1)))))))
+		((fix:= n 4) (unrolled-move-left 4))
+		((fix:= n 3) (unrolled-move-left 3))
+		((fix:= n 2) (unrolled-move-left 2))
+		((fix:= n 1) (unrolled-move-left 1)))
+	  (cond ((fix:> n 4)
+		 (if (fix:> n 32)
+		     (substring-move-right! string1 start1 end1 string2 start2)
+		     (let loop ((i1 end1) (i2 (fix:+ start2 n)))
+		       (if (fix:> i1 start1)
+			   (let ((i1 (fix:- i1 1))
+				 (i2 (fix:- i2 1)))
+			     (string-set! string2 i2 (string-ref string1 i1))
+			     (loop i1 i2))))))
+		((fix:= n 4) (unrolled-move-right 4))
+		((fix:= n 3) (unrolled-move-right 3))
+		((fix:= n 2) (unrolled-move-right 2))
+		((fix:= n 1) (unrolled-move-right 1))))
+      (fix:+ start2 n))))
 
 (define (string-append . strings)
   (%string-append strings))
@@ -315,7 +344,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (let loop ((strings strings) (index 0))
       (if (pair? strings)
 	  (let ((size (string-length (car strings))))
-	    (substring-move-left! (car strings) 0 size result index)
+	    (%substring-move! (car strings) 0 size result index)
 	    (loop (cdr strings) (fix:+ index size)))
 	  result))))
 
@@ -726,9 +755,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	string
 	(let ((result (string-allocate n)))
 	  (if (fix:> length n)
-	      (substring-move-left! string 0 n result 0)
+	      (%substring-move! string 0 n result 0)
 	      (begin
-		(substring-move-left! string 0 length result 0)
+		(%substring-move! string 0 length result 0)
 		(let ((char (if (default-object? char) #\space char)))
 		  (substring-fill! result length n char))))
 	  result))))
@@ -742,11 +771,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	(let ((result (string-allocate n))
 	      (i (fix:- n length)))
 	  (if (fix:< i 0)
-	      (substring-move-left! string (fix:- 0 i) length result 0)
+	      (%substring-move! string (fix:- 0 i) length result 0)
 	      (begin
 		(let ((char (if (default-object? char) #\space char)))
 		  (substring-fill! result 0 i char))
-		(substring-move-left! string 0 length result i)))
+		(%substring-move! string 0 length result i)))
 	  result))))
 
 ;;;; String Search