From: Matt Birkholz Date: Thu, 21 Jul 2011 20:34:29 +0000 (-0700) Subject: Undo genio hack: external-string buffers. X-Git-Tag: mit-scheme-pucked-9.2.12~665 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6910d4e855c5a566ccf0146577c9e92b2ecb14e9;p=mit-scheme.git Undo genio hack: external-string buffers. --- diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index 5554a9472..c4d5cf6db 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -27,8 +27,7 @@ USA. (define (open-input-gfile uri) (let* ((gfile (make-gfile uri)) (gstream (gfile-read gfile)) - (port (fluid-let ((allocate-buffer-bytes allocate-external-string)) - (make-generic-i/o-port (make-g-stream-source gstream) #f)))) + (port (make-generic-i/o-port (make-g-stream-source gstream) #f))) ;;(port/set-coding port 'ISO-8859-1) ;;(port/set-line-ending port 'NEWLINE) port)) @@ -59,8 +58,7 @@ USA. (define (open-output-gfile uri) (let* ((gfile (make-gfile uri)) (gstream (gfile-replace gfile #f #t 'private)) - (port (fluid-let ((allocate-buffer-bytes allocate-external-string)) - (make-generic-i/o-port #f (make-g-stream-sink gstream))))) + (port (make-generic-i/o-port #f (make-g-stream-sink gstream)))) ;;(port/set-coding port 'ISO-8859-1) ;;(port/set-line-ending port 'NEWLINE) port)) @@ -94,7 +92,15 @@ USA. define standard initial-value 10) (queue - define accessor initializer (lambda () (make-thread-queue 1)))) + define accessor initializer (lambda () (make-thread-queue 1))) + + (buffer + define standard initializer (lambda () (malloc buffer-size 'uchar))) + + (buffer-size + define standard initializer (lambda () buffer-size))) + +(define buffer-size #x1000) ;;; When these streams are GCed, any pending operation must be ;;; cancelled. This ensures that the operation's finish callback will @@ -127,8 +133,9 @@ USA. ;; To avoid registering read or skip finish callbacks for every read ;; or skip (a LOT of registering/deregistering!), the open operation ;; (i.e. gfile-read) registers them in advance. - read-id - skip-id) + read-id ; #f or the read finish callback ID + skip-id ; #f or the skip finish callback ID + ) (define-method initialize-instance ((object )) (call-next-method object) @@ -186,8 +193,7 @@ USA. (if (g-input-stream-cancel-info-pending-op info) (error "Operation pending:" gstream)) (let* ((count (fix:- end start)) - (async-buffer (alien-byte-increment! (external-string->alien buffer) - start))) + (async-buffer (ensure-buffer gstream count))) (set-g-input-stream-cancel-info-pending-op! info 'READ) (C-call "g_input_stream_read_async" (gobject-alien gstream) @@ -204,9 +210,22 @@ USA. (set-g-input-stream-cancel-info-pending-op! info 'ERROR) (error "Error reading:" gstream value)) (begin + (c-peek-bytes async-buffer 0 value buffer start) (set-g-input-stream-cancel-info-pending-op! info #f) value)))))) +(define-integrable (ensure-buffer gstream count) + (let ((size (g-stream-buffer-size gstream)) + (buffer (g-stream-buffer gstream))) + (if (fix:< size count) + (begin + (free buffer) + (let ((buffer* (malloc count 'uchar))) + (set-g-stream-buffer! gstream buffer*) + (set-g-stream-buffer-size! gstream count) + buffer*)) + buffer))) + (define (make-g-input-stream-read-finish-callback queue gerror*) (C-callback (named-lambda (g-input-stream-read-finish-callback source result) @@ -372,9 +391,9 @@ USA. (if (g-output-stream-cancel-info-pending-op info) (error "Operation pending:" gstream)) (let* ((count (fix:- end start)) - (async-buffer (alien-byte-increment! (external-string->alien buffer) - start))) + (async-buffer (ensure-buffer gstream count))) (set-g-output-stream-cancel-info-pending-op! info 'WRITE) + (c-poke-bytes async-buffer 0 count buffer start) (C-call "g_output_stream_write_async" (gobject-alien gstream) async-buffer @@ -661,11 +680,6 @@ USA. (begin (%trace ";g-output-stream-"op"-callback "alien" "queue"\n") (%queue! queue alien)))) - -(define-integrable (external-string->alien xstr) - (let ((alien (make-alien 'uchar))) - (%set-alien/address! alien (external-string-descriptor xstr)) - alien)) (define-class ( (constructor (uri))) () diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 2aeb837f0..90b9e98ee 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -64,8 +64,7 @@ USA. %set-alien/address!) (import (runtime generic-i/o-port) make-gsource - make-gsink - allocate-buffer-bytes) + make-gsink) (import (gtk main) maybe-yield-gtk) (export (gtk) diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index aabcba4d8..6a3b6cfa4 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -28,7 +28,7 @@ USA. ;;; package: (runtime generic-i/o-port) (declare (usual-integrations) - (integrate-external "port" "string")) + (integrate-external "port")) (define (make-generic-i/o-port source sink #!optional type . extra-state) (if (not (or source sink)) @@ -719,8 +719,6 @@ 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) @@ -734,7 +732,7 @@ USA. (define (make-input-buffer source coder-name normalizer-name) (%make-input-buffer source - (allocate-buffer-bytes byte-buffer-length) + (make-string byte-buffer-length) byte-buffer-length byte-buffer-length byte-buffer-length @@ -809,15 +807,15 @@ USA. (eq? (input-buffer-normalize ib) binary-normalizer)) (define (input-buffer-contents ib) - (xsubstring (input-buffer-bytes ib) - (input-buffer-start ib) - (input-buffer-end ib))) + (substring (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) (xstring-length bv)))) - (xsubstring-move! contents 0 n bv 0) + (let ((n (fix:min (string-length contents) (string-length bv)))) + (substring-move! contents 0 n bv 0) (set-input-buffer-prev! ib 0) (set-input-buffer-start! ib 0) (set-input-buffer-end! ib n)))) @@ -858,7 +856,7 @@ USA. (let ((do-read (lambda (be) (let ((be* (fix:+ be page-size))) - (if (not (fix:<= be* (xstring-length bv))) + (if (not (fix:<= be* (vector-8b-length bv))) (error "Input buffer overflow:" ib)) ((source/read (input-buffer-source ib)) bv be be*))))) (let ((bs (input-buffer-start ib)) @@ -866,11 +864,13 @@ USA. (if (fix:< bs be) (begin (if (fix:> bs 0) - (begin - (xsubstring-move! 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)))) + (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)))) (let ((be (input-buffer-end ib))) (let ((n (do-read be))) (if n @@ -894,7 +894,7 @@ USA. (if (fix:< bs be) (let ((n (fix:min (fix:- be bs) (fix:- end start)))) (let ((be (fix:+ bs n))) - (xsubstring-move! bv bs be string start) + (%substring-move! bv bs be string start) (set-input-buffer-prev! ib be) (set-input-buffer-start! ib be) n)) @@ -979,7 +979,7 @@ USA. (define (make-output-buffer sink coder-name normalizer-name) (%make-output-buffer sink - (allocate-buffer-bytes byte-buffer-length) + (make-string byte-buffer-length) 0 0 (name->encoder coder-name) @@ -1010,7 +1010,7 @@ USA. ((sink/get-port (output-buffer-sink ob)))) (define-integrable (output-buffer-end ob) - (xstring-length (output-buffer-bytes ob))) + (string-length (output-buffer-bytes ob))) (define (flush-output-buffer buffer) (set-output-buffer-start! buffer 0)) @@ -1037,9 +1037,11 @@ USA. 0 (fix:min bs page-size)))) (if (and n (fix:> n 0)) - (begin - (xsubstring-move! bv n bs bv 0) - (set-output-buffer-start! ob (fix:- bs n)))) + (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)))) n)) 0))) @@ -1124,8 +1126,7 @@ USA. (define-decoder 'ISO-8859-1 (lambda (ib) - (let ((cp (xstring-byte-ref (input-buffer-bytes ib) - (input-buffer-start ib)))) + (let ((cp (vector-8b-ref (input-buffer-bytes ib) (input-buffer-start ib)))) (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1)) cp))) @@ -1133,7 +1134,7 @@ USA. (lambda (ob cp) (if (not (fix:< cp #x100)) (error:char-encoding ob cp)) - (xstring-byte-set! (output-buffer-bytes ob) (output-buffer-start ob) cp) + (vector-8b-set! (output-buffer-bytes ob) (output-buffer-start ob) cp) 1)) (define-sizer 'ISO-8859-1 @@ -1179,8 +1180,8 @@ USA. (define (decode-8-bit ib table) (let ((cp (vector-ref table - (xstring-byte-ref (input-buffer-bytes ib) - (input-buffer-start ib))))) + (vector-8b-ref (input-buffer-bytes ib) + (input-buffer-start ib))))) (if cp (begin (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1)) @@ -1188,20 +1189,20 @@ USA. (error:char-decoding ib)))) (define (encode-8-bit ob cp start map-lhs map-rhs) - (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))))))) + (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))))))) 1) (define (reverse-iso-8859-map start code-points) @@ -1782,10 +1783,10 @@ USA. (else (error:char-encoding ib cp))))) (define-integrable (get-byte bv base offset) - (xstring-byte-ref bv (fix:+ base offset))) + (vector-8b-ref bv (fix:+ base offset))) (define-integrable (put-byte bv base offset byte) - (xstring-byte-set! bv (fix:+ base offset) byte)) + (vector-8b-set! bv (fix:+ base offset) byte)) (define-integrable (extract b m n) (fix:lsh (fix:and b m) n))