From: Matt Birkholz Date: Thu, 8 Mar 2018 21:45:57 +0000 (-0700) Subject: glib: Serialize callouts to glib. Banish without-interrupts. X-Git-Tag: mit-scheme-pucked-x11-0.2.2~61 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6174307368e7ce6c83ef387c825c856494a11dea;p=mit-scheme.git glib: Serialize callouts to glib. Banish without-interrupts. --- diff --git a/src/glib/gio.scm b/src/glib/gio.scm index d9f4e8187..67b913704 100644 --- a/src/glib/gio.scm +++ b/src/glib/gio.scm @@ -28,8 +28,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (open-input-gfile uri) (let* ((uri* (->uri* uri 'open-input-gfile)) - (gfile (make-gfile uri*)) - (gstream (gfile-read gfile)) + (gstream + (with-glib-lock + (lambda () + (let* ((gfile (make-gfile uri*)) + (gstream (gfile-read gfile))) + (gobject-unref! gfile) + gstream)))) (port (make-generic-i/o-port (make-binary-port (make-g-stream-source gstream) #f @@ -38,7 +43,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 'open-input-gfile))) ;;(port/set-coding port 'ISO-8859-1) ;;(port/set-line-ending port 'NEWLINE) - (gobject-unref! gfile) port)) (define (->uri* object caller) @@ -66,17 +70,24 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) + (with-glib-lock + (lambda () (g-input-stream-read gstream buffer start end)))) (named-lambda (g-stream-source/close) (if open? - (let ((value (g-input-stream-close gstream))) + (let ((value (with-glib-lock + (lambda () (g-input-stream-close gstream))))) (set! open? #f) value)))))) (define (open-output-gfile uri) (let* ((uri* (->uri* uri 'open-output-gfile)) - (gfile (make-gfile uri*)) - (gstream (gfile-replace gfile #f #t 'private)) + (gstream + (with-glib-lock + (lambda () + (let* ((gfile (make-gfile uri*)) + (gstream (gfile-replace gfile #f #t 'private))) + (gobject-unref! gfile) + gstream)))) (port (make-generic-i/o-port (make-binary-port #f (make-g-stream-sink gstream) @@ -85,32 +96,34 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 'open-output-gfile))) ;;(port/set-coding port 'ISO-8859-1) ;;(port/set-line-ending port 'NEWLINE) - (gobject-unref! gfile) port)) (define (make-g-stream-sink gstream) (let ((open? #t)) (make-non-channel-output-sink (named-lambda (g-stream-sink/write-bytes buffer start end) - (g-output-stream-write gstream buffer start end)) + (with-glib-lock + (lambda () (g-output-stream-write gstream buffer start end)))) (named-lambda (g-stream-sink/close) (if open? - (let ((value (g-output-stream-close gstream))) + (let ((value (with-glib-lock + (lambda () (g-output-stream-close gstream))))) (set! open? #f) value)))))) (define (gdirectory-read uri) - (let* ((uri* (->uri* uri 'gdirectory-read)) - (gfile (make-gfile uri*)) - (names - (map! (lambda (ginfo) - (let ((name (gfile-info-get-attribute-value - ginfo "standard::name"))) - (gobject-unref! ginfo) - name)) - (gfile-children gfile "standard::name")))) - (gobject-unref! gfile) - names)) + (let ((uri* (->uri* uri 'gdirectory-read))) + (with-glib-lock + (lambda () + (let ((gfile (make-gfile uri*))) + (map! (lambda (ginfo) + (let ((name (gfile-info-get-attribute-value + ginfo "standard::name"))) + (gobject-unref! ginfo) + name)) + (let ((children (gfile-children gfile "standard::name"))) + (gobject-unref! gfile) + children))))))) (define (gfile-children gfile attributes) (let ((genum (gfile-enumerate-children gfile attributes #f))) @@ -160,6 +173,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (call-next-method object) (let* ((gio-info (gio-cleanup-info object)) (gerror* (gio-cleanup-info-gerror-pointer gio-info))) + (assert-glib-locked '(initialize-instance )) (C-call "g_try_malloc0" gerror* (C-sizeof "* GError")) (error-if-null gerror* "Could not create:" gerror*))) @@ -183,6 +197,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (,modifier ,info #F)))))))))) (define-integrable-operator (cleanup-gerror-pointer gerror*) + (assert-glib-locked 'cleanup-gerror-pointer) (if (not (alien-null? gerror*)) (let ((gerror (make-alien '|GError|))) (C-> gerror* "* GError" gerror) @@ -192,6 +207,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (alien-null! gerror*)))) (define-integrable-operator (cleanup-gio gio-info) + (assert-glib-locked 'cleanup-gio) (let ((pending-op (gio-cleanup-info-pending-op gio-info))) (if (not (memq pending-op '(#f ERROR CLOSED))) (C-call "g_cancellable_cancel" @@ -239,12 +255,19 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cleanup-g-input-stream gio-info info))) (define (cleanup-g-input-stream gio-info info) - ;; For glib-cleanups. Run without-interrupts. + (assert-without-interruption 'cleanup-g-input-stream) + (assert-glib-locked 'cleanup-g-input-stream) (cleanup-gio gio-info) (cleanup-callback-id info g-input-stream read-id) (cleanup-callback-id info g-input-stream skip-id)) +(define-integrable (dequeue! queue) + (without-glib-lock + (lambda () + (thread-queue/dequeue! queue)))) + (define (g-input-stream-read gstream buffer start end) + (assert-glib-locked 'g-input-stream-read) (let* ((gio-info (gio-cleanup-info gstream)) (info (g-input-stream-cleanup-info gstream)) (callback-id (g-input-stream-cleanup-info-read-id info))) @@ -261,7 +284,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-callback "async_ready") callback-id) (let* ((queue (gio-queue gstream)) - (value (thread-queue/dequeue! queue))) + (value (dequeue! queue))) (if (string? value) (begin (set-gio-cleanup-info-pending-op! gio-info 'ERROR) @@ -286,6 +309,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-read-finish-callback queue gerror*) (C-callback (named-lambda (read-finish-callback source result) + (assert-glib-locked 'read-finish-callback) (let ((bytes (C-call "g_input_stream_read_finish" source result gerror*))) (if (fix:= bytes -1) (let ((message (%gerror-message gerror*))) @@ -314,6 +338,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (maybe-yield-glib)) (define (g-input-stream-skip gstream count) + (assert-glib-locked 'g-input-stream-skip) (let* ((gio-info (gio-cleanup-info gstream)) (info (g-input-stream-cleanup-info gstream)) (callback-id (g-input-stream-cleanup-info-skip-id info))) @@ -327,7 +352,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-callback "async_ready") callback-id) (let* ((queue (gio-queue gstream)) - (value (thread-queue/dequeue! queue))) + (value (dequeue! queue))) (if (string? value) (begin (set-gio-cleanup-info-pending-op! gio-info 'ERROR) @@ -339,6 +364,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-skip-finish-callback queue gerror*) (C-callback (named-lambda (skip-finish-callback source result) + (assert-glib-locked 'skip-finish-callback) (let ((bytes (C-call "g_input_stream_skip_finish" source result gerror*))) (if (fix:= bytes -1) (let ((message (%gerror-message gerror*))) @@ -349,6 +375,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%queue! queue bytes))))))) (define (g-input-stream-close gstream) + (assert-glib-locked 'g-input-stream-close) (gfile-close gstream (named-lambda (close-input gstream* priority gcancellable* callback id) @@ -361,12 +388,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. gio-info (g-input-stream-cleanup-info gstream))))) (define (gfile-close gio callout make-callback cleanup) + (assert-glib-locked 'gfile-close) (let* ((gio-info (gio-cleanup-info gio)) (queue (gio-queue gio)) (gerror* (gio-cleanup-info-gerror-pointer gio-info))) (guarantee-gio-idle gio) (let ((callback-id - (without-interrupts ;don't leak callback IDs + (without-interruption ;don't leak callback IDs (lambda () (let ((old (gio-cleanup-info-callback-id gio-info))) (if old (de-register-c-callback old))) @@ -379,11 +407,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) - (let ((value (thread-queue/dequeue! queue))) + (let ((value (dequeue! queue))) (cond ((eq? value #t) - (set-gio-cleanup-info-pending-op! gio-info 'CLOSED) - (without-interrupts + (without-interruption (lambda () + (set-gio-cleanup-info-pending-op! gio-info 'CLOSED) (cleanup gio-info))) unspecific) ((string? value) @@ -395,6 +423,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-input-close-finish-callback queue gerror*) (C-callback (named-lambda (input-close-finish-callback source result) + (assert-glib-locked 'input-close-finish-callback) (if (fix:zero? (C-call "g_input_stream_close_finish" source result gerror*)) (let ((message (%gerror-message gerror*))) @@ -428,12 +457,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cleanup-g-output-stream gio-info info))) (define (cleanup-g-output-stream gio-info info) - ;; For glib-cleanups. Run without-interrupts. + (assert-without-interruption 'cleanup-g-output-stream) + (assert-glib-locked 'cleanup-g-output-stream) (cleanup-gio gio-info) (cleanup-callback-id info g-output-stream write-id) (cleanup-callback-id info g-output-stream flush-id)) (define (g-output-stream-write gstream buffer start end) + (assert-glib-locked 'g-output-stream-write) (let* ((gio-info (gio-cleanup-info gstream)) (info (g-output-stream-cleanup-info gstream)) (callback-id (g-output-stream-cleanup-info-write-id info))) @@ -451,7 +482,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-callback "async_ready") callback-id) (let* ((queue (gio-queue gstream)) - (value (thread-queue/dequeue! queue))) + (value (dequeue! queue))) (if (string? value) (begin (set-gio-cleanup-info-pending-op! gio-info 'ERROR) @@ -463,6 +494,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-write-finish-callback queue gerror*) (C-callback (named-lambda (write-finish-callback source result) + (assert-glib-locked 'write-finish-callback) (let ((bytes (C-call "g_output_stream_write_finish" source result gerror*))) (if (fix:= bytes -1) @@ -474,6 +506,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%queue! queue bytes))))))) (define (g-output-stream-flush gstream) + (assert-glib-locked 'g-output-stream-flush) (let* ((gio-info (gio-cleanup-info gstream)) (info (g-output-stream-cleanup-info gstream)) (callback-id (g-output-stream-cleanup-info-flush-id info))) @@ -486,7 +519,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-callback "async_ready") callback-id) (let* ((queue (gio-queue gstream)) - (value (thread-queue/dequeue! queue))) + (value (dequeue! queue))) (if (string? value) (begin (set-gio-cleanup-info-pending-op! gio-info 'ERROR) @@ -498,6 +531,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-flush-finish-callback queue gerror*) (C-callback (named-lambda (flush-finish-callback source result) + (assert-glib-locked 'flush-finish-callback) (if (fix:zero? (C-call "g_output_stream_flush_finish" source result gerror*)) (let ((message (%gerror-message gerror*))) @@ -508,6 +542,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%queue! queue #t)))))) (define (g-output-stream-close gstream) + (assert-glib-locked 'g-output-stream-close) (gfile-close gstream (named-lambda (close-output gstream* priority gcancellable* callback id) @@ -522,6 +557,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-output-close-finish-callback queue gerror*) (C-callback (named-lambda (output-close-finish-callback source result) + (assert-glib-locked 'output-close-finish-callback) (if (fix:zero? (C-call "g_output_stream_close_finish" source result gerror*)) (let ((message (%gerror-message gerror*))) @@ -540,6 +576,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-alien/ctype! alien '|GFileInputStream|))) (define (gfile-read gfile) + (assert-glib-locked 'gfile-read) (gfile-open gfile 'OPEN make-g-input-stream (named-lambda (open-callout @@ -555,7 +592,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (queue (gio-queue gstream)) (gerror* (gio-cleanup-info-gerror-pointer gio-info)) (callback-id - (without-interrupts ;don't leak callback IDs + (without-interruption ;don't leak callback IDs (lambda () (let ((id (make-callback (gobject-alien gstream) queue gerror*))) (set-gio-cleanup-info-pending-op! gio-info operation) @@ -567,10 +604,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) - (let ((value (thread-queue/dequeue! queue))) + (let ((value (dequeue! queue))) (cond ((eq? value #t) (set-gio-cleanup-info-pending-op! gio-info #f) - (without-interrupts + (without-interruption (lambda () (de-register-c-callback callback-id) (set-gio-cleanup-info-callback-id! gio-info #f) @@ -588,6 +625,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-open-finish-callback alien queue gerror*) (C-callback (named-lambda (open-finish-callback source result) + (assert-glib-locked 'open-finish-callback) (C-call "g_file_read_finish" alien source result gerror*) (if (alien-null? alien) (let ((message (%gerror-message gerror*))) @@ -613,6 +651,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-alien/ctype! alien '|GFileOutputStream|))) (define (gfile-append-to gfile . flags) + (assert-glib-locked 'gfile-append-to) (let ((flags* (->gfile-create-flags flags))) (gfile-open gfile 'APPEND-TO make-g-output-stream @@ -636,10 +675,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-append-to-finish-callback alien queue gerror*) (C-callback (named-lambda (append-to-finish-callback source result) + (assert-glib-locked 'append-to-finish-callback) (C-call "g_file_append_to_finish" alien source result gerror*) (g-output-stream-finish alien queue gerror* 'APPEND-TO)))) (define (g-output-stream-finish alien queue gerror* op) + (assert-glib-locked 'g-output-stream-finish) (if (alien-null? alien) (let ((message (%gerror-message gerror*))) (%trace ";"op"-finish-callback "message" "queue"\n") @@ -656,6 +697,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. info (make-flush-finish-callback queue gerror*)))) (define (gfile-create gfile . flags) + (assert-glib-locked 'gfile-create) (let ((flags* (->gfile-create-flags flags))) (gfile-open gfile 'CREATE make-g-output-stream @@ -669,10 +711,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-create-finish-callback alien queue gerror*) (C-callback (named-lambda (create-finish-callback source result) + (assert-glib-locked 'create-finish-callback) (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) + (assert-glib-locked 'gfile-replace) (let ((etag (->gfile-etag etag)) (make-backups (if backup? 1 0)) (flags* (->gfile-create-flags flags))) @@ -697,6 +741,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-replace-finish-callback alien queue gerror*) (C-callback (named-lambda (replace-finish-callback source result) + (assert-glib-locked 'replace-finish-callback) (C-call "g_file_replace_finish" alien source result gerror*) (g-output-stream-finish alien queue gerror* 'REPLACE)))) @@ -713,6 +758,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gfile-query-info gfile attributes follow-symlinks?) (guarantee string? attributes 'gfile-query-info) + (assert-glib-locked 'gfile-query-info) (gfile-open gfile 'QUERY make-gfile-info (named-lambda (query-callout @@ -734,6 +780,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-query-finish-callback alien queue gerror*) (C-callback (named-lambda (query-finish-callback source result) + (assert-glib-locked 'query-finish-callback) (C-call "g_file_query_info_finish" alien source result gerror*) (if (alien-null? alien) (let ((message (%gerror-message gerror*))) @@ -745,6 +792,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gfile-info-list-attributes ginfo namespace) (guarantee string? namespace 'gfile-info-list-attributes) + (assert-glib-locked 'gfile-info-list-attributes) (map! string->symbol (let ((alien (make-cstringv (lambda (copy) @@ -755,6 +803,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. strings)))) (define (gfile-info-get-attribute-status ginfo name) + (assert-glib-locked 'gfile-info-get-attribute-status) (let ((code (C-call "g_file_info_get_attribute_status" (gobject-alien ginfo) (string->utf8 name)))) @@ -765,6 +814,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (else (error "Unknown GFileAttributeStatus:" code))))) (define (gfile-info-get-attribute-value ginfo name) + (assert-glib-locked 'gfile-info-get-attribute-value) (let* ((alien (gobject-alien ginfo)) (name-bv (string->utf8 name)) (type (C-call "g_file_info_get_attribute_type" alien name-bv))) @@ -815,11 +865,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cleanup-gfile-enumerator gio-info ginfos))) (define (cleanup-gfile-enumerator gio-info ginfos) - ;; For glib-cleanups. Run without-interrupts. + (assert-without-interruption 'cleanup-gfile-enumerator) + (assert-glib-locked 'cleanup-gfile-enumerator) (cleanup-gio gio-info) (cleanup-ginfos ginfos)) (define (cleanup-ginfos glist) + (assert-without-interruption 'cleanup-ginfos) + (assert-glib-locked 'cleanup-ginfos) (if (not (alien-null? glist)) (let ((scan (copy-alien glist)) (ginfo (make-alien '|GFileInfo|))) @@ -838,6 +891,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gfile-enumerate-children gfile attributes follow-symlinks?) (guarantee string? attributes 'gfile-enumerate-children) + (assert-glib-locked 'gfile-enumerate-children) (gfile-open gfile 'OPEN make-gfile-enumerator (named-lambda (query-callout @@ -861,6 +915,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-enumerator-finish-callback alien queue gerror*) (C-callback (named-lambda (enumerator-finish-callback source result) + (assert-glib-locked 'enumerator-finish-callback) (C-call "g_file_enumerate_children_finish" alien source result gerror*) (if (alien-null? alien) (let ((message (%gerror-message gerror*))) @@ -872,6 +927,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gfile-enumerator-next-files genum nfiles) (guarantee fixnum? nfiles 'gfile-enumerator-next-files) + (assert-glib-locked 'gfile-enumerator-next-files) (let* ((gio-info (gio-cleanup-info genum)) (callback-id (gio-cleanup-info-callback-id gio-info))) (guarantee-gio-idle genum) @@ -884,7 +940,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-callback "async_ready") callback-id) (let* ((queue (gio-queue genum)) - (value (thread-queue/dequeue! queue))) + (value (dequeue! queue))) (if (string? value) (begin (set-gio-cleanup-info-pending-op! gio-info 'ERROR) @@ -894,6 +950,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (make-ginfos genum)))))) (define (make-ginfos genum) + (assert-glib-locked 'make-ginfos) (let* ((glist (gfile-enumerator-ginfos genum)) (scan (copy-alien glist)) (ginfo (make-alien '|GFileInfo|)) @@ -905,26 +962,23 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-> scan "GList data" ginfo) (if (not (alien-null? ginfo)) (let ((new (make-gfile-info))) - (without-interrupts - (lambda () - (copy-alien-address! (gobject-alien new) ginfo) - (C->= scan "GList data" 0))) + (copy-alien-address! (gobject-alien new) ginfo) + (C->= scan "GList data" 0) (C-> scan "GList next" scan) (cons new (loop))) (begin (C-> scan "GList next" scan) (loop)))))))) - (without-interrupts - (lambda () - (if (not (alien-null? glist)) - (begin - (C-call "g_list_free" glist) - (alien-null! glist))))) + (if (not (alien-null? glist)) + (begin + (C-call "g_list_free" glist) + (alien-null! glist))) ginfos)) (define (make-next-files-finish-callback ginfos queue gerror*) (C-callback (named-lambda (next-files-finish-callback source result) + (assert-glib-locked 'next-files-finish-callback) (C-call "g_file_enumerator_next_files_finish" ginfos source result gerror*) (if (and (alien-null? ginfos) (not (alien-null? (C-> gerror* "* GError")))) @@ -936,6 +990,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%queue! queue #t)))))) (define (gfile-enumerator-close genum) + (assert-glib-locked 'gfile-enumerator-close) (let ((ginfos (gfile-enumerator-ginfos genum))) (gfile-close genum (named-lambda (close-enumerator @@ -949,6 +1004,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-enumerator-close-finish-callback queue gerror*) (C-callback (named-lambda (enumerator-close-finish-callback source result) + (assert-glib-locked 'enumerator-close-finish-callback) (if (fix:zero? (C-call "g_file_enumerator_close_finish" source result gerror*)) (let ((message (%gerror-message gerror*))) @@ -979,13 +1035,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cleanup-gio gio-info))) (define (gfile-mount gfile) + (assert-glib-locked 'gfile-mount) (let* ((gmountop (make-g-mount-operation)) (alien (gobject-alien gmountop)) (gio-info (gio-cleanup-info gmountop)) (queue (gio-queue gmountop)) (gerror* (gio-cleanup-info-gerror-pointer gio-info)) (callback-id - (without-interrupts ;don't leak callback IDs + (without-interruption ;don't leak callback IDs (lambda () (let ((id (make-mount-finish-callback queue gerror*))) (set-gio-cleanup-info-pending-op! gio-info 'MOUNT) @@ -1010,7 +1067,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) - (let ((value (thread-queue/dequeue! queue))) + (let ((value (dequeue! queue))) (cond ((and (equal? value "Password dialog cancelled") (g-mount-operation-ask-password-flags gmountop)) (set-gio-cleanup-info-pending-op! gio-info #f) @@ -1022,7 +1079,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((eq? value #t) (set-gio-cleanup-info-pending-op! gio-info #f) (gobject-unref! gmountop) - (without-interrupts + (without-interruption (lambda () (cleanup-gio gio-info))) unspecific) @@ -1031,6 +1088,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (prompt-for-mount-auth gmountop) (%trace-auth ";prompt-for-mount-auth "gmountop"\n") + (assert-glib-locked 'prompt-for-mount-auth) (let ((message (g-mount-operation-message gmountop)) (domain (g-mount-operation-domain gmountop)) (username (g-mount-operation-username gmountop)) @@ -1039,7 +1097,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (port (interaction-i/o-port))) (if message (display message port)) (if (and (memq 'ANONYMOUS-SUPPORTED flags) - (prompt-for-confirmation "Login anonymously" port)) + (without-glib-lock + (lambda () + (prompt-for-confirmation "Login anonymously" port)))) (begin (C-call "g_mount_operation_set_anonymous" alien 1) (set-g-mount-operation-username! alien "anonymous"))) @@ -1052,22 +1112,37 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-call "g_mount_operation_set_username" alien (string->utf8 u)) (set-g-mount-operation-username! gmountop u))) (if (memq 'NEED-PASSWORD flags) - (call-with-pass-phrase - "Password" - (lambda (phrase) - (C-call "g_mount_operation_set_password" alien (string->utf8 phrase))))) + (let ((password)) + (dynamic-wind + (lambda () unspecific) + (lambda () + (without-glib-lock + (lambda () + (call-with-pass-phrase + "Password" + (lambda (phrase) (set! password (string->utf8 phrase)))))) + (C-call "g_mount_operation_set_password" alien password)) + (lambda () + (bytevector-fill! password #x55))))) (if (memq 'SAVING-SUPPORTED flags) - (if (prompt-for-confirmation "Save password permanently" port) + (if (without-glib-lock + (lambda () + (prompt-for-confirmation "Save password permanently" port))) (C-call "g_mount_operation_set_password_save" alien (C-enum "G_PASSWORD_SAVE_PERMANENTLY")) - (if (prompt-for-confirmation "Save password for this session" port) + (if (without-glib-lock + (lambda () + (prompt-for-confirmation "Save password for this session" + port))) (C-call "g_mount_operation_set_password_save" alien (C-enum "G_PASSWORD_SAVE_FOR_SESSION")) (C-call "g_mount_operation_set_password_save" alien (C-enum "G_PASSWORD_SAVE_NEVER"))))))) (define (prompt-for-string* prompt default port) - (let ((s (prompt-for-string prompt port))) + (let ((s (without-glib-lock + (lambda () + (prompt-for-string prompt port))))) (if (not (string-find-next-char-in-set s char-set:not-whitespace)) default s))) @@ -1075,6 +1150,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-mount-finish-callback queue gerror*) (C-callback (named-lambda (mount-finish-callback source result) + (assert-glib-locked 'mount-finish-callback) (if (fix:zero? (C-call "g_file_mount_enclosing_volume_finish" source result gerror*)) (let ((message (%gerror-message gerror*))) @@ -1100,6 +1176,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. " "(c-peek-cstring user) " "(c-peek-cstring domain) " "(->ask-password-flags flags)"\n") + (assert-glib-locked 'mount-password-callback) (let ((old (g-mount-operation-ask-password-flags gmountop)) (new (->ask-password-flags flags))) (set-g-mount-operation-message! gmountop @@ -1142,7 +1219,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. " "gmountop " "(c-peek-cstring message) " "(peek-gstrv! choices)"\n") - (warn "Unimplemented" 'mount-question-callback))) + (warn "Unimplemented" 'mount-question-callback) + (assert-glib-locked 'mount-question-callback))) (define (peek-gstrv! alien) (let loop () @@ -1167,6 +1245,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((gfile )) (call-next-method gfile) + (assert-glib-locked '(initialize-instance )) (let ((alien (gobject-alien gfile)) (uri (string->utf8 (uri->string (gfile-uri gfile))))) (set-alien/ctype! alien '|GFile|) @@ -1178,6 +1257,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method initialize-instance ((gcancel )) (call-next-method gcancel) + (assert-glib-locked '(initialize-instance )) (let ((alien (gobject-alien gcancel))) (set-alien/ctype! alien '|GCancellable|) (C-call "g_cancellable_new" alien))) @@ -1187,6 +1267,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-cstringv setter) ;; SETTER is applied to an alien that must not escape. + (assert-glib-locked 'make-cstringv) (let ((alien (make-alien '(* uchar))) (copy (make-alien '(* uchar)))) (add-glib-cleanup alien (make-cstringv-cleanup copy)) @@ -1196,6 +1277,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (make-cstringv-cleanup alien) (named-lambda (cstringv-cleanup) + (assert-glib-locked 'cstringv-cleanup) (if (not (alien-null? alien)) (let ((scan (copy-alien alien)) (cstr (make-alien 'uchar))) @@ -1221,7 +1303,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cons str (loop))))))) (define (free-cstringv alien) - (without-interrupts + (without-interruption (lambda () (execute-glib-cleanup alien) (alien-null! alien)))) diff --git a/src/glib/glib-main.scm b/src/glib/glib-main.scm index 5dd9dcd03..660db6c3a 100644 --- a/src/glib/glib-main.scm +++ b/src/glib/glib-main.scm @@ -30,27 +30,36 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; Called from glib/make.scm, from a (load-option 'Glib). (if (not (plugin-available? "glib")) (error "GLIB plugin not found")) - (if (fix:zero? (C-call "start_glib")) + (if (fix:zero? (with-glib-lock + (lambda () + (C-call "start_glib")))) (error "Could not start Glib main loop.")) (create-glib-thread)) (define-integrable (run-glib select-registry-handle time) - (C-call "run_glib" select-registry-handle time)) + (assert-glib-locked 'run-glib) + (C-call "run_glib" select-registry-handle time) + (assert-glib-locked 'run-glib-continue)) (define (maybe-yield-glib) ;; Used by callbacks that may have made threads runnable. + (assert-glib-locked 'maybe-yield-glib) (if (other-running-threads?) (C-call "yield_glib"))) (define (stop-glib) ;; Sortof does the opposite of glib-start. - (without-interrupts + (with-glib-lock (lambda () (exit-glib-thread) (C-call "stop_glib")))) (define (glib-select-trace?) - (C-call "glib_select_trace_p")) + (with-glib-lock + (lambda () + (C-call "glib_select_trace_p")))) (define (glib-select-trace! on?) - (C-call "glib_select_trace" (if on? 1 0))) \ No newline at end of file + (with-glib-lock + (lambda () + (C-call "glib_select_trace" (if on? 1 0))))) \ No newline at end of file diff --git a/src/glib/glib-thread.scm b/src/glib/glib-thread.scm index bb4b9ad70..a274c3b16 100644 --- a/src/glib/glib-thread.scm +++ b/src/glib/glib-thread.scm @@ -52,36 +52,35 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (done-tick 0) (next-secondary-tick secondary-gc-rate)) (let glib-thread-loop () - (if (not (eq? interrupt-mask/all - ((ucode-primitive get-interrupt-enables 0)))) - (outf-error "\nglib-thread-loop: already running without-interrupts\n")) - (without-interrupts + (let ((gc-tick (car (gc-timestamp)))) + (if (fix:< done-tick gc-tick) + (with-glib-lock + (lambda () + (%trace ";run-glib cleaning up\n") + (run-glib-cleanups) + (%trace ";run-glib clean up done\n") + (set! done-tick gc-tick)))) + (if (fix:< next-secondary-tick gc-tick) + (begin + (%trace ";run-glib secondary-gc daemons\n") + (run-glib-daemons) + (%trace ";run-glib secondary-gc daemons done\n") + (set! next-secondary-tick + (fix:+ gc-tick secondary-gc-rate))))) + (with-glib-lock (lambda () - (let ((gc-tick (car (gc-timestamp)))) - (if (fix:< done-tick gc-tick) - (begin - (%trace ";run-glib cleaning up\n") - (run-glib-cleanups) - (%trace ";run-glib clean up done\n") - (set! done-tick gc-tick))) - (if (fix:< next-secondary-tick gc-tick) - (begin - (%trace ";run-glib secondary-gc daemons\n") - (run-glib-daemons) - (%trace ";run-glib secondary-gc daemons done\n") - (set! next-secondary-tick - (fix:+ gc-tick secondary-gc-rate))))))) - (with-thread-timer-stopped - (lambda () - (let ((time (or (and (thread/next self) 0) - (and timer-records - (timer-record/time timer-records)) - -1))) - (%trace ";run-glib until "time"\n") - ;;(account-for-times self (get-system-times)) - (run-glib (select-registry-handle io-registry) time) - ;;(record-start-times! self) - (%trace ";run-glib done at "(real-time-clock)"\n")))) + (with-thread-timer-stopped + (lambda () + (let ((time (or (and (thread/next self) 0) + (and timer-records + (timer-record/time timer-records)) + -1))) + (%trace ";run-glib until "time"\n") + ;;(account-for-times self (get-system-times)) + (run-glib (select-registry-handle io-registry) time) + ;;(record-start-times! self) + (%trace ";run-glib done at "(real-time-clock)"\n") + ))))) (%trace ";run-glib yields\n") (yield-current-thread) (%trace ";run-glib loops\n") diff --git a/src/glib/glib.pkg b/src/glib/glib.pkg index 66bf005d2..c320bb1d7 100644 --- a/src/glib/glib.pkg +++ b/src/glib/glib.pkg @@ -32,7 +32,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-package (glib) (parent ()) - (files "glib")) + (files "glib") + (import (runtime thread) + get-thread-event-block)) (define-package (gobject) (parent (glib)) @@ -112,6 +114,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (export () stop-glib-thread) (import (glib) + glib-mutex ;exposed by with-glib-lock, run-glib,... + with-glib-lock run-glib-cleanups run-glib-daemons) (import (glib main) diff --git a/src/glib/glib.scm b/src/glib/glib.scm index c876d5e5f..0adc5a85b 100644 --- a/src/glib/glib.scm +++ b/src/glib/glib.scm @@ -115,14 +115,44 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-color-alpha! color alpha) color)) +;;; GLib Mutex + +(define glib-mutex) + +(define (reset-glib-mutex!) + (set! glib-mutex (make-thread-mutex))) + +(define-integrable (with-glib-lock thunk) + (with-thread-mutex-lock glib-mutex thunk)) + +(define-integrable-operator (without-glib-lock thunk) + ;; Temporarily use thread-mutex-owner to (try to) avoid signaling an + ;; error when glib is not locked. This should actually avoid the + ;; error in single threaded worlds. + (let ((owner (thread-mutex-owner glib-mutex))) + (if (eq? #f owner) + (begin + (outf-error ";glib already unlocked\n") + (thunk) + ;; Lock it *now*? + ) + (without-thread-mutex-lock glib-mutex thunk)))) + +(define-integrable (assert-glib-locked operator) + ;; Useful at least when debugging single threaded worlds. + (if (not (eq? (current-thread) (thread-mutex-owner glib-mutex))) + (outf-error ";glib not locked: "operator"\n"))) + +(define-integrable (assert-without-interruption operator) + (if (not (get-thread-event-block)) + (outf-error ";not without-interruption: "operator"\n"))) + ;;; GLib Cleanups (define glib-cleanups) -(define (initialize-glib-cleanups!) - (set! glib-cleanups '())) - (define (run-glib-cleanups) + (assert-glib-locked 'run-glib-cleanups) (let loop ((alist glib-cleanups) (prev #f)) (if (pair? alist) @@ -157,13 +187,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set! glib-cleanups '())) (define (add-glib-cleanup object cleanup-thunk) + (assert-glib-locked 'add-glib-cleanup) (let ((weak-pair (weak-cons object cleanup-thunk))) - (without-interrupts - (lambda () - (set! glib-cleanups (cons weak-pair glib-cleanups)))) + (set! glib-cleanups (cons weak-pair glib-cleanups)) weak-pair)) (define (execute-glib-cleanup object) + (assert-glib-locked 'execute-glib-cleanup) ; and without-interruption (let ((entry (weak-assq object glib-cleanups))) (if entry (begin @@ -179,8 +209,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (if (eq? obj key) entry (loop (cdr alist))))))) +(define (reset-glib-package!) + (reset-glib-mutex!) + (reset-glib-cleanups!)) + (define (initialize-package!) - (initialize-glib-cleanups!) - (add-event-receiver! event:after-restore reset-glib-cleanups!)) + (reset-glib-package!) + (add-event-receiver! event:after-restore reset-glib-package!)) (initialize-package!) \ No newline at end of file diff --git a/src/glib/gobject.scm b/src/glib/gobject.scm index 4ded11da6..780f84f1e 100644 --- a/src/glib/gobject.scm +++ b/src/glib/gobject.scm @@ -62,6 +62,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; the closure. (named-lambda (gobject-cleanup) (%trace ";gobject-cleanup "alien"\n") + (assert-glib-locked 'gobject-cleanup) (if (not (alien-null? alien)) (begin (for-each @@ -72,7 +73,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace ";gobject-cleanup done with "alien"\n"))) (define (gobject-unref! object) - (without-interrupts + (assert-glib-locked 'gobject-unref!) + (without-interruption (lambda () (execute-glib-cleanup object)))) @@ -81,6 +83,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; Specify SIGNAL-NAME if it is not the same as ALIEN-FUNCTION's name. (guarantee-gobject gobject 'g-signal-connect) (guarantee-alien-function alien-function 'g-signal-connect) + (assert-glib-locked 'g-signal-connect) (let ((name (cond ((default-object? signal-name) (string->symbol (alien-function/name alien-function))) ((symbol? signal-name) signal-name) @@ -88,7 +91,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (else (error:wrong-type-argument signal-name "string or symbol" 'g-signal-connect))))) - (without-interrupts + (without-interruption (lambda () (let* ((alien (gobject-alien gobject)) (signals (gobject-signals gobject)) @@ -125,7 +128,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (g-signal-disconnect gobject name) (guarantee-gobject gobject 'g-signal-disconnect) (guarantee symbol? name 'g-signal-disconnect) - (without-interrupts + (assert-glib-locked 'g-signal-disconnect) + (without-interruption (lambda () (let* ((alien (gobject-alien gobject)) (signals (gobject-signals gobject)) @@ -149,6 +153,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gobject-get-property gobject property) (guarantee-gobject gobject 'gobject-get-property) + (assert-glib-locked 'gobject-get-property) (let ((name (check-prop-name property)) (gvalue (malloc (C-sizeof "GValue") '|GValue|))) @@ -215,6 +220,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. value))) (define (gobject-set-properties gobject . property-list) + (assert-glib-locked 'gobject-set-properties) (let* ((gobject-alien (gobject-alien gobject)) (gvalue (malloc (C-sizeof "GValue") '|GValue|)) (pspec (malloc (C-sizeof "GParamSpec") '|GParamSpec|)) @@ -308,17 +314,20 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. unspecific) (define (gobject-get-gclass alien) + (assert-glib-locked 'gobject-get-gclass) (let ((ret (make-alien '|GObjectClass|))) (C-call "G_OBJECT_GET_CLASS" ret alien) ret)) (define (gclass-get-name gclass) + (assert-glib-locked 'gclass-get-name) ;; GCLASS should be an alien of type GObjectClass. (let ((c* (make-alien '(* |gchar|)))) (C-call "G_OBJECT_CLASS_NAME" c* gclass) (c-peek-cstring c*))) (define (gobject-get-gtype gobject) + (assert-glib-locked 'gobject-get-gtype) (let ((ret (make-alien '|GType|))) (C-call "G_OBJECT_TYPE" ret (gobject-alien gobject)) ret)) @@ -402,6 +411,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define gquark-to-string-cache (make-eqv-hash-table)) (define (gquark-from-string string) + (assert-glib-locked 'gquark-from-string) (or (hash-table/get gquark-from-string-cache string #f) (let ((gq (C-call "g_quark_from_string" (string->utf8 string)))) (hash-table/put! gquark-from-string-cache string gq)