From 7b637a6b6d8715479e9d02b1a5ae765b046d83a2 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 20 Jul 2011 10:17:24 -0700 Subject: [PATCH] Lighter-weight GError handling. Keep a gerror-pointer in a gio stream's cancel-info to avoid MANY mallocs/frees and gc-cleanup de-/registrations. Share gerror->message code with gobject.scm's pixbuf loaders. --- src/gtk/gio.scm | 277 ++++++++++++++++++++------------------------ src/gtk/gobject.scm | 33 +++--- src/gtk/gtk.pkg | 1 + 3 files changed, 148 insertions(+), 163 deletions(-) diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index 74aeffc02..2bb59658d 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -99,9 +99,9 @@ USA. ;;; 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. +;;; includes the GError *ptr, 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 @@ -110,15 +110,19 @@ USA. (define-class ( (constructor ())) () (cancel-info - define accessor - initializer (lambda () - (make-g-input-stream-cancel-info - #f #f (make-gcancellable) #f #f)))) + define accessor initializer + (lambda () + (make-g-input-stream-cancel-info + #f #f (make-gcancellable) (make-gerror*) #f #f)))) + +(define-integrable (make-gerror*) + (make-alien '(* |GError|))) (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 + gerror-pointer ; null or malloced GError* that MAY ref. a GError ;; To avoid registering read or skip finish callbacks for every read ;; or skip (a LOT of registering/deregistering!), the open operation @@ -129,9 +133,11 @@ USA. (define-method initialize-instance ((object )) (call-next-method object) - (add-gc-cleanup object - (make-g-input-stream-cleanup - (g-input-stream-cancel-info object)))) + (let* ((info (g-input-stream-cancel-info object)) + (gerror* (g-input-stream-cancel-info-gerror-pointer info))) + (add-gc-cleanup object + (make-g-input-stream-cleanup info)) + ((ucode-primitive c-malloc 2) gerror* (C-sizeof "*")))) (define (make-g-input-stream-cleanup info) (named-lambda (g-input-stream-cleanup) @@ -161,8 +167,17 @@ USA. (cleanup-callback-id info input callback-id) (cleanup-callback-id info input read-id) (cleanup-callback-id info input skip-id) + (cleanup-gerror-pointer (g-input-stream-cancel-info-gerror-pointer info)) (gobject-unref! (g-input-stream-cancel-info-gcancellable info))) +(define-integrable (cleanup-gerror-pointer gerror*) + (if (not (alien-null? gerror*)) + (let ((gerror (make-alien '|GError|))) + (C-> gerror* "* GError" gerror) + (if (not (alien-null? gerror)) + (C-call "g_error_free" gerror)) + ((ucode-primitive c-free 1) gerror*)))) + (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))) @@ -191,18 +206,17 @@ USA. (set-g-input-stream-cancel-info-pending-op! info #f) value)))))) -(define (make-g-input-stream-read-finish-callback queue) +(define (make-g-input-stream-read-finish-callback queue gerror*) (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)))))) + (let ((bytes (C-call "g_input_stream_read_finish" source result gerror*))) + (if (fix:= bytes -1) + (let ((message (gerror->message gerror*))) + (%trace ";g-input-stream-read-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";g-input-stream-read-finish-callback "bytes" "queue"\n") + (%queue! queue bytes))))))) (define-integrable (%queue! queue value) ;; The GIO finish callbacks use this procedure to queue a value on a @@ -235,29 +249,30 @@ USA. (set-g-input-stream-cancel-info-pending-op! info #f) value))))) -(define (make-g-input-stream-skip-finish-callback queue) +(define (make-g-input-stream-skip-finish-callback queue gerror*) (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)))))) + (let ((bytes (C-call "g_input_stream_skip_finish" source result gerror*))) + (if (fix:= bytes -1) + (let ((message (gerror->message gerror*))) + (%trace ";g-input-stream-skip-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";g-input-stream-skip-finish-callback "bytes" "queue"\n") + (%queue! queue bytes))))))) (define (g-input-stream-close gstream) (let* ((info (g-input-stream-cancel-info gstream)) (queue (g-stream-queue gstream)) + (gerror* (g-input-stream-cancel-info-gerror-pointer info)) (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))) + (let ((id (make-g-input-stream-close-finish-callback + queue gerror*))) (set-g-input-stream-cancel-info-pending-op! info 'CLOSE) (set-g-input-stream-cancel-info-callback-id! info id) id))))) @@ -279,31 +294,31 @@ USA. (cleanup-g-input-stream info))) value)))))) -(define (make-g-input-stream-close-finish-callback queue) +(define (make-g-input-stream-close-finish-callback queue gerror*) (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)))))) + (if (fix:zero? + (C-call "g_input_stream_close_finish" source result gerror*)) + (let ((message (gerror->message gerror*))) + (%trace ";g-input-stream-close-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";g-input-stream-close-finish-callback #t "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 accessor initializer + (lambda () + (make-g-output-stream-cancel-info + #f #f (make-gcancellable) (make-alien '(* |GError|)) #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 + gerror-pointer ; null or malloced GError* that MAY ref. a GError ;; To avoid registering write or flush finish callbacks for every ;; write or flush (a LOT of registering/deregistering!), the open @@ -331,6 +346,7 @@ USA. (cleanup-callback-id info output callback-id) (cleanup-callback-id info output write-id) (cleanup-callback-id info output flush-id) + (cleanup-gerror-pointer (g-output-stream-cancel-info-gerror-pointer info)) (gobject-unref! (g-output-stream-cancel-info-gcancellable info))) (define (g-output-stream-write gstream buffer start end) @@ -361,18 +377,19 @@ USA. (set-g-input-stream-cancel-info-pending-op! info #f) value)))))) -(define (make-g-output-stream-write-finish-callback queue) +(define (make-g-output-stream-write-finish-callback queue gerror*) (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)))))) + (let ((bytes + (C-call "g_output_stream_write_finish" source result gerror*))) + (if (fix:= bytes -1) + (let ((message (gerror->message gerror*))) + (%trace ";g-output-stream-write-finish-callback "message + " "queue"\n") + (%queue! queue message)) + (begin + (%trace ";g-output-stream-write-finish-callback "bytes" "queue"\n") + (%queue! queue bytes))))))) (define (g-output-stream-flush gstream) (let* ((info (g-output-stream-cancel-info gstream)) @@ -397,22 +414,22 @@ USA. (set-g-input-stream-cancel-info-pending-op! info #f) (not (fix:zero? value))))))) -(define (make-g-output-stream-flush-finish-callback queue) +(define (make-g-output-stream-flush-finish-callback queue gerror*) (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)))))) + (if (fix:zero? + (C-call "g_output_stream_flush_finish" source result gerror*)) + (let ((message (gerror->message gerror*))) + (%trace ";g-output-stream-flush-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";g-output-stream-flush-finish-callback #t "queue"\n") + (%queue! queue #t)))))) (define (g-output-stream-close gstream) (let* ((info (g-output-stream-cancel-info gstream)) (queue (g-stream-queue gstream)) + (gerror* (g-output-stream-cancel-info-gerror-pointer info)) (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) @@ -420,7 +437,8 @@ USA. (let ((callback-id (without-interrupts ;don't leak callback IDs (lambda () - (let ((id (make-g-output-stream-close-finish-callback queue))) + (let ((id (make-g-output-stream-close-finish-callback + queue gerror*))) (set-g-output-stream-cancel-info-pending-op! info 'CLOSE) (set-g-output-stream-cancel-info-callback-id! info id) id))))) @@ -442,18 +460,17 @@ USA. (cleanup-g-output-stream info))) value)))))) -(define (make-g-output-stream-close-finish-callback queue) +(define (make-g-output-stream-close-finish-callback queue gerror*) (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)))))) + (if (fix:zero? + (C-call "g_output_stream_close_finish" source result gerror*)) + (let ((message (gerror->message gerror*))) + (%trace ";g-output-stream-close-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";g-output-stream-close-finish-callback #t "queue"\n") + (%queue! queue #t)))))) (define-class ()) @@ -467,11 +484,12 @@ USA. (let* ((gstream (make-g-input-stream)) (info (g-input-stream-cancel-info gstream)) (queue (g-stream-queue gstream)) + (gerror* (g-input-stream-cancel-info-gerror-pointer info)) (callback-id (without-interrupts ;don't leak callback IDs (lambda () (let* ((alien (gobject-alien gstream)) - (id (make-gfile-read-finish-callback alien queue))) + (id (make-gfile-read-finish-callback alien queue gerror*))) (set-g-input-stream-cancel-info-pending-op! info 'OPEN) (set-g-input-stream-cancel-info-callback-id! info id) id))))) @@ -493,23 +511,22 @@ USA. (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)) + info (make-g-input-stream-read-finish-callback queue gerror*)) (set-g-input-stream-cancel-info-skip-id! - info (make-g-input-stream-skip-finish-callback queue)))) + info (make-g-input-stream-skip-finish-callback queue gerror*)))) gstream))))) -(define (make-gfile-read-finish-callback alien queue) +(define (make-gfile-read-finish-callback alien queue gerror*) (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)))))) + (let ((bytes (C-call "g_file_read_finish" alien source result gerror*))) + (if (fix:= bytes -1) + (let ((message (gerror->message gerror*))) + (%trace ";g-file-read-finish-callback \""message"\" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";g-file-read-finish-callback "bytes" "queue"\n") + (%queue! queue bytes))))))) (define-class ()) @@ -538,13 +555,11 @@ USA. (else (error:wrong-type-argument flag "GFile create flag" '->GFILE-CREATE-FLAG)))) -(define (make-gfile-append-to-finish-callback alien queue) +(define (make-gfile-append-to-finish-callback alien queue gerror*) (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)))))) + (C-call "g_file_append_to_finish" alien source result gerror*) + (g-output-stream-finish alien queue gerror* 'append-to)))) (define (gfile-create gfile . flags) (let ((flags* (->gfile-create-flags flags))) @@ -555,13 +570,11 @@ USA. priority gcancellable callback id)) make-gfile-create-finish-callback))) -(define (make-gfile-create-finish-callback alien queue) +(define (make-gfile-create-finish-callback alien queue gerror*) (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)))))) + (C-call "g_file_create_finish" alien source result gerror*) + (g-output-stream-finish alien queue gerror* 'create)))) (define (gfile-replace gfile etag backup? . flags) (let ((etag (->gfile-etag etag)) @@ -582,23 +595,22 @@ USA. (else (error:wrong-type-argument etag "GFile etag" '->GFILE-ETAG)))) -(define (make-gfile-replace-finish-callback alien queue) +(define (make-gfile-replace-finish-callback alien queue gerror*) (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)))))) + (C-call "g_file_replace_finish" alien source result gerror*) + (g-output-stream-finish alien queue gerror* 'replace)))) (define-integrable (gfile-open gfile callout make-callback) (let* ((gstream (make-g-output-stream)) (info (g-output-stream-cancel-info gstream)) + (gerror* (g-output-stream-cancel-info-gerror-pointer info)) (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))) + (id (make-callback alien queue gerror*))) (set-g-output-stream-cancel-info-pending-op! info 'OPEN) (set-g-output-stream-cancel-info-callback-id! info id) id))))) @@ -619,20 +631,20 @@ USA. (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)) + info (make-g-output-stream-write-finish-callback queue gerror*)) (set-g-output-stream-cancel-info-flush-id! - info (make-g-output-stream-flush-finish-callback queue)))) + info + (make-g-output-stream-flush-finish-callback queue gerror*)))) 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 (g-output-stream-finish alien queue gerror* op) + (if (alien-null? alien) + (let ((message (gerror->message gerror*))) + (%trace ";g-output-stream-"op"-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";g-output-stream-"op"-callback "alien" "queue"\n") + (%queue! queue alien)))) (define-integrable (external-string->alien xstr) (let ((alien (make-alien 'uchar))) @@ -664,39 +676,6 @@ USA. (define-structure gfile-etag alien) -(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 (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 diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm index edbeb3f21..03541dffd 100644 --- a/src/gtk/gobject.scm +++ b/src/gtk/gobject.scm @@ -65,7 +65,8 @@ USA. (without-interrupts (lambda () (gobject-cleanup (gobject-alien object) (gobject-signals object)) - (set! gc-cleanups (delq! (gobject-weak-self object) gc-cleanups))))) + (set! gc-cleanups (delq! (gobject-weak-self object) gc-cleanups)) + unspecific))) (define (gobject-cleanup alien signals) ;; Run as a gc-daemon, or with exclusive write access to ALIEN and @@ -461,6 +462,15 @@ USA. (set! gquark-from-string-cache (make-string-hash-table)) (set! gquark-to-string-cache (make-eqv-hash-table)) unspecific) + +(define-integrable (gerror->message pointer) + (let* ((GError (C-> pointer "* GError")) + (message (or (and (not (alien-null? GError)) + (c-peek-cstring (C-> GError "GError message"))) + "GError pointer not set."))) + (C->= pointer "* GError" 0) + (C-call "g_error_free" GError) + message)) ;;; GdkPixbufLoaders @@ -540,12 +550,13 @@ USA. (%trace "; "loader" started in "(current-thread)"\n") (let ((port (pixbuf-loader-port loader)) (alien (gobject-alien loader)) - (GError-ptr (malloc (C-sizeof "*") '(* |GError|))) + (*gerror (malloc (C-sizeof "*") '(* |GError|))) (buff (allocate-external-string 4200))) - (C->= GError-ptr "* GError" 0) + (C->= *gerror "* GError" 0) (let ((buff-address (external-string-descriptor buff))) (define (note-done) + (free *gerror) (without-interrupts (lambda () (set-pixbuf-loader-closed?! loader #t) @@ -556,26 +567,20 @@ USA. (proc loader)))))) (define (note-error) - (let* ((GError (C-> GError-ptr "*" (make-alien '|GError|))) - (message (or (and (not (alien-null? GError)) - (c-peek-cstring - (C-> GError "GError message"))) - "GError not set."))) - (set-pixbuf-loader-error-message! loader message) - (C-call "g_error_free" GError) - (free GError-ptr) - (note-done))) + (set-pixbuf-loader-error-message! loader + (gerror->message *gerror)) + (note-done)) (let loop () (let ((n (input-port/read-string! port buff))) (cond ((and (fix:zero? n) (eof-object? (peek-char port))) (if (fix:zero? (C-call "gdk_pixbuf_loader_close" - alien GError-ptr)) + alien *gerror)) (note-error) (note-done))) ((not (fix:zero? (C-call "gdk_pixbuf_loader_write" - alien buff-address n GError-ptr))) + alien buff-address n *gerror))) (loop)) (else (note-error)))))))))) diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index ee72b2ee9..0bd83275f 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -44,6 +44,7 @@ USA. add-gc-cleanup punt-gc-cleanup gobject-get-property gobject-set-properties gquark-from-string gquark-to-string + gerror->message make-pixbuf-loader load-pixbuf-from-port load-pixbuf-from-file pixbuf-loader-size-hook set-pixbuf-loader-size-hook! -- 2.25.1