From: Matt Birkholz Date: Sun, 17 Jul 2011 18:45:38 +0000 (-0700) Subject: Added g-output-streams, gc-cleanups, and a performance test. X-Git-Tag: mit-scheme-pucked-9.2.12~682 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=19fdd0a70473d52d99d6f4f2ea652eab7cfef55a;p=mit-scheme.git Added g-output-streams, gc-cleanups, and a performance test. --- diff --git a/src/gtk/Includes/gio/gfile.cdecl b/src/gtk/Includes/gio/gfile.cdecl index 8cdc9e090..a2b415b3e 100644 --- a/src/gtk/Includes/gio/gfile.cdecl +++ b/src/gtk/Includes/gio/gfile.cdecl @@ -20,6 +20,53 @@ glib-2.0/gio/gfile.h |# (res (* GAsyncResult)) (error (* (* GError)))) +(extern void + g_file_append_to_async + (file (* GFile)) + (flags GFileCreateFlags) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern (* GFileOutputStream) + g_file_append_to_finish + (file (* GFile)) + (res (* GAsyncResult)) + (error (* (* GError)))) + +(extern void + g_file_create_async + (file (* GFile)) + (flags GFileCreateFlags) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern (* GFileOutputStream) + g_file_create_finish + (file (* GFile)) + (res (* GAsyncResult)) + (error (* (* GError)))) + +(extern void + g_file_replace_async + (file (* GFile)) + (etag (* (const char))) + (make_backup gboolean) + (flags GFileCreateFlags) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern (* GFileOutputStream) + g_file_replace_finish + (file (* GFile)) + (res (* GAsyncResult)) + (error (* (* GError)))) + (extern void g_file_open_readwrite_async (file (* GFile)) diff --git a/src/gtk/Includes/gio/ginputstream.cdecl b/src/gtk/Includes/gio/ginputstream.cdecl index 1c69ed58d..f18e165b2 100644 --- a/src/gtk/Includes/gio/ginputstream.cdecl +++ b/src/gtk/Includes/gio/ginputstream.cdecl @@ -3,23 +3,24 @@ glib-2.0/gio/ginputstream.h |# (extern void - g_input_stream_close_async + g_input_stream_read_async (stream (* GInputStream)) + (buffer (* void)) + (count gsize) (io_priority int) (cancellable (* GCancellable)) - (callback GAsyncReadyCallback) - (user_data gpointer)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) -(extern gboolean - g_input_stream_close_finish +(extern gssize + g_input_stream_read_finish (stream (* GInputStream)) (result (* GAsyncResult)) (error (* (* GError)))) (extern void - g_input_stream_read_async + g_input_stream_skip_async (stream (* GInputStream)) - (buffer (* void)) (count gsize) (io_priority int) (cancellable (* GCancellable)) @@ -27,7 +28,21 @@ glib-2.0/gio/ginputstream.h |# (ID gpointer)) (extern gssize - g_input_stream_read_finish + g_input_stream_skip_finish + (stream (* GInputStream)) + (result (* GAsyncResult)) + (error (* (* GError)))) + +(extern void + g_input_stream_close_async + (stream (* GInputStream)) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern gboolean + g_input_stream_close_finish (stream (* GInputStream)) (result (* GAsyncResult)) (error (* (* GError)))) \ No newline at end of file diff --git a/src/gtk/Includes/gio/gio.cdecl b/src/gtk/Includes/gio/gio.cdecl index a4b1b4a77..e286396ed 100644 --- a/src/gtk/Includes/gio/gio.cdecl +++ b/src/gtk/Includes/gio/gio.cdecl @@ -55,7 +55,7 @@ glib-2.0/gio/gio.h |# ;(include "ginetsocketaddress") ;(include "ginitable") (include "ginputstream") -;(include "gioenums") +(include "gioenums") ;(include "gioenumtypes") ;(include "gioerror") ;(include "giomodule") @@ -69,7 +69,7 @@ glib-2.0/gio/gio.h |# ;(include "gnativevolumemonitor") ;(include "gnetworkaddress") ;(include "gnetworkservice") -;(include "goutputstream") +(include "goutputstream") ;(include "gpermission") ;(include "gpollableinputstream") ;(include "gpollableoutputstream") diff --git a/src/gtk/Includes/gio/gioenums.cdecl b/src/gtk/Includes/gio/gioenums.cdecl new file mode 100644 index 000000000..9efdb7f1d --- /dev/null +++ b/src/gtk/Includes/gio/gioenums.cdecl @@ -0,0 +1,11 @@ +#| -*-Scheme-*- + +glib-2.0/gio/gioenums.h |# + +(include "../glib-object") + +(typedef GFileCreateFlags + (enum + (G_FILE_CREATE_NONE) + (G_FILE_CREATE_PRIVATE) + (G_FILE_CREATE_REPLACE_DESTINATION))) \ No newline at end of file diff --git a/src/gtk/Includes/gio/goutputstream.cdecl b/src/gtk/Includes/gio/goutputstream.cdecl new file mode 100644 index 000000000..5030e1bf6 --- /dev/null +++ b/src/gtk/Includes/gio/goutputstream.cdecl @@ -0,0 +1,47 @@ +#| -*-Scheme-*- + +glib-2.0/gio/goutputstream.h |# + +(extern void + g_output_stream_write_async + (stream (* GOutputStream)) + (buffer (* (const void))) + (count gsize) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern gssize + g_output_stream_write_finish + (stream (* GOutputStream)) + (result (* GAsyncResult)) + (error (* (* GError)))) + +(extern void + g_output_stream_flush_async + (stream (* GOutputStream)) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern gboolean + g_output_stream_flush_finish + (stream (* GOutputStream)) + (result (* GAsyncResult)) + (error (* (* GError)))) + +(extern void + g_output_stream_close_async + (stream (* GOutputStream)) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern gboolean + g_output_stream_close_finish + (stream (* GOutputStream)) + (result (* GAsyncResult)) + (error (* (* GError)))) \ No newline at end of file diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index ffd48ab36..74aeffc02 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -22,124 +22,636 @@ USA. |# ;;;; GIO Ports -;;; package: (glib gio) +;;; package: (gtk gio) (define (open-input-gfile uri) - (let* ((gfile (->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-gstream-source gstream) #f)))) - (gobject-unref! gfile) + (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)) -#;(define (open-i/o-gfile uri) - (let* ((gfile (->gfile uri)) - (gstream (gfile-open-readwrite gfile)) - (port (make-generic-i/o-port (make-gstream-source gstream) - (make-gstream-sink gstream)))) - (gobject-unref! gfile) +(define (make-g-stream-source gstream) + ;; Not unlike make-non-channel-port-source in genio.scm. + (let ((port #f) + (open? #t)) + (make-gsource + (named-lambda (g-stream-source/get-channel) + #f) + (named-lambda (g-stream-source/get-port) + port) + (named-lambda (g-stream-source/set-port port*) + (set! port port*)) + (named-lambda (g-stream-source/open?) + open?) + (named-lambda (g-stream-source/close) + (if open? + (let ((value (g-input-stream-close gstream))) + (set! open? #f) + value))) + (named-lambda (g-stream-source/has-bytes?) + #t) + (named-lambda (g-stream-source/read-bytes buffer start end) + (g-input-stream-read gstream buffer start end))))) + +(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/set-coding port 'ISO-8859-1) ;;(port/set-line-ending port 'NEWLINE) port)) -(define (make-gstream-source gstream) - ;; Not unlike make-non-channel-port-source in genio.scm. +(define (make-g-stream-sink gstream) + ;; Not unlike make-non-channel-port-sink in genio.scm. (let ((port #f) (open? #t)) - (make-gsource - (named-lambda (gstream-source/get-channel) + (make-gsink + (named-lambda (g-stream-sink/get-channel) #f) - (named-lambda (gstream-source/get-port) + (named-lambda (g-stream-sink/get-port) port) - (named-lambda (gstream-source/set-port port*) + (named-lambda (g-stream-sink/set-port port*) (set! port port*)) - (named-lambda (gstream-source/open?) + (named-lambda (g-stream-sink/open?) open?) - (named-lambda (gstream-source/close) + (named-lambda (g-stream-sink/close) (if open? - (let ((value (gstream-input-close gstream))) + (let ((value (g-output-stream-close gstream))) (set! open? #f) value))) - (named-lambda (gstream-source/has-bytes?) - #t) - (named-lambda (gstream-source/read-bytes buffer start end) - (gstream-read gstream buffer start end))))) + (named-lambda (g-stream-sink/write-bytes buffer start end) + (g-output-stream-write gstream buffer start end))))) + +(define-class + ;; Abstract -- slots common to s and s. + () + + (io-priority + define standard initial-value 10) + + (queue + define accessor initializer (lambda () (make-thread-queue 1)))) + +;;; When these streams are GCed, any pending operation must be +;;; cancelled. This ensures that the operation's finish callback will +;;; not be called and can be safely de-registered. The cancel-info +;;; includes the GCancellable, the finish callback ids, AND a flag to +;;; indicate whether an operation is pending and thus whether the +;;; GCancellable should be used. + +;;; The subclasses' cancel-info is separated from the so +;;; that the latter can be GCed while the -info stays with a +;;; gc-cleanup thunk. + +(define-class ( (constructor ())) + () + (cancel-info + define accessor + initializer (lambda () + (make-g-input-stream-cancel-info + #f #f (make-gcancellable) #f #f)))) + +(define-structure g-input-stream-cancel-info + pending-op ; #f, OPEN, READ, SKIP, CLOSE or ERROR. + callback-id ; #f or the open/close finish callback ID + gcancellable ; a GCancellable alien + + ;; 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 ; #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) + (add-gc-cleanup object + (make-g-input-stream-cleanup + (g-input-stream-cancel-info object)))) + +(define (make-g-input-stream-cleanup info) + (named-lambda (g-input-stream-cleanup) + (let ((pending-op (g-input-stream-cancel-info-pending-op info)) + (gcancellable (g-input-stream-cancel-info-gcancellable info))) + (if (and pending-op (not (eq? pending-op 'ERROR))) + (C-call "g_cancellable_cancel" gcancellable)) + (cleanup-g-input-stream info)))) + +(define-syntax cleanup-callback-id + (sc-macro-transformer + (lambda (form environment) + (if (syntax-match? '(IDENTIFIER SYMBOL SYMBOL) (cdr form)) + (let ((info (close-syntax (cadr form) environment)) + (i/o (caddr form)) + (slot (cadddr form))) + (let ((accessor (symbol ' G- i/o '-STREAM-CANCEL-INFO- slot)) + (modifier (symbol 'SET-G- i/o '-STREAM-CANCEL-INFO- slot '!))) + `(LET ((ID (,accessor ,info))) + (IF ID + (BEGIN + (DE-REGISTER-C-CALLBACK ID) + (,modifier ,info #F)))))))))) + +(define (cleanup-g-input-stream info) + ;; For gc-cleanup. Run without-interrupts. + (cleanup-callback-id info input callback-id) + (cleanup-callback-id info input read-id) + (cleanup-callback-id info input skip-id) + (gobject-unref! (g-input-stream-cancel-info-gcancellable info))) + +(define (g-input-stream-read gstream buffer start end) + (let* ((info (g-input-stream-cancel-info gstream)) + (callback-id (g-input-stream-cancel-info-read-id info))) + (if (not callback-id) (error "Not open:" gstream)) + (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))) + (set-g-input-stream-cancel-info-pending-op! info 'READ) + (C-call "g_input_stream_read_async" + (gobject-alien gstream) + async-buffer + count + (g-stream-io-priority gstream) + (gobject-alien (g-input-stream-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let* ((queue (g-stream-queue gstream)) + (value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-g-input-stream-cancel-info-pending-op! info 'ERROR) + (error "Error reading:" gstream value)) + (begin + (set-g-input-stream-cancel-info-pending-op! info #f) + value)))))) + +(define (make-g-input-stream-read-finish-callback queue) + (C-callback + (named-lambda (g-input-stream-read-finish-callback source result) + (if-gerror + (lambda (gerror) + (C-call "g_input_stream_read_finish" source result gerror)) + (lambda (message) + (%trace ";g-input-stream-read-finish-callback "message" "queue"\n") + (%queue! queue message)) + (lambda (value) + (%trace ";g-input-stream-read-finish-callback "value" "queue"\n") + (%queue! queue value)))))) + +(define-integrable (%queue! queue value) + ;; The GIO finish callbacks use this procedure to queue a value on a + ;; g-stream's queue AND signal the main loop if Scheme has become + ;; runnable. + (thread-queue/queue! queue value) + (maybe-yield-gtk)) + +(define (g-input-stream-skip gstream count) + (let* ((info (g-input-stream-cancel-info gstream)) + (callback-id (g-input-stream-cancel-info-skip-id info))) + (if (not callback-id) (error "Not open:" gstream)) + (if (g-input-stream-cancel-info-pending-op info) + (error "Operation pending:" gstream)) + (set-g-input-stream-cancel-info-pending-op! info 'SKIP) + (C-call "g_input_stream_skip_async" + (gobject-alien gstream) + count + (g-stream-io-priority gstream) + (gobject-alien (g-input-stream-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let* ((queue (g-stream-queue gstream)) + (value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-g-input-stream-cancel-info-pending-op! info 'ERROR) + (error "Error reading:" gstream value)) + (begin + (set-g-input-stream-cancel-info-pending-op! info #f) + value))))) + +(define (make-g-input-stream-skip-finish-callback queue) + (C-callback + (named-lambda (g-input-stream-skip-finish-callback source result) + (if-gerror + (lambda (gerror) + (C-call "g_input_stream_skip_finish" source result gerror)) + (lambda (message) + (%trace ";g-input-stream-skip-finish-callback "message" "queue"\n") + (%queue! queue message)) + (lambda (value) + (%trace ";g-input-stream-skip-finish-callback "value" "queue"\n") + (%queue! queue value)))))) + +(define (g-input-stream-close gstream) + (let* ((info (g-input-stream-cancel-info gstream)) + (queue (g-stream-queue gstream)) + (read-id (g-input-stream-cancel-info-read-id info))) + (if (not read-id) (error "Not open:" gstream)) + (if (g-input-stream-cancel-info-pending-op info) (error "Operation pending:" gstream)) + (let ((callback-id + (without-interrupts ;don't leak callback IDs + (lambda () + (let ((id (make-g-input-stream-close-finish-callback queue))) + (set-g-input-stream-cancel-info-pending-op! info 'CLOSE) + (set-g-input-stream-cancel-info-callback-id! info id) + id))))) + (C-call "g_input_stream_close_async" + (gobject-alien gstream) + (g-stream-io-priority gstream) + (gobject-alien (g-input-stream-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let ((value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-g-input-stream-cancel-info-pending-op! info 'ERROR) + (error "Error in g-input-stream-close:" gstream value)) + (begin + (set-g-input-stream-cancel-info-pending-op! info #f) + (without-interrupts + (lambda () + (cleanup-g-input-stream info))) + value)))))) + +(define (make-g-input-stream-close-finish-callback queue) + (C-callback + (named-lambda (g-input-stream-close-finish-callback source result) + (if-gerror + (lambda (gerror) + (C-call "g_input_stream_close_finish" source result gerror)) + (lambda (message) + (%trace ";g-input-stream-close-finish-callback "message" "queue"\n") + (%queue! queue message)) + (lambda (value) + (%trace ";g-input-stream-close-finish-callback "value" "queue"\n") + (%queue! queue #t)))))) + +(define-class ( (constructor ())) + () + (cancel-info + define accessor + initializer (lambda () + (make-g-output-stream-cancel-info + #f #f (make-gcancellable) #f #f)))) + +(define-structure g-output-stream-cancel-info + pending-op ; #f, OPEN, WRITE, FLUSH, CLOSE or ERROR. + callback-id ; #f or the open/close finish callback ID + gcancellable ; a GCancellable alien + + ;; To avoid registering write or flush finish callbacks for every + ;; write or flush (a LOT of registering/deregistering!), the open + ;; operation (i.e. gfile-write) registers them in advance. + write-id ; #f or the write finish callback ID + flush-id ; #f or the flush finish callback ID + ) + +(define-method initialize-instance ((object )) + (call-next-method object) + (add-gc-cleanup object + (make-g-output-stream-cleanup + (g-output-stream-cancel-info object)))) + +(define (make-g-output-stream-cleanup info) + (named-lambda (g-output-stream-cleanup) + (let ((pending-op (g-output-stream-cancel-info-pending-op info)) + (gcancellable (g-output-stream-cancel-info-gcancellable info))) + (if (and pending-op (not (eq? pending-op 'ERROR))) + (C-call "g_cancellable_cancel" gcancellable)) + (cleanup-g-output-stream info)))) + +(define (cleanup-g-output-stream info) + ;; For gc-cleanup. Run without-interrupts. + (cleanup-callback-id info output callback-id) + (cleanup-callback-id info output write-id) + (cleanup-callback-id info output flush-id) + (gobject-unref! (g-output-stream-cancel-info-gcancellable info))) + +(define (g-output-stream-write gstream buffer start end) + (let* ((info (g-output-stream-cancel-info gstream)) + (callback-id (g-output-stream-cancel-info-write-id info))) + (if (not callback-id) (error "Not open:" gstream)) + (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))) + (set-g-output-stream-cancel-info-pending-op! info 'WRITE) + (C-call "g_output_stream_write_async" + (gobject-alien gstream) + async-buffer + count + (g-stream-io-priority gstream) + (gobject-alien (g-output-stream-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let* ((queue (g-stream-queue gstream)) + (value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-g-output-stream-cancel-info-pending-op! info 'ERROR) + (error "Error writing:" gstream value)) + (begin + (set-g-input-stream-cancel-info-pending-op! info #f) + value)))))) + +(define (make-g-output-stream-write-finish-callback queue) + (C-callback + (named-lambda (g-output-stream-write-finish-callback source result) + (if-gerror + (lambda (gerror) + (C-call "g_output_stream_write_finish" source result gerror)) + (lambda (message) + (%trace ";g-output-stream-write-finish-callback "message" "queue"\n") + (%queue! queue message)) + (lambda (value) + (%trace ";g-output-stream-write-finish-callback "value" "queue"\n") + (%queue! queue value)))))) -(define (gstream-input-close gstream) - (let ((io-priority 10) - (q (make-thread-queue 1))) - (C-call "g_input_stream_close_async" +(define (g-output-stream-flush gstream) + (let* ((info (g-output-stream-cancel-info gstream)) + (callback-id (g-output-stream-cancel-info-write-id info))) + (if (not callback-id) (error "Not open:" gstream)) + (if (g-output-stream-cancel-info-pending-op info) + (error "Operation pending:" gstream)) + (set-g-output-stream-cancel-info-pending-op! info 'WRITE) + (C-call "g_output_stream_flush_async" (gobject-alien gstream) - io-priority 0 + (g-stream-io-priority gstream) + (gobject-alien (g-output-stream-cancel-info-gcancellable info)) (C-callback "async_ready") - (C-callback - (named-lambda (gstream-input-close-finish source result) - (if (not (alien=? source (gobject-alien gstream))) (warn "Unexpected source in async_ready:" source gstream)) - (if-gerror - (lambda (gerr) - (C-call "g_input_stream_close_finish" source result gerr)) - (lambda (message) - (thread-queue/queue! q message)) - (lambda (value) - (thread-queue/queue! q value)))))) - (let ((value (thread-queue/dequeue! q))) - (gobject-unref! gstream) - (if (string? value) (error value)) - (not (zero? value))))) - -(define (gstream-read gstream external-string start end) - (let ((io-priority 10) - ;;(gcancel (make-gcancellable)) - (buffer (alien-byte-increment! (external-string->alien external-string) - start)) - (count (- end start)) - (q (make-thread-queue 1))) - (C-call "g_input_stream_read_async" - (gobject-alien gstream) buffer count - io-priority 0 ;;(gobject-alien gcancel) + callback-id) + (let* ((queue (g-stream-queue gstream)) + (value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-g-output-stream-cancel-info-pending-op! info 'ERROR) + (error "Error writing:" gstream value)) + (begin + (set-g-input-stream-cancel-info-pending-op! info #f) + (not (fix:zero? value))))))) + +(define (make-g-output-stream-flush-finish-callback queue) + (C-callback + (named-lambda (g-output-stream-flush-finish-callback source result) + (if-gerror + (lambda (gerror) + (C-call "g_output_stream_flush_finish" source result gerror)) + (lambda (message) + (%trace ";g-output-stream-flush-finish-callback "message" "queue"\n") + (%queue! queue message)) + (lambda (value) + (%trace ";g-output-stream-flush-finish-callback "value" "queue"\n") + (%queue! queue value)))))) + +(define (g-output-stream-close gstream) + (let* ((info (g-output-stream-cancel-info gstream)) + (queue (g-stream-queue gstream)) + (write-id (g-output-stream-cancel-info-write-id info))) + (if (not write-id) (error "Not open:" gstream)) + (if (g-output-stream-cancel-info-pending-op info) + (error "Operation pending:" gstream)) + (let ((callback-id + (without-interrupts ;don't leak callback IDs + (lambda () + (let ((id (make-g-output-stream-close-finish-callback queue))) + (set-g-output-stream-cancel-info-pending-op! info 'CLOSE) + (set-g-output-stream-cancel-info-callback-id! info id) + id))))) + (C-call "g_output_stream_close_async" + (gobject-alien gstream) + (g-stream-io-priority gstream) + (gobject-alien (g-output-stream-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let ((value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-g-output-stream-cancel-info-pending-op! info 'ERROR) + (error "Error in g-output-stream-close:" gstream value)) + (begin + (set-g-output-stream-cancel-info-pending-op! info #f) + (without-interrupts + (lambda () + (cleanup-g-output-stream info))) + value)))))) + +(define (make-g-output-stream-close-finish-callback queue) + (C-callback + (named-lambda (g-output-stream-close-finish-callback source result) + (if-gerror + (lambda (gerror) + (C-call "g_output_stream_close_finish" source result gerror)) + (lambda (message) + (%trace ";g-output-stream-close-finish-callback "message" "queue"\n") + (%queue! queue message)) + (lambda (value) + (%trace ";g-output-stream-close-finish-callback "value" "queue"\n") + (%queue! queue #t)))))) + +(define-class + ()) + +(define-method initialize-instance ((gstream )) + (call-next-method gstream) + (let ((alien (gobject-alien gstream))) + (set-alien/ctype! alien '|GFileInputStream|))) + +(define (gfile-read gfile) + (let* ((gstream (make-g-input-stream)) + (info (g-input-stream-cancel-info gstream)) + (queue (g-stream-queue gstream)) + (callback-id + (without-interrupts ;don't leak callback IDs + (lambda () + (let* ((alien (gobject-alien gstream)) + (id (make-gfile-read-finish-callback alien queue))) + (set-g-input-stream-cancel-info-pending-op! info 'OPEN) + (set-g-input-stream-cancel-info-callback-id! info id) + id))))) + (C-call "g_file_read_async" + (gobject-alien gfile) + (g-stream-io-priority gstream) + (gobject-alien (g-input-stream-cancel-info-gcancellable info)) (C-callback "async_ready") - (C-callback - (named-lambda (gstream-read-finish source result) - (if (not (alien=? source (gobject-alien gstream))) (warn "Unexpected source in async_ready:" source gstream)) - (if-gerror - (lambda (gerr) - (C-call "g_input_stream_read_finish" source result gerr)) - (lambda (message) - (thread-queue/queue! q message)) - (lambda (value) - (thread-queue/queue! q value)))))) - (let ((value (thread-queue/dequeue! q))) - ;; (gobject-unref! gcancel) - (if (string? value) (error value)) - value))) - -(define (external-string->alien string) - (if (not (external-string? string)) - (error:wrong-type-argument string "an external string" 'EXTERNAL-STRING->ALIEN)) - (let ((a (make-alien '|char|))) - (%set-alien/address! a (external-string-descriptor string)) - a)) - -(define-class ( (constructor () (uri))) + callback-id) + (let ((value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-g-input-stream-cancel-info-pending-op! info 'ERROR) + (error "Error in gfile-read:" gfile value)) + (begin + (set-g-input-stream-cancel-info-pending-op! info #f) + (without-interrupts + (lambda () + (de-register-c-callback callback-id) + (set-g-input-stream-cancel-info-callback-id! info #f) + (set-g-input-stream-cancel-info-read-id! + info (make-g-input-stream-read-finish-callback queue)) + (set-g-input-stream-cancel-info-skip-id! + info (make-g-input-stream-skip-finish-callback queue)))) + gstream))))) + +(define (make-gfile-read-finish-callback alien queue) + (C-callback + (named-lambda (gfile-read-finish-callback source result) + (if-gerror + (lambda (gerror) + (C-call "g_file_read_finish" alien source result gerror)) + (lambda (message) ;failure + (%trace ";g-file-read-finish-callback "message" "queue"\n") + (%queue! queue message)) + (lambda (value) ;success + (%trace ";g-file-read-finish-callback "value" "queue"\n") + (%queue! queue value)))))) + +(define-class + ()) + +(define-method initialize-instance ((gstream )) + (call-next-method gstream) + (let ((alien (gobject-alien gstream))) + (set-alien/ctype! alien '|GFileOutputStream|))) + +(define (gfile-append-to gfile . flags) + (let ((flags* (->gfile-create-flags flags))) + (gfile-open gfile + (lambda (gfile priority gcancellable callback id) + (C-call "g_file_append_to_async" + gfile flags* + priority gcancellable callback id)) + make-gfile-append-to-finish-callback))) + +(define (->gfile-create-flags flags) + (reduce-left fix:or 0 (map ->gfile-create-flag flags))) + +(define (->gfile-create-flag flag) + (case flag + ((PRIVATE) (C-enum "G_FILE_CREATE_PRIVATE")) + ((REPLACE) (C-enum "G_FILE_CREATE_REPLACE_DESTINATION")) + (else (error:wrong-type-argument flag "GFile create flag" + '->GFILE-CREATE-FLAG)))) + +(define (make-gfile-append-to-finish-callback alien queue) + (C-callback + (named-lambda (gfile-append-to-finish-callback source result) + (g-output-stream-callback queue 'append-to + (lambda (gerror) + (C-call "g_file_append_to_finish" + alien source result gerror)))))) + +(define (gfile-create gfile . flags) + (let ((flags* (->gfile-create-flags flags))) + (gfile-open gfile + (lambda (gfile priority gcancellable callback id) + (C-call "g_file_create_async" + gfile flags* + priority gcancellable callback id)) + make-gfile-create-finish-callback))) + +(define (make-gfile-create-finish-callback alien queue) + (C-callback + (named-lambda (gfile-create-finish-callback source result) + (g-output-stream-callback queue 'create + (lambda (gerror) + (C-call "g_file_create_finish" + alien source result gerror)))))) + +(define (gfile-replace gfile etag backup? . flags) + (let ((etag (->gfile-etag etag)) + (make-backups (if backup? 1 0)) + (flags* (->gfile-create-flags flags))) + (gfile-open gfile + (lambda (gfile priority gcancellable callback id) + (C-call "g_file_replace_async" + gfile etag make-backups flags* + priority gcancellable callback id)) + make-gfile-replace-finish-callback))) + +(define-integrable (->gfile-etag etag) + (cond ((and (alien? etag) (eq? (alien/ctype etag) '|GFile etag|)) + etag) + ((or (eq? etag #f) (zero? etag)) + 0) + (else + (error:wrong-type-argument etag "GFile etag" '->GFILE-ETAG)))) + +(define (make-gfile-replace-finish-callback alien queue) + (C-callback + (named-lambda (gfile-replace-finish-callback source result) + (g-output-stream-callback queue 'replace + (lambda (gerror) + (C-call "g_file_replace_finish" + alien source result gerror)))))) + +(define-integrable (gfile-open gfile callout make-callback) + (let* ((gstream (make-g-output-stream)) + (info (g-output-stream-cancel-info gstream)) + (queue (g-stream-queue gstream)) + (callback-id + (without-interrupts ;don't leak callback IDs + (lambda () + (let* ((alien (gobject-alien gstream)) + (id (make-callback alien queue))) + (set-g-output-stream-cancel-info-pending-op! info 'OPEN) + (set-g-output-stream-cancel-info-callback-id! info id) + id))))) + (callout (gobject-alien gfile) + (g-stream-io-priority gstream) + (gobject-alien (g-output-stream-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let ((value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-g-output-stream-cancel-info-pending-op! info 'ERROR) + (error value gfile)) + (begin + (set-g-output-stream-cancel-info-pending-op! info #f) + (without-interrupts + (lambda () + (de-register-c-callback callback-id) + (set-g-output-stream-cancel-info-callback-id! info #f) + (set-g-output-stream-cancel-info-write-id! + info (make-g-output-stream-write-finish-callback queue)) + (set-g-output-stream-cancel-info-flush-id! + info (make-g-output-stream-flush-finish-callback queue)))) + gstream))))) + +(define-integrable (g-output-stream-callback queue op callback) + (if-gerror + callback + (lambda (message) ;failure + (%trace ";g-output-stream-"op"-callback "message" "queue"\n") + (%queue! queue message)) + (lambda (value) ;success + (%trace ";g-output-stream-"op"-callback "value" "queue"\n") + (%queue! queue value)))) + +(define-integrable (external-string->alien xstr) + (let ((alien (make-alien 'uchar))) + (%set-alien/address! alien (external-string-descriptor xstr)) + alien)) + +(define-class ( (constructor (uri))) () (uri define accessor)) -(define-method initialize-instance ((gfile ) uri) +(define-method initialize-instance ((gfile )) (call-next-method gfile) - (guarantee-utf8-string uri) - (let ((alien (gobject-alien gfile))) + (let ((alien (gobject-alien gfile)) + (uri (gfile-uri gfile))) (set-alien/ctype! alien '|GFile|) + (guarantee-utf8-string uri) (C-call "g_file_new_for_uri" alien uri) (error-if-null alien "Could not create:" gfile uri))) -(define (->gfile object) - (cond ((string? object) (make-gfile object)) - ((pathname? object) (make-gfile (->namestring object))) - ((gfile? object) object) - (else (error "Not a GFile, pathname nor string:" object)))) - (define-class ( (constructor ())) ()) @@ -149,109 +661,44 @@ USA. (set-alien/ctype! alien '|GCancellable|) (C-call "g_cancellable_new" alien))) -(define (gcancellable-cancel gcancel) - (C-call "g_cancellable_cancel" (gobject-alien gcancel)) - (gobject-unref! gcancel)) - -(define (with-gcancellability callout) - (let ((gcancel (make-gcancellable)) - (in? #f) - (result #f)) - (dynamic-wind - (lambda () - (if in? (error "Already in!")) - (set! in? #t)) - (lambda () - (set! result (callout gcancel))) - (lambda () - (if (not result) - (gcancellable-cancel gcancel)) - (gobject-unref! gcancel))) - result)) - -(define-class ( (constructor ())) - ()) - -(define-method initialize-instance ((stream )) - (call-next-method stream) - (let ((alien (gobject-alien stream))) - (set-alien/ctype! alien '|GFileInputStream|))) - -(define (gfile-read gfile) - ;; Returns a . - (let ((gstream (make-gfile-input-stream)) - (io-priority 10) - ;;(gcancel (make-gcancellable)) - (q (make-thread-queue 1))) - (C-call "g_file_read_async" - (gobject-alien gfile) io-priority 0 ;;gcancel - (C-callback "async_ready") - (C-callback - (named-lambda (gfile-read-finish source result) - (if (not (alien=? source (gobject-alien gfile))) (warn "Unexpected source in async_ready:" source gfile)) - (if-gerror - (lambda (gerr) - (C-call "g_file_read_finish" - (gobject-alien gstream) - source result gerr)) - (lambda (message) ;failure - (thread-queue/queue! q message)) - (lambda (value) ;success - (declare (ignore value));;this is void/unspecific - (thread-queue/queue! q #t)))))) - (let ((message (thread-queue/dequeue! q))) - (if (string? message) (error message)) - ;;(gobject-unref! gcancel) - gstream))) - -(define-class ( (constructor ())) - ()) - -(define-method initialize-instance ((stream )) - (call-next-method stream) - (let ((alien (gobject-alien stream))) - (set-alien/ctype! alien '|GFileInputStream|))) +(define-structure gfile-etag + alien) -(define (gfile-open-readwrite gfile) - ;; Returns a . - (let ((gstream (make-gfile-io-stream)) - (io-priority 10) - ;;(gcancel (make-gcancellable)) - (q (make-thread-queue 1))) - (C-call "g_file_open_readwrite_async" - (gobject-alien gfile) io-priority 0 ;;gcancel - (C-callback "async_ready") - (C-callback - (named-lambda (gfile-open-readwrite-finish source result) - (if (not (alien=? source (gobject-alien gfile))) (warn "Unexpected source in async_ready:" source gfile)) - (if-gerror - (lambda (gerr) - (C-call "g_file_open_readwrite_finish" - (gobject-alien gstream) - source result gerr)) - (lambda (message) ;failure - (thread-queue/queue! q message)) - (lambda (value) ;success - (declare (ignore value));;this is void/unspecific - (thread-queue/queue! q #t)))))) - (let ((message (thread-queue/dequeue! q))) - (if (string? message) (error message)) - ;;(gobject-unref! gcancel) - gstream))) - -(define (if-gerror callout failure success) +(define-integrable (if-gerror callout failure success) ;; Applies CALLOUT to a *GError. If the pointer is set, tail- ;; applies FAILURE to the GError message, else SUCCESS to CALLOUT's ;; value. - (let ((gerror-ptr (malloc (C-sizeof "* GError") '(* |GError|)))) - (C->= gerror-ptr "* GError" 0) - (let* ((value (callout gerror-ptr)) - (gerror (C-> gerror-ptr "* GError"))) - (if (alien-null? gerror) - (begin - (free gerror-ptr) - (success value)) - (let ((message (c-peek-cstring (C-> gerror "GError message")))) - (C-call "g_error_free" gerror) - (free gerror-ptr) - (failure message)))))) \ No newline at end of file + (let ((gerror (make-alien '|GError|)) + (gerror* (make-alien '(* |GError|)))) + (let ((cleanup (make-gerror-cleanup gerror*))) + (add-gc-cleanup gerror cleanup) + ((ucode-primitive c-malloc 2) gerror* (c-sizeof "* GError")) + (C->= gerror* "* GError" 0) + (let ((value (callout gerror*))) + (C-> gerror* "* GError" gerror) + (if (alien-null? gerror) + (begin + ((ucode-primitive c-free 1) gerror*) + (alien-null! gerror*) + (punt-gc-cleanup gerror) + (success value)) + (let ((message (c-peek-cstring (C-> gerror "GError message")))) + (cleanup) + (punt-gc-cleanup gerror) + (alien-null! gerror) + (failure message))))))) + +(define (make-gerror-cleanup gerror*) + (named-lambda (gerror-cleanup) + (if (not (alien-null? gerror*)) + (let ((gerror (C-> gerror* "* GError"))) + (if (not (alien-null? gerror)) + (C-call "g_error_free" gerror)) + ((ucode-primitive c-free 1) gerror*) + (alien-null! gerror*))))) + +(define %trace? #f) + +(define-syntax %trace + (syntax-rules () + ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 27a2a8e29..ee72b2ee9 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -58,13 +58,19 @@ USA. (parent (gtk)) (files "gio") ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi") + (import (runtime) + ucode-primitive) (import (runtime ffi) %set-alien/address!) (import (runtime generic-i/o-port) make-gsource + make-gsink allocate-buffer-bytes) + (import (gtk thread) + maybe-yield-gtk) (export (gtk) - open-input-gfile)) + open-input-gfile + open-output-gfile)) (define-package (gtk pango) (parent (gtk)) diff --git a/tests/gtk/test-port-performance.scm b/tests/gtk/test-port-performance.scm new file mode 100644 index 000000000..e7b64ec64 --- /dev/null +++ b/tests/gtk/test-port-performance.scm @@ -0,0 +1,159 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of + Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Tests of port (character i/o) performance. + +(declare (usual-integrations)) + +(load-option 'Gtk) + +;; The number of trials for each test. +(define repeats 7) + +(define test-port-performance + (let ((cwd (directory-pathname (current-load-pathname)))) + (named-lambda (test-port-performance) + (with-working-directory-pathname cwd test)))) + +(define (test) + (note "Expressions") + (let ((data (test-io (make-read-exprs call-with-input-file) + (make-write-exprs call-with-tmp-output-file)))) + (note " "(length data)" files," + " "(reduce-left + 0 (map length data))" exprs\n")) + (note "Lines") + (let ((data (test-io (make-read-lines call-with-input-file) + (make-write-lines call-with-tmp-output-file)))) + (note " "(length data)" lines\n")) + + (note "Expressions via GIO") + (let ((data (test-io (make-read-exprs call-with-input-gfile) + (make-write-exprs call-with-tmp-output-gfile)))) + (note " "(length data)" files," + " "(reduce-left + 0 (map length data))" exprs\n")) + (note "Lines via GIO") + (let ((data (test-io (make-read-lines call-with-input-gfile) + (make-write-lines call-with-tmp-output-gfile)))) + (note " "(length data)" lines\n"))) + +(define (test-io read write) + (let ((data (read))) + (note " reading") + (dotimes repeats + (lambda (i) + (gc-flip) + (show-time read))) + (note " writing") + (dotimes repeats + (lambda (i) + (gc-flip) + (show-time (lambda () (write data))))) + data)) + +(define (make-read-exprs with-input-port) + (named-lambda (read-exprs) + (map (lambda (file) + (with-input-port + file + (lambda (port) + (let loop () + (let ((obj (read port))) + (if (eof-object? obj) + '() + (cons obj (loop)))))))) + (directory-read "../../src/runtime/*.scm")))) + +(define (make-write-exprs with-output-port) + (named-lambda (write-exprs data) + (with-output-port + (lambda (port) + (write data port)(newline port))))) + +(define (make-read-lines with-input-port) + (named-lambda (read-lines) + (append-map! (lambda (file) + (with-input-port + file + (lambda (port) + (let loop () + (let ((obj (read-line port))) + (if (eof-object? obj) + '() + (cons obj (loop)))))))) + (directory-read "../../src/runtime/*.scm")))) + +(define (make-write-lines with-output-port) + (named-lambda (write-lines lines) + (with-output-port + (lambda (port) + (let loop ((lines lines)) + (if (pair? lines) + (begin + (write-string (car lines) port)(newline port) + (loop (cdr lines))))))))) + +(define (call-with-input-gfile pathname receiver) + (let* ((port ((access open-input-gfile (->environment '(gtk))) + (string-append "file://" (->truename* pathname)))) + (value (receiver port))) + (close-input-port port) + value)) + +(define-integrable (->truename* pathname) + (let loop ((simpler (pathname-simplify (->truename pathname)))) + (let ((again (pathname-simplify simpler))) + (if (pathname=? again simpler) + (->namestring again) + (loop again))))) + +(define (call-with-tmp-output-file receiver) + (call-with-temporary-file-pathname + (lambda (pathname) + (call-with-output-file pathname receiver)))) + +(define (call-with-tmp-output-gfile receiver) + (call-with-temporary-file-pathname + (lambda (pathname) + (let* ((port ((access open-output-gfile (->environment '(gtk))) + (string-append "file://" (->truename* pathname)))) + (value (receiver port))) + (close-output-port port) + value)))) + +(define (note . objects) + (write-notification-line + (lambda (port) + (for-each (lambda (object) (display object port)) objects)))) + +(define (dotimes n procedure) + (define (loop i) + (if (<= i n) + (begin (procedure i) + (loop (1+ i))))) + (loop 1)) + +;(register-test 'port-performance test-port-performance) +(test-port-performance) \ No newline at end of file