External string buffers for generic-i/o-ports.

Added allocate-buffer-bytes with default make-string value, to fluid
let to make-external-string when appropriate, i.e. NOT in the cold
load.  Not sure why it does not work in the cold load...

Hampered performance especially by replacing %substring-move! with
xsubstring-move!.  The former integrates unrolled loops.  Need a
%xsubstring-move! with all that, and open-coded
external-string-ref/set!.

diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm
index 61b24cf9c424be3209288c8aa60182c8741f74ca..9b82fb6f9aa328742e229aa2951c8bae70b1980c 100644 (file)
--- a/src/runtime/genio.scm
+++ b/src/runtime/genio.scm
@@ -28,7 +28,8 @@ USA.
 ;;; package: (runtime generic-i/o-port)
 
 (declare (usual-integrations)
-        (integrate-external "port"))
+        (integrate-external "port")
+        (integrate-exteranl "string"))
 \f
 (define (make-generic-i/o-port source sink #!optional type . extra-state)
   (if (not (or source sink))
@@ -717,6 +718,8 @@ USA.
   (fix:+ page-size
         (fix:- (fix:* max-char-bytes 4) 1)))
 
+(define allocate-buffer-bytes make-string)
+
 (define-structure (input-buffer (constructor %make-input-buffer))
   (source #f read-only #t)
   (bytes #f read-only #t)
@@ -730,7 +733,7 @@ USA.
 
 (define (make-input-buffer source coder-name normalizer-name)
   (%make-input-buffer source
-                     (make-string byte-buffer-length)
+                     (allocate-buffer-bytes byte-buffer-length)
                      byte-buffer-length
                      byte-buffer-length
                      byte-buffer-length
@@ -804,15 +807,15 @@ USA.
   (eq? (input-buffer-normalize ib) binary-normalizer))
 
 (define (input-buffer-contents ib)
-  (substring (input-buffer-bytes ib)
-            (input-buffer-start ib)
-            (input-buffer-end ib)))
+  (xsubstring (input-buffer-bytes ib)
+             (input-buffer-start ib)
+             (input-buffer-end ib)))
 
 (define (set-input-buffer-contents! ib contents)
   (guarantee-string contents 'SET-INPUT-BUFFER-CONTENTS!)
   (let ((bv (input-buffer-bytes ib)))
-    (let ((n (fix:min (string-length contents) (string-length bv))))
-      (substring-move! contents 0 n bv 0)
+    (let ((n (fix:min (string-length contents) (xstring-length bv))))
+      (xsubstring-move! contents 0 n bv 0)
       (set-input-buffer-prev! ib 0)
       (set-input-buffer-start! ib 0)
       (set-input-buffer-end! ib n))))
@@ -853,7 +856,7 @@ USA.
     (let ((do-read
           (lambda (be)
             (let ((be* (fix:+ be page-size)))
-              (if (not (fix:<= be* (vector-8b-length bv)))
+              (if (not (fix:<= be* (xstring-length bv)))
                   (error "Input buffer overflow:" ib))
               ((source/read (input-buffer-source ib)) bv be be*)))))
       (let ((bs (input-buffer-start ib))
@@ -861,13 +864,11 @@ USA.
        (if (fix:< bs be)
            (begin
              (if (fix:> bs 0)
-                 (do ((i bs (fix:+ i 1))
-                      (j 0 (fix:+ j 1)))
-                     ((not (fix:< i be))
-                      (set-input-buffer-prev! ib 0)
-                      (set-input-buffer-start! ib 0)
-                      (set-input-buffer-end! ib j))
-                   (string-set! bv j (string-ref bv i))))
+                 (begin
+                   (substring-move-left! bv bs be bv 0)
+                   (set-input-buffer-prev! ib 0)
+                   (set-input-buffer-start! ib 0)
+                   (set-input-buffer-end! ib (fix:- be bs))))
              (let ((be (input-buffer-end ib)))
                (let ((n (do-read be)))
                  (if n
@@ -891,7 +892,7 @@ USA.
               (if (fix:< bs be)
                   (let ((n (fix:min (fix:- be bs) (fix:- end start))))
                     (let ((be (fix:+ bs n)))
-                      (%substring-move! bv bs be string start)
+                      (xsubstring-move! bv bs be string start)
                       (set-input-buffer-prev! ib be)
                       (set-input-buffer-start! ib be)
                       n))
@@ -976,7 +977,7 @@ USA.
 
 (define (make-output-buffer sink coder-name normalizer-name)
   (%make-output-buffer sink
-                      (make-string byte-buffer-length)
+                      (allocate-buffer-bytes byte-buffer-length)
                       0
                       0
                       (name->encoder coder-name)
@@ -1006,7 +1007,7 @@ USA.
   ((sink/get-port (output-buffer-sink ob))))
 
 (define-integrable (output-buffer-end ob)
-  (string-length (output-buffer-bytes ob)))
+  (xstring-length (output-buffer-bytes ob)))
 
 (define (flush-output-buffer buffer)
   (set-output-buffer-start! buffer 0))
@@ -1033,11 +1034,9 @@ USA.
                  0
                  (fix:min bs page-size))))
            (if (and n (fix:> n 0))
-               (do ((bi n (fix:+ bi 1))
-                    (bj 0 (fix:+ bj 1)))
-                   ((not (fix:< bi bs))
-                    (set-output-buffer-start! ob bj))
-                 (vector-8b-set! bv bj (vector-8b-ref bv bi))))
+               (begin
+                 (substring-move-left! bv n bs bv 0)
+                 (set-output-buffer-start! ob (fix:- bs n))))
            n))
        0)))
 
@@ -1122,7 +1121,8 @@ USA.
 
 (define-decoder 'ISO-8859-1
   (lambda (ib)
-    (let ((cp (vector-8b-ref (input-buffer-bytes ib) (input-buffer-start ib))))
+    (let ((cp (xstring-byte-ref (input-buffer-bytes ib)
+                               (input-buffer-start ib))))
       (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1))
       cp)))
 
@@ -1130,7 +1130,7 @@ USA.
   (lambda (ob cp)
     (if (not (fix:< cp #x100))
        (error:char-encoding ob cp))
-    (vector-8b-set! (output-buffer-bytes ob) (output-buffer-start ob) cp)
+    (xstring-byte-set! (output-buffer-bytes ob) (output-buffer-start ob) cp)
     1))
 
 (define-sizer 'ISO-8859-1
@@ -1176,8 +1176,8 @@ USA.
 (define (decode-8-bit ib table)
   (let ((cp
         (vector-ref table
-                    (vector-8b-ref (input-buffer-bytes ib)
-                                   (input-buffer-start ib)))))
+                    (xstring-byte-ref (input-buffer-bytes ib)
+                                      (input-buffer-start ib)))))
     (if cp
        (begin
          (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1))
@@ -1185,20 +1185,20 @@ USA.
        (error:char-decoding ib))))
 
 (define (encode-8-bit ob cp start map-lhs map-rhs)
-  (vector-8b-set! (input-buffer-bytes ob)
-                 (input-buffer-start ob)
-                 (if (fix:< cp start)
-                     cp
-                     (let loop ((low 0) (high (vector-length map-lhs)))
-                       (if (not (fix:< low high))
-                           (error:char-encoding ob cp))
-                       (let ((i (fix:quotient (fix:+ low high) 2)))
-                         (cond ((fix:< cp (vector-ref map-lhs i))
-                                (loop low i))
-                               ((fix:> cp (vector-ref map-lhs i))
-                                (loop (fix:+ i 1) high))
-                               (else
-                                (vector-8b-ref map-rhs i)))))))
+  (xstring-byte-set! (input-buffer-bytes ob)
+                    (input-buffer-start ob)
+                    (if (fix:< cp start)
+                        cp
+                        (let loop ((low 0) (high (vector-length map-lhs)))
+                          (if (not (fix:< low high))
+                              (error:char-encoding ob cp))
+                          (let ((i (fix:quotient (fix:+ low high) 2)))
+                            (cond ((fix:< cp (vector-ref map-lhs i))
+                                   (loop low i))
+                                  ((fix:> cp (vector-ref map-lhs i))
+                                   (loop (fix:+ i 1) high))
+                                  (else
+                                   (vector-8b-ref map-rhs i)))))))
   1)
 
 (define (reverse-iso-8859-map start code-points)
@@ -1779,10 +1779,10 @@ USA.
          (else (error:char-encoding ib cp)))))
 
 (define-integrable (get-byte bv base offset)
-  (vector-8b-ref bv (fix:+ base offset)))
+  (xstring-byte-ref bv (fix:+ base offset)))
 
 (define-integrable (put-byte bv base offset byte)
-  (vector-8b-set! bv (fix:+ base offset) byte))
+  (xstring-byte-set! bv (fix:+ base offset) byte))
 
 (define-integrable (extract b m n)
   (fix:lsh (fix:and b m) n))