|#
;;;; 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")
(make-gio-cleanup-info
#f #f (make-gcancellable) (make-alien '(* |GError|))))))
-;;; When a <gio> 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, <opname>, CLOSED or ERROR. The first one
; means "idle" and the last two are more
(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
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))
(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))
(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)
(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*)))
(if (not (alien-null? gerror))
(begin
(C->= pointer "* GError" 0)
+ (assert-glib-locked '%gerror-message)
(C-call "g_error_free" gerror)))
message))
(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)
(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*)))
(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
(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)))
(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)
(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*)))
(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))
(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)
(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)
(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)
(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*)))
(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
(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*)))
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
(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)
(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)
(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*)))
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
(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))))
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
(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))))
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))
(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))))
\f
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
(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*)))
(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)))
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)))
(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"))
(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))
(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)
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
(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*)))
(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)
(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)))
(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"))))
(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
(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*)))
(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)
(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))
(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
(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)))
(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*)))
(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)
(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 (<gcancellable> (constructor ()))
(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)
(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))
(cons str (loop)))))))
(define (free-cstringv alien)
- (without-interrupts
+ (without-interruption
(lambda ()
(execute-glib-cleanup alien)
(alien-null! alien))))
@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
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
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{<gobject>}
@deffn Class <gobject>
The base class for all toolkit objects.
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}.
@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
<gfile>
@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
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
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
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,
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 <gio> 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
projects / mit-scheme.git / commitdiff