From: Matt Birkholz Date: Wed, 18 Mar 2015 19:51:27 +0000 (-0700) Subject: Borked, probably earlier. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=refs%2Fheads%2FSMP-Gtk;p=mit-scheme.git Borked, probably earlier. --- diff --git a/src/TAGS b/src/TAGS index e0668593b..37b4bb0c8 100644 --- a/src/TAGS +++ b/src/TAGS @@ -16,3 +16,39 @@ cref/TAGS,include rcs/TAGS,include ffi/TAGS,include + +blowfish/TAGS,include + +cairo/TAGS,include + +gdbm/TAGS,include + +gl/TAGS,include + +glib/TAGS,include + +gtk/TAGS,include + +gtk-screen/TAGS,include + +imail/TAGS,include + +mcrypt/TAGS,include + +md5/TAGS,include + +mhash/TAGS,include + +pango/TAGS,include + +planetarium/TAGS,include + +sos/TAGS,include + +ssp/TAGS,include + +star-parser/TAGS,include + +xdoc/TAGS,include + +xml/TAGS,include diff --git a/src/glib/gio.scm b/src/glib/gio.scm index 4392cbc19..23dc1ffcb 100644 --- a/src/glib/gio.scm +++ b/src/glib/gio.scm @@ -22,7 +22,10 @@ USA. |# ;;;; GIO Objects -;;; package: (glib gio) +;;; package: (gio) + +;;; For an overview of the implementation and its conventions, see +;;; node "Implementation Notes" in the accompanying glib.texinfo. (C-include "glib") @@ -148,14 +151,6 @@ USA. (make-gio-cleanup-info #f #f (make-gcancellable) (make-alien '(* |GError|)))))) -;;; When a is 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 gio-cleanup-info -;;; includes the GCancellable, the finish callback id, AND a flag to -;;; indicate whether an operation is pending and thus whether the -;;; GCancellable should be used. It also includes the GError pointer -;;; which, if not null, references a GError that must be freed. - (define-structure gio-cleanup-info pending-op ; #f, , CLOSED or ERROR. The first one ; means "idle" and the last two are more @@ -170,7 +165,9 @@ USA. (call-next-method object) (let* ((gio-info (gio-cleanup-info object)) (gerror* (gio-cleanup-info-gerror-pointer gio-info))) - (C-call "g_try_malloc0" gerror* (C-sizeof "* GError")) + (with-glib-locked + (lambda () + (C-call "g_try_malloc0" gerror* (C-sizeof "* GError")))) (error-if-null gerror* "Could not create:" gerror*))) (define-syntax cleanup-callback-id @@ -188,27 +185,34 @@ USA. environment))) `(LET ((ID (,accessor ,info))) (IF ID - (BEGIN - (DE-REGISTER-C-CALLBACK ID) - (,modifier ,info #F)))))))))) + (WITHOUT-INTERRUPTION + (LAMBDA () + (DE-REGISTER-C-CALLBACK ID) + (,modifier ,info #F))))))))))) (define-integrable-operator (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*) - (alien-null! gerror*)))) + (assert-glib-locked 'cleanup-gerror-pointer) + (without-interruption + (lambda () + (if (not (alien-null? gerror)) + (C-call "g_error_free" gerror)) + ((ucode-primitive c-free 1) gerror*) + (alien-null! gerror*)))))) (define-integrable-operator (cleanup-gio gio-info) (let ((pending-op (gio-cleanup-info-pending-op gio-info))) - (if (not (memq pending-op '(#f ERROR CLOSED))) - (C-call "g_cancellable_cancel" - (gobject-alien (gio-cleanup-info-gcancellable gio-info))))) - (cleanup-callback-id gio-info gio callback-id) - (gobject-unref! (gio-cleanup-info-gcancellable gio-info)) - (cleanup-gerror-pointer (gio-cleanup-info-gerror-pointer gio-info))) + (assert-glib-locked 'cleanup-gio) + (without-interruption + (lambda () + (if (not (memq pending-op '(#f ERROR CLOSED))) + (C-call "g_cancellable_cancel" + (gobject-alien (gio-cleanup-info-gcancellable gio-info)))) + (cleanup-callback-id gio-info gio callback-id) + (gobject-unref! (gio-cleanup-info-gcancellable gio-info)) + (cleanup-gerror-pointer (gio-cleanup-info-gerror-pointer gio-info)))))) (define-integrable (guarantee-gio-idle gio) (let* ((gio-info (gio-cleanup-info gio)) @@ -249,7 +253,7 @@ USA. (cleanup-g-input-stream gio-info info))) (define (cleanup-g-input-stream gio-info info) - ;; For glib-cleanups. Run without-interrupts. + (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)) @@ -262,14 +266,16 @@ USA. (let* ((count (fix:- end start)) (async-buffer (ensure-buffer gstream count))) (set-gio-cleanup-info-pending-op! gio-info 'READ) - (C-call "g_input_stream_read_async" - (gobject-alien gstream) - async-buffer - count - (gio-priority gstream) - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) + (with-glib-locked + (lambda () + (C-call "g_input_stream_read_async" + (gobject-alien gstream) + async-buffer + count + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) + (C-callback "async_ready") + callback-id))) (let* ((queue (gio-queue gstream)) (value (thread-queue/dequeue! queue))) (if (string? value) @@ -296,6 +302,7 @@ 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*))) @@ -313,6 +320,7 @@ USA. (if (not (alien-null? gerror)) (begin (C->= pointer "* GError" 0) + (assert-glib-locked '%gerror-message) (C-call "g_error_free" gerror))) message)) @@ -329,13 +337,15 @@ USA. (callback-id (g-input-stream-cleanup-info-skip-id info))) (guarantee-gio-idle gstream) (set-gio-cleanup-info-pending-op! gio-info 'SKIP) - (C-call "g_input_stream_skip_async" - (gobject-alien gstream) - count - (gio-priority gstream) - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) + (with-glib-locked + (lambda () + (C-call "g_input_stream_skip_async" + (gobject-alien gstream) + count + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) + (C-callback "async_ready") + callback-id))) (let* ((queue (gio-queue gstream)) (value (thread-queue/dequeue! queue))) (if (string? value) @@ -349,6 +359,7 @@ 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*))) @@ -362,6 +373,7 @@ USA. (gfile-close gstream (named-lambda (close-input gstream* priority gcancellable* callback id) + (assert-glib-locked 'g-input-stream-closed) (C-call "g_input_stream_close_async" gstream* priority gcancellable* callback id)) make-input-close-finish-callback @@ -375,7 +387,7 @@ USA. (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))) @@ -391,7 +403,7 @@ USA. (let ((value (thread-queue/dequeue! queue))) (cond ((eq? value #t) (set-gio-cleanup-info-pending-op! gio-info 'CLOSED) - (without-interrupts + (with-glib-locked (lambda () (cleanup gio-info))) unspecific) @@ -404,6 +416,7 @@ 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*))) @@ -437,7 +450,7 @@ USA. (cleanup-g-output-stream gio-info info))) (define (cleanup-g-output-stream gio-info info) - ;; For glib-cleanups. Run without-interrupts. + (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)) @@ -451,14 +464,16 @@ USA. (async-buffer (ensure-buffer gstream count))) (set-gio-cleanup-info-pending-op! gio-info 'WRITE) (c-poke-bytes async-buffer 0 count buffer start) - (C-call "g_output_stream_write_async" - (gobject-alien gstream) - async-buffer - count - (gio-priority gstream) - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) + (with-glib-locked + (lambda () + (C-call "g_output_stream_write_async" + (gobject-alien gstream) + async-buffer + count + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) + (C-callback "async_ready") + callback-id))) (let* ((queue (gio-queue gstream)) (value (thread-queue/dequeue! queue))) (if (string? value) @@ -472,6 +487,7 @@ 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) @@ -488,12 +504,14 @@ USA. (callback-id (g-output-stream-cleanup-info-flush-id info))) (guarantee-gio-idle gstream) (set-gio-cleanup-info-pending-op! gio-info 'FLUSH) - (C-call "g_output_stream_flush_async" - (gobject-alien gstream) - (gio-priority gstream) - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) + (with-glib-locked + (lambda () + (C-call "g_output_stream_flush_async" + (gobject-alien gstream) + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) + (C-callback "async_ready") + callback-id))) (let* ((queue (gio-queue gstream)) (value (thread-queue/dequeue! queue))) (if (string? value) @@ -507,6 +525,7 @@ 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*))) @@ -520,6 +539,7 @@ USA. (gfile-close gstream (named-lambda (close-output gstream* priority gcancellable* callback id) + (assert-glib-locked 'close-output) (C-call "g_output_stream_close_async" gstream* priority gcancellable* callback id)) make-output-close-finish-callback @@ -530,6 +550,7 @@ 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*))) @@ -552,6 +573,7 @@ USA. make-g-input-stream (named-lambda (open-callout gfile* priority gcancellable* callback id) + (assert-glib-locked 'open-callout) (C-call "g_file_read_async" gfile* priority gcancellable* callback id)) make-open-finish-callback @@ -563,7 +585,7 @@ 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) @@ -578,7 +600,7 @@ USA. (let ((value (thread-queue/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) @@ -596,6 +618,7 @@ 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*))) @@ -626,6 +649,7 @@ USA. make-g-output-stream (named-lambda (append-to-callout gfile* priority gcancellable* callback id) + (assert-glib-locked 'append-to-callout) (C-call "g_file_append_to_async" gfile* flags* priority gcancellable* callback id)) make-append-to-finish-callback @@ -644,6 +668,7 @@ 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)))) @@ -669,6 +694,7 @@ USA. make-g-output-stream (named-lambda (create-callout gfile* priority gcancellable* callback id) + (assert-glib-locked 'create-callout) (C-call "g_file_create_async" gfile* flags* priority gcancellable* callback id)) make-create-finish-callback @@ -677,6 +703,7 @@ 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)))) @@ -688,6 +715,7 @@ USA. make-g-output-stream (named-lambda (replace-callout gfile* priority gcancellable* callback id) + (assert-glib-locked 'replace-callout) (C-call "g_file_replace_async" gfile* etag make-backups flags* priority gcancellable* callback id)) @@ -705,6 +733,7 @@ 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)))) @@ -725,6 +754,7 @@ USA. make-gfile-info (named-lambda (query-callout gfile* priority gcancellable* callback id) + (assert-glib-locked 'query-callout) (C-call "g_file_query_info_async" gfile* attributes @@ -742,6 +772,7 @@ 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*))) @@ -756,6 +787,7 @@ USA. (map! string->symbol (let ((alien (make-cstringv (lambda (copy) + (assert-glib-locked 'gfile-info-list-attributes) (C-call "g_file_info_list_attributes" copy (gobject-alien ginfo) namespace))))) (let ((strings (peek-cstringv alien))) @@ -763,6 +795,7 @@ 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) name))) @@ -773,6 +806,7 @@ 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)) (type (C-call "g_file_info_get_attribute_type" alien name))) (cond ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INVALID")) @@ -822,7 +856,7 @@ USA. (cleanup-gfile-enumerator gio-info ginfos))) (define (cleanup-gfile-enumerator gio-info ginfos) - ;; For glib-cleanups. Run without-interrupts. + (assert-glib-locked 'cleanup-gfile-enumerator) (cleanup-gio gio-info) (cleanup-ginfos ginfos)) @@ -830,18 +864,21 @@ USA. (if (not (alien-null? glist)) (let ((scan (copy-alien glist)) (ginfo (make-alien '|GFileInfo|))) - (let loop () - (C-> scan "GList data" ginfo) - (if (not (alien-null? ginfo)) - (begin - (C->= scan "GList data" 0) - (C-call "g_object_unref" ginfo))) - (C-> scan "GList next" scan) - (if (alien-null? scan) - (begin - (C-call "g_list_free" glist) - (alien-null! glist)) - (loop)))))) + (assert-glib-locked 'cleanup-ginfos) + (without-interruption + (lambda () + (let loop () + (C-> scan "GList data" ginfo) + (if (not (alien-null? ginfo)) + (begin + (C->= scan "GList data" 0) + (C-call "g_object_unref" ginfo))) + (C-> scan "GList next" scan) + (if (alien-null? scan) + (begin + (C-call "g_list_free" glist) + (alien-null! glist)) + (loop)))))))) (define (gfile-enumerate-children gfile attributes follow-symlinks?) (guarantee-string attributes 'gfile-enumerate-children) @@ -849,6 +886,7 @@ USA. make-gfile-enumerator (named-lambda (query-callout gfile* priority gcancellable* callback id) + (assert-glib-locked 'query-callout) (C-call "g_file_enumerate_children_async" gfile* attributes @@ -868,6 +906,7 @@ 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*))) @@ -883,13 +922,15 @@ USA. (callback-id (gio-cleanup-info-callback-id gio-info))) (guarantee-gio-idle genum) (set-gio-cleanup-info-pending-op! gio-info 'NEXT) - (C-call "g_file_enumerator_next_files_async" - (gobject-alien genum) - nfiles - (gio-priority genum) - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) + (with-glib-locked + (lambda () + (C-call "g_file_enumerator_next_files_async" + (gobject-alien genum) + nfiles + (gio-priority genum) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) + (C-callback "async_ready") + callback-id))) (let* ((queue (gio-queue genum)) (value (thread-queue/dequeue! queue))) (if (string? value) @@ -912,7 +953,7 @@ USA. (C-> scan "GList data" ginfo) (if (not (alien-null? ginfo)) (let ((new (make-gfile-info))) - (without-interrupts + (without-interruption (lambda () (copy-alien-address! (gobject-alien new) ginfo) (C->= scan "GList data" 0))) @@ -921,17 +962,19 @@ USA. (begin (C-> scan "GList next" scan) (loop)))))))) - (without-interrupts + (with-glib-locked (lambda () (if (not (alien-null? glist)) - (begin - (C-call "g_list_free" glist) - (alien-null! glist))))) + (without-interruption + (lambda () + (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")))) @@ -947,6 +990,7 @@ USA. (gfile-close genum (named-lambda (close-enumerator genum* priority gcancellable* callback id) + (assert-glib-locked 'close-enumerator) (C-call "g_file_enumerator_close_async" genum* priority gcancellable* callback id)) make-enumerator-close-finish-callback @@ -956,6 +1000,7 @@ 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*))) @@ -978,7 +1023,9 @@ USA. (make-gmountop-cleanup (gio-cleanup-info gmountop))) (let ((alien (gobject-alien gmountop))) (set-alien/ctype! alien '|GMountOperation|) - (C-call "g_mount_operation_new" alien) + (with-glib-locked + (lambda () + (C-call "g_mount_operation_new" alien))) (error-if-null alien "Could not create:" gmountop))) (define (make-gmountop-cleanup gio-info) @@ -992,30 +1039,35 @@ USA. (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) (set-gio-cleanup-info-callback-id! gio-info id) id))))) - (let ((userinfo (uri-authority-userinfo (uri-authority (gfile-uri gfile))))) - (if userinfo - (if (string=? userinfo "anonymous") - (begin - (C-call "g_mount_operation_set_anonymous" alien 1) - (set-g-mount-operation-username! gmountop "anonymous")) - (begin - (C-call "g_mount_operation_set_username" alien userinfo) - (set-g-mount-operation-username! gmountop userinfo))))) - (attach-mount-signal-handlers gmountop gfile) + (with-glib-locked + (lambda () + (let ((userinfo (uri-authority-userinfo + (uri-authority (gfile-uri gfile))))) + (if userinfo + (if (string=? userinfo "anonymous") + (begin + (C-call "g_mount_operation_set_anonymous" alien 1) + (set-g-mount-operation-username! gmountop "anonymous")) + (begin + (C-call "g_mount_operation_set_username" alien userinfo) + (set-g-mount-operation-username! gmountop userinfo))))) + (attach-mount-signal-handlers gmountop gfile))) (let retry () - (C-call "g_file_mount_enclosing_volume" - (gobject-alien gfile) - (C-enum "G_MOUNT_MOUNT_NONE") - alien - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) + (with-glib-locked + (lambda () + (C-call "g_file_mount_enclosing_volume" + (gobject-alien gfile) + (C-enum "G_MOUNT_MOUNT_NONE") + alien + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) + (C-callback "async_ready") + callback-id))) (let ((value (thread-queue/dequeue! queue))) (cond ((and (equal? value "Password dialog cancelled") (g-mount-operation-ask-password-flags gmountop)) @@ -1027,9 +1079,9 @@ USA. (error (string-append (uri->string (gfile-uri gfile))":") value)) ((eq? value #t) (set-gio-cleanup-info-pending-op! gio-info #f) - (gobject-unref! gmountop) - (without-interrupts + (with-glib-locked (lambda () + (gobject-unref! gmountop) (cleanup-gio gio-info))) unspecific) (else @@ -1047,30 +1099,44 @@ USA. (if (and (memq 'ANONYMOUS-SUPPORTED flags) (prompt-for-confirmation "Login anonymously" port)) (begin - (C-call "g_mount_operation_set_anonymous" alien 1) + (with-glib-locked + (lambda () + (C-call "g_mount_operation_set_anonymous" alien 1))) (set-g-mount-operation-username! alien "anonymous"))) (if (memq 'NEED-DOMAIN flags) (let ((d (prompt-for-string* "Domain" domain port))) - (C-call "g_mount_operation_set_domain" alien d) + (with-glib-locked + (lambda () + (C-call "g_mount_operation_set_domain" alien d))) (set-g-mount-operation-domain! gmountop d))) (if (memq 'NEED-USERNAME flags) (let ((u (prompt-for-string* "Username" username port))) - (C-call "g_mount_operation_set_username" alien u) + (with-glib-locked + (lambda () + (C-call "g_mount_operation_set_username" alien 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 phrase)))) + (with-glib-locked + (lambda () + (C-call "g_mount_operation_set_password" alien phrase)))))) (if (memq 'SAVING-SUPPORTED flags) (if (prompt-for-confirmation "Save password permanently" port) - (C-call "g_mount_operation_set_password_save" alien - (C-enum "G_PASSWORD_SAVE_PERMANENTLY")) + (with-glib-locked + (lambda () + (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) - (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"))))))) + (with-glib-locked + (lambda () + (C-call "g_mount_operation_set_password_save" alien + (C-enum "G_PASSWORD_SAVE_FOR_SESSION")))) + (with-glib-locked + (lambda () + (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))) @@ -1081,6 +1147,7 @@ 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*))) @@ -1112,6 +1179,7 @@ USA. (set-g-mount-operation-username! gmountop (c-peek-cstring user)) (set-g-mount-operation-domain! gmountop (c-peek-cstring domain)) (set-g-mount-operation-ask-password-flags! gmountop new) + (assert-glib-locked 'mount-password-callback) (cond ((not old) ;; Punt, %queuing "Password dialog cancelled". (C-call "g_mount_operation_reply" (gobject-alien gmountop) @@ -1174,7 +1242,9 @@ USA. (uri (uri->string (gfile-uri gfile)))) (set-alien/ctype! alien '|GFile|) (guarantee-utf8-string uri) - (C-call "g_file_new_for_uri" alien uri) + (with-glib-locked + (lambda () + (C-call "g_file_new_for_uri" alien uri))) (error-if-null alien "Could not create:" gfile uri))) (define-class ( (constructor ())) @@ -1184,7 +1254,9 @@ USA. (call-next-method gcancel) (let ((alien (gobject-alien gcancel))) (set-alien/ctype! alien '|GCancellable|) - (C-call "g_cancellable_new" alien))) + (with-glib-locked + (lambda () + (C-call "g_cancellable_new" alien))))) (define-structure gfile-etag alien) @@ -1203,6 +1275,7 @@ USA. (if (not (alien-null? alien)) (let ((scan (copy-alien alien)) (cstr (make-alien 'uchar))) + (assert-glib-locked 'cstringv-cleanup) (let loop () (C-> scan "* uchar" cstr) (if (not (alien-null? cstr)) @@ -1225,7 +1298,7 @@ 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 a5c90dd6d..34bbf0e25 100644 --- a/src/glib/glib-main.scm +++ b/src/glib/glib-main.scm @@ -26,29 +26,43 @@ USA. (C-include "glib") +(define glib-mutex (make-thread-mutex)) + +(define-integrable (with-glib-locked thunk) + (with-thread-mutex-locked glib-mutex thunk)) + +(define-integrable (assert-glib-locked operator) + (if (not (eq? (current-thread) (thread-mutex-owner glib-mutex))) + (outf-error ";Glib not locked: "operator"\n"))) + (define (glib-start) ;; Called from glib/make.scm, from a (load-option 'Glib). - (set! hook/subprocess-wait nonblocking/subprocess-wait) - (let ((path (system-library-pathname "glib-shim.so"))) - (if (not (file-loadable? path)) (error "Glib shim not loadable."))) - (if (fix:zero? (C-call "start_glib")) - (error "Could not start Glib main loop.")) - (create-glib-thread)) + (with-glib-locked + (lambda () + (set! hook/subprocess-wait nonblocking/subprocess-wait) + (let ((path (system-library-pathname "glib-shim.so"))) + (if (not (file-loadable? path)) (error "Glib shim not loadable."))) + (if (fix:zero? (C-call "start_glib")) + (error "Could not start Glib main loop.")) + (create-glib-thread)))) (define-integrable (run-glib select-registry-handle time) + (assert-glib-locked 'run-glib) (C-call "run_glib" select-registry-handle time)) (define (maybe-yield-glib) ;; Used by callbacks that may have made threads runnable. - (if (other-running-threads?) + (assert-glib-locked 'maybe-yield-glib) + (if (runnable-threads-not-running?) (C-call "yield_glib"))) (define (stop-glib) ;; Sortof does the opposite of glib-start. - (without-interrupts + (without-interruption (lambda () (exit-glib-thread) - (C-call "stop_glib")))) + (C-call "stop_glib") + (set! hook/subprocess-wait normal/subprocess-wait)))) (define (glib-select-trace?) (C-call "glib_select_trace_p")) diff --git a/src/glib/glib-thread.scm b/src/glib/glib-thread.scm index 55bd2b30d..bed6455ae 100644 --- a/src/glib/glib-thread.scm +++ b/src/glib/glib-thread.scm @@ -25,56 +25,67 @@ USA. ;;; package: (glib thread) ;;; parent: (runtime thread) -(define glib-thread #f) - -;;; With the glib-thread always running, the runtime system should no -;;; longer use wait-for-io and thus never signal -;;; condition-type:no-thread! - -;;; GC daemons cannot be allowed to run during a callback. After-gc -;;; interrupts are currently serviced with interrupt-mask/timer-ok!, -;;; which might allow a switch to a different thread, which might -;;; return from a different callback. +;;; For an overview of the implementation and its conventions, see +;;; node "Implementation Notes" in the accompanying glib.texinfo. -;;; The Glib system's "GC cleanups" are run by glib-thread sometime -;;; after a flip. The secondary gc daemons are also run by glib-thread -;;; after some number of flips. +(define glib-thread #f) +(define glib-registry #f) ;; Number of GCs between applications of trigger-secondary-gc-daemons! (define secondary-gc-rate 100) (define (create-glib-thread) (if glib-thread (error "A Glib thread already exists.")) + (if (and enable-smp? (not glib-registry)) + (set! glib-registry (make-select-registry))) (set! glib-thread (create-thread - #f (lambda () - (let ((self (current-thread)) - (done-tick 0) - (next-secondary-tick secondary-gc-rate)) - (let glib-thread-loop () - (without-interrupts - (lambda () - (let ((gc-tick (car (gc-timestamp)))) - (if (fix:< done-tick gc-tick) - (begin - (run-glib-cleanups) - (set! done-tick gc-tick))) - (if (fix:< next-secondary-tick gc-tick) - (begin - (trigger-secondary-gc-daemons!) - (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") - (run-glib (select-registry-handle io-registry) time) - (%trace ";run-glib done at "(real-time-clock)"\n")))) - (yield-current-thread) - (glib-thread-loop)))))) + #f + (lambda () + (let ((done-tick 0) + (next-secondary-tick secondary-gc-rate)) + (let glib-thread-loop () + (with-glib-locked + (lambda () + (let ((gc-tick (car (gc-timestamp)))) + (if (fix:< done-tick gc-tick) + (begin + (run-glib-cleanups) + (set! done-tick gc-tick))) + (if (fix:< next-secondary-tick gc-tick) + (begin + (trigger-secondary-gc-daemons!) + (set! next-secondary-tick + (fix:+ gc-tick secondary-gc-rate))))) + (set-interrupt-enables! interrupt-mask/gc-ok) + (%lock) + (let ((id io-waiter)) + (set! io-waiter (%id)) + (if id + (begin + (outf-error ";"(%id)" glib-thread replacing" + " io-waiter "io-waiter"\n") + ((ucode-primitive smp-wake 1) io-waiter)))) + (let ((registry + (if enable-smp? + (begin + (copy-select-registry! io-registry glib-registry) + glib-registry) + io-registry)) + (time (or (and first-runnable-thread 0) + (and timer-records + (timer-record/time timer-records)) + -1))) + (%trace ";run-glib until "time"\n") + (%unlock) + (set-interrupt-enables! interrupt-mask/all) + (with-thread-timer-stopped + (lambda () + (run-glib (select-registry-handle registry) time))) + (set! io-waiter #f) + (%trace ";run-glib done at "(real-time-clock)"\n")))) + (yield-current-thread) + (glib-thread-loop)))))) (detach-thread glib-thread)) (define (exit-glib-thread) @@ -91,7 +102,10 @@ USA. (define (restart-glib-thread) (restart-thread glib-thread #t #f)) -(define %trace? #f) +(define (runnable-threads-not-running?) + first-runnable-thread) + +(define %trace? #t) (define-syntax %trace (syntax-rules () diff --git a/src/glib/glib.pkg b/src/glib/glib.pkg index d2b873981..48336c4b4 100644 --- a/src/glib/glib.pkg +++ b/src/glib/glib.pkg @@ -101,9 +101,16 @@ USA. (import (runtime) ucode-primitive) (import (runtime subprocess) - hook/subprocess-wait nonblocking/subprocess-wait) + hook/subprocess-wait + nonblocking/subprocess-wait + normal/subprocess-wait) (import (glib thread) - create-glib-thread exit-glib-thread) + create-glib-thread + exit-glib-thread + runnable-threads-not-running?) + (export (glib) + with-glib-locked + assert-glib-locked) (export () glib-select-trace? glib-select-trace!)) @@ -117,6 +124,8 @@ USA. (import (glib) run-glib-cleanups) (import (glib main) + glib-mutex run-glib) (import (runtime primitive-io) + copy-select-registry! select-registry-handle)) \ No newline at end of file diff --git a/src/glib/glib.scm b/src/glib/glib.scm index 23a5838f9..27daacdd7 100644 --- a/src/glib/glib.scm +++ b/src/glib/glib.scm @@ -132,13 +132,15 @@ 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 + (without-interruption (lambda () (set! glib-cleanups (cons weak-pair glib-cleanups)))) weak-pair)) (define (execute-glib-cleanup object) + (assert-glib-locked 'execute-glib-cleanup) (let ((entry (weak-assq object glib-cleanups))) (if entry (begin diff --git a/src/glib/glib.texinfo b/src/glib/glib.texinfo index 770a5b5c1..3c49555c3 100644 --- a/src/glib/glib.texinfo +++ b/src/glib/glib.texinfo @@ -26,7 +26,7 @@ @copying This manual documents @acronym{Glib} @value{VERSION}. -Copyright @copyright{} 2008, 2009, 2010, 2011, 2012, 2013, 2014 +Copyright @copyright{} 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Matthew Birkholz @quotation @@ -112,11 +112,11 @@ while Scheme holds the reference. @bref{gobject-unref!} kills it, releasing Scheme's reference. Once dead to Scheme, the toolkit may dispose and finalize the GObject. -Callbacks can be "connected" to gobjects --- one callback per signal -name. The procedures run without-interrupts (or at least -without-preemption, or perhaps just without-toolkit). -Connecting a second callback disconnects the -first. +Callbacks can be ``connected'' to gobjects --- one callback per signal +name. The callbacks run without-interrupts, without-interruption and +without-preemption in whatever thread called them. Often this is the +@code{glib-thread}, the toolkit's main loop. Connecting a second +callback disconnects the first. @anchor{pinned-objects} All connected callbacks are ``pinned'' by the @@ -128,6 +128,19 @@ toolkit resources. Thus a callback might want to avoid closing over its instance, use its first parameter to reference the instance, and have no other binding through which the instance is reachable. +Multiple threads can use glib concurrently. Currently @emph{all} +calls to the toolkit should be serialized by @code{glib-mutex}. If a +thread executes an operation without first locking the mutex, a +warning is issued. To grab the mutex for the duration of a thunk, +pass the thunk to @code{with-glib-locked}. Note that main loop +callbacks need to @emph{not} do this else they will deadlock. The +@code{glib-mutex} is already held by the @code{glib-thread} while it +runs the toolkit, including the callbacks. + +Multiple threads @emph{cannot} share the same glib objects. There is +no serialization of operations on gio ports, for example. If two +threads read from the same gio port concurrently, havoc may ensue. + @anchor{} @deffn Class The base class for all toolkit objects. @@ -210,7 +223,9 @@ The URI can specify file, http and sftp protocols (and perhaps more, depending on support in the GIO library). If an SFTP URI requires a password, Scheme's @code{call-with-pass-phrase} procedure is called. If the ports are GCed or the stack unwound, pending operations are -cancelled. Re-winding the stack is an error. +cancelled. Re-winding the stack is an error. Multiple threads can +use these procedures concurrently. Their use of the toolkit will be +serialized by @code{glib-mutex}. @deffn Procedure open-input-gfile uri Returns an input port that reads from @var{uri}. @@ -226,7 +241,8 @@ Returns a list of strings --- the names of the ``children'' of @end deffn A more direct interface to GIO's GFile operations is provided by the -following 8 classes and 18 operations. +following 8 classes and 18 operations. Their use of the toolkit will +be serialized by @code{glib-mutex}. @verbatim @@ -383,8 +399,8 @@ Lists the gfile-info attribute keys. @deffn Procedure gfile-info-get-attribute-status ginfo key Returns @code{set} if the @code{key} attribute in @code{ginfo} has -been set. Returns @code{unset} if not. Returns @code{error-setting} -if there was an error collecting the value. +been set. Returns @code{unset} if not. Returns the symbol +@code{error-setting} if there was an error collecting the value. @end deffn @deffn Procedure gfile-info-get-attribute-value ginfo key @@ -566,7 +582,7 @@ environment. This chapter is for the hapless debugger, or potential widget developer. It provides an overview of the mechanisms behind the -scenes, like gtk-thread. +scenes, like glib-thread. The procedures implementing the API are thin wrappers, trivial convenience functions that do type checking and conversion, and hide @@ -592,16 +608,130 @@ In the example call to @code{gtk-label-get-text} above, a Scheme object represents the GtkLabel. It is a gtk-label instance, whose class is a specialization of the abstract gtk-object class. -@unnumberedsec Gtk Thread +@unnumberedsec Glib Thread -When the Gtk system loads, it starts a toolkit main loop with Scheme +When the Glib system loads, it starts a toolkit main loop with Scheme attached as an custom idle task. The main loop then re-starts Scheme, which creates a thread to ``run'' the toolkit (actually, return to it). Thus Scheme threads multitask with the toolkit. Scheme runs as an idle task in the toolkit, and the toolkit runs in a Scheme thread. -A program using the Gtk system does not call @code{gtk_init} nor -@code{gtk_main}. It need only create toolkit objects and attach -signal handlers to them. +A program using the Glib system does not call @code{gtk_init} nor +@code{g_main_loop_run}. It need only create toolkit objects and +attach signal handlers to them. + +Thread safety rules are enforced by @code{assert-glib-locked} forms +placed before every @code{c-call} form. If a thread calls out to the +toolkit, it should only do so if it owns the glib-mutex. The assert +form does not signal an error, but will nag with incessant warnings +that the toolkit is being used without being locked. + +Most callbacks and all cleanups are run by the main loop and will find +the toolkit already locked. The glib-mutex is NOT recursive, but +callbacks will be keeping it short and sweet, like interrupt handlers, +and will @emph{not} be running arbitrary Scheme hooks with escaping +continuations or worse. + + + + +;;; The glib-thread grabs the glib-mutex before calling the toolkit. +;;; Callbacks thus run in glib-thread with glib-mutex locked, with the +;;; thread timer stopped???, and without-interrupts. + +;;; The after-gc interrupt must be masked (the GC daemons postponed) +;;; during a callback because after-gc is serviced with interrupt- +;;; mask/timer-ok! (why???) which might allow a switch to a different +;;; thread, which might return from a different callback. + +;;; In a single-processor world, with the glib-thread always running, +;;; there will never be an io-waiter. The blocking done in run_glib +;;; is the only blocking. The toolkit must return control when any +;;; channel upon which a thread waits is ready or when the next timer +;;; OR thread switch interval expires. Thus (a copy of) the io- +;;; registry is passed to run_glib. + +;;; In a many-processor world, though the glib-thread is always +;;; running, there is rarely no io-waiter -- not one idle processor. +;;; In such a busy world, glib-thread should only poll the toolkit and +;;; not block at all. Most frequently, an idle processor has snagged +;;; the io-waiter situation and glib-thread is + +;;; In a many-processor world, it is more likely that glib-thread will +;;; find there already is an idle processor that has become io-waiter. +;;; The io-waiter is blocked and will wake when non-toolkit i/o is +;;; available or when it is explicitly woken because the runnable +;;; queue is no longer empty. The glib-thread can thus block in the +;;; toolkit forever EXCEPT that it has locked the glib-mutex. + +;;; A less busy world can afford to have glib-thread's processor +;;; blocked for as long as its time slice and longer. Thus when there +;;; already is an io-waiter, glib-thread blocks in run_glib with an +;;; empty select registry (and a large time slice?). + +;;; Whenever run-glib returns, glib-thread releases the mutex and gets +;;; behind any threads woken by the release. Idle processors pick +;;; them up in the same order, and each thread grabs the mutex first +;;; thing, so the first added to the runnable-queue arranges for the +;;; rest to block on the mutex again. Nothing guarantees glib-thread +;;; cannot starve the others. + +;;; Something like a thread barrier is needed to keep glib-thread from +;;; picking up the mutex until after all the waiters have had it -- so +;;; that NONE of the contenders can starve the others. Thus grabbing +;;; (and blocking on) the mutex means joining a queue. Releasing the +;;; mutex means passing ownership to (and unblocking) the next in the +;;; queue. The looping glib-thread passes ownership to the next +;;; waiting thread, then grabs the mutex, blocking and getting back in +;;; the queue. When there are no threads waiting, it releases +;;; ownership and immediately(?) grabs it again. It would spin if it +;;; did not run the toolkit with a timeout of forever. + +;;; The whole world should go quiet when there are no runnable +;;; threads. Most processors should be idle (blocked forever, until +;;; signaled). One should be io-waiter and blocked forever for i/o. +;;; With glib running, another processor will be blocked forever in +;;; run_glib. That last processor should be considered idle, like +;;; io-waiter?, and woken (SIGALRMed?) when threads become runnable. + + + + + +;;; are waiting, it could loop to grab the mutex again and block +;;; forever in run_glib. Another thread on another processor would +;;; have to signal + + + may then block in run_glib until + + + grabbing the mutex means joining + + +;;; Glib-thread waits on all-quiet. + + wait until + + +;;; sleeps for a large time slice??? This helps ensure that threads +;;; waiting on the mutex have had a chance to grab it and do their +;;; thing. (Glib-thread might put itself behind any woken threads on +;;; the runnable queue, but still get picked up by an idle processor +;;; and grab the mutex before some of the waiters had their shot.) + +;;; Need glib-thread to wait until all waiters have had the mutex... +;;; ... like a thread barrier whose generations are taken from the +;;; wait list of the mutex... + +;;; when no select registry is provided, don't bother about subprocess +;;; status changes either? + +;;; The Glib system's "GC cleanups" are run by glib-thread sometime +;;; after a flip. The secondary gc daemons are also run by glib-thread +;;; after some number of flips. + + + @unnumberedsec Toolkit Resource Usage @@ -621,9 +751,8 @@ The following scenarios are typical of Gtk resource management. Temporary alien: The (alien) address of a PangoFontDescription is read from a PangoLayout member. The layout ``owns'' the -font description. Scheme does not. The address should only be used -while without-toolkit (or without-interrupts), else the -toolkit may "dispose" of it while Scheme is using it. +font description. Scheme does not. The address should be used soon. +The toolkit may ``dispose'' of it while Scheme is using it. Schemely: A toolkit object is created and reflected in Scheme by a gobject instance. Scheme owns the toolkit object, holds a reference, @@ -645,7 +774,23 @@ will not be invoked after an instance is GCed, else an error should be signaled. TODO: A world save hook might warn of gobject instances still on the -glib-cleanups list. A world restore hook could kill them. +glib-cleanups list. A world restore hook already drops them. + +@unnumberedsec GIO + +The GIO interface uses the asynchronous functions to avoid blocking a +Scheme machine. Each operation creates a thread-queue, calls an +asynchronous toolkit function, and blocks on the queue. The +callbacks for the operation pass the result value to the waiting +thread through the queue, which is then discarded. + +When a is 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 gio-cleanup-info +includes the GCancellable, the finish callback id, AND a flag to +indicate whether an operation is pending and thus whether the +GCancellable should be used. It also includes the GError pointer +which, if not null, references a GError that must be freed. @node GNU Free Documentation License, , Implementation Notes, Top @appendix GNU Free Documentation License diff --git a/src/glib/gobject.scm b/src/glib/gobject.scm index 30bc55e07..ed34ce01a 100644 --- a/src/glib/gobject.scm +++ b/src/glib/gobject.scm @@ -67,12 +67,13 @@ USA. (for-each (lambda (name.id.handle) (disconnect!? alien (cdr name.id.handle))) (cdr signals)) + (assert-glib-locked 'gobject-cleanup) (C-call "g_object_unref" alien) (alien-null! alien))) (%trace ";gobject-cleanup done with "alien"\n"))) (define (gobject-unref! object) - (without-interrupts + (without-interruption (lambda () (execute-glib-cleanup object)))) @@ -88,7 +89,8 @@ USA. (else (error:wrong-type-argument signal-name "string or symbol" 'g-signal-connect))))) - (without-interrupts + (assert-glib-locked 'g-signal-connect) + (without-interruption (lambda () (let* ((alien (gobject-alien gobject)) (signals (gobject-signals gobject)) @@ -106,7 +108,7 @@ USA. (define (make-gobject-signal-callback name weak-pair callback) (named-lambda (gobject-signal-callback instance . args) - ;; Callbacks run without-interrupts. + (assert-glib-locked 'gobject-signal-callback) (if (weak-pair/car? weak-pair) (let ((gobject (weak-car weak-pair))) (if (not (alien=? (gobject-alien gobject) instance)) @@ -115,6 +117,7 @@ USA. (error "Cannot signal a that is already GC'ed:" name args)))) (define (connect! alien name.id.handle alien-function newid) + (assert-glib-locked 'connect!) (let ((id.handle (cdr name.id.handle))) (set-car! id.handle newid) (set-cdr! id.handle @@ -125,7 +128,8 @@ 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)) @@ -139,6 +143,7 @@ USA. (if (eq? (car id.handle) #f) #f (begin + (assert-glib-locked 'disconnect!?) (C-call "g_signal_handler_disconnect" alien (cdr id.handle)) (de-register-c-callback (car id.handle)) (set-car! id.handle #f) @@ -156,6 +161,7 @@ USA. (define (unimplemented type) (error "Unimplemented property type:" type name gobject)) + (assert-glib-locked 'gobject-get-property) (C-call "g_object_get_property" (gobject-alien gobject) name gvalue) (let* ((type (C-> gvalue "GValue g_type")) (value @@ -227,6 +233,7 @@ USA. (else (let ((name (check-prop-name (car plist))) (value (cadr plist))) + (assert-glib-locked 'gobject-set-properties) (C-call "g_object_class_find_property" pspec gclass name) (if (alien-null? pspec) (error "No property:" name gclass-name)) @@ -305,17 +312,20 @@ 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) ;; GCLASS should be an alien of type GObjectClass. + (assert-glib-locked 'gobject-get-name) (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)) @@ -399,6 +409,7 @@ 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))) (hash-table/put! gquark-from-string-cache string gq) diff --git a/src/microcode/prossmp.c b/src/microcode/prossmp.c index 90f426aee..d564ff853 100644 --- a/src/microcode/prossmp.c +++ b/src/microcode/prossmp.c @@ -524,7 +524,7 @@ Wait for interrupts.") while (! ((PENDING_INTERRUPTS_P) || OS_process_any_status_change ())) { - OS_pause (); + OS_pause (true); trace (";%d SMP-Idle awoke to 0x%04x.", self->id, GET_INT_CODE); } diff --git a/src/runtime/process.scm b/src/runtime/process.scm index efdb1a943..8cb1eb2c0 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -197,11 +197,10 @@ USA. ((ucode-primitive process-wait 1) (subprocess-index process))) (define (nonblocking/subprocess-wait process) - (without-interrupts - (lambda () - (let ((status (%subprocess-status process))) - (if (eqv? status 0) - (block-on-process-status-change)))))) + (let* ((tick (subprocess-global-status-tick)) + (status (%subprocess-status process))) + (if (eqv? status 0) + (block-on-process-status-change tick)))) (define hook/subprocess-wait normal/subprocess-wait) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index e09cf2d7e..e7ca6b2bd 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3875,7 +3875,8 @@ USA. %handle-subprocess-status-change) (import (runtime thread) with-threads-locked - %signal-subprocess-status-change) + %signal-subprocess-status-change + block-on-process-status-change) (initialization (initialize-package!))) (define-package (runtime synchronous-subprocess) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 20cea287a..f740d634a 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -797,41 +797,28 @@ USA. (eq? (%current-thread (%id)) (tentry/thread tentry))) (delete-tentry! tentry))) -(define (block-on-process-status-change) - (without-interrupts - (lambda () - (let ((registration)) - (dynamic-wind - (lambda () - (let ((thread (current-thread))) - (set! registration - (%register-io-thread-event - 'PROCESS-STATUS-CHANGE - 'READ - thread - (lambda (mode) - (declare (ignore mode)) - unspecific) - #f #t))) - (%maybe-toggle-thread-timer)) +(define (block-on-process-status-change subprocess-tick) + (let* ((thread (current-thread)) + (registration (make-tentry thread (lambda (mode) + (declare (ignore mode)) + unspecific)))) + (dynamic-wind + (lambda () + (with-threads-locked (lambda () - (%suspend-current-thread)) + (%register-io-thread-event 'PROCESS-STATUS-CHANGE 'READ + registration #t) + (%maybe-toggle-thread-timer) + (%maybe-wake-io-waiter)))) + (lambda () + (%suspend-current-thread subprocess-tick) + unspecific) + (lambda () + (with-threads-locked (lambda () - (%deregister-io-thread-event registration) - (%maybe-toggle-thread-timer))))))) - -(define (register-subprocess-status-change-event event) - (guarantee-procedure-of-arity event 1 'register-subprocess-status-change-event) - (without-interrupts - (lambda () - (%register-io-thread-event - 'PROCESS-STATUS-CHANGE - 'READ - (current-thread) - event - #t ;permanent? - #f ;front? - )))) + (%maybe-deregister-io-thread-event registration) + (%maybe-toggle-thread-timer) + (%maybe-wake-io-waiter))))))) (define (permanently-register-io-thread-event descriptor mode thread event) (guarantee-select-mode mode 'permanently-register-io-thread-event)