From 446e59e48fae5258b4d5aa855307c8795e4089d1 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 22 Jun 2011 08:09:34 -0700 Subject: [PATCH] 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!. --- src/runtime/genio.scm | 86 +++++++++++++++++++++---------------------- 1 file changed, 43 insertions(+), 43 deletions(-) diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index 61b24cf9c..9b82fb6f9 100644 --- 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")) (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)) -- 2.25.1