From 20203a5f0897a77cad53a0c1bce532cb234f9ca9 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Fri, 15 May 2009 08:16:36 -0700
Subject: [PATCH] Fixed gtk-thread crash.  Raised pixbuf-loader interface.

* src/.gitignore:

Added exceptions for src/gtk/Clean.sh and src/gtk/Tags.sh.

* src/gtk/gobject.scm:

Wrap <pixbuf-loader>s' GdkPixbufs with a <pixbuf>, a new type of
<gobject> that will free a GdkPixbuf when it is GCed.  Provide hooks
so that users of <pixbuf-loader>s do not have to register low-level C
callbacks.  Support "late" hooking by cacheing size and pixbuf and
providing them immediately to latecomers.  (The update hook, on the
other hand, might never call.)  The close hook is run in the loader's
thread (or the latecomer's) after gdk_pixbuf_loader_close has been
closed, and any error status collected.

* src/gtk/: gobject.scm, gtk-object.scm, scm-layout.scm:

Use "cleanup" instead of "finalize" to avoid confusion with Gtk's
notion of finalization.  Assume gc-cleanups are without-interrupts.
Do NOT run gc-cleanups in a gc-daemon; run them in gtk-thread.  Added
more tracing; named more lambdas.

* src/gtk/gtk.pkg:

Declare new pixbuf-loader interface.  Rename (gtk object) package
"(gtk gtk-object)".  Punt gobject-finalize! (same as gobject-unref).
Move (gtk main) to load after (gtk gobject), so the gc-cleanup list is
initialized before gtk-thread is launched.

* src/gtk/main.scm:

Added program "name" parameter to gtk-init, to correctly (re)construct
the command line.

* src/gtk/scm-layout.scm:

Use the new pixbuf-loader hooks instead of low-level gsignals.
"%trace" -> "trace" for consistency.

* src/gtk/thread.scm:

Disable interrupts BEFORE calling out with run-gtk as now required by
the FFI.  Run gc-cleanups whenever the gc-timestamp increases.  Punt
signal-thread-events, which was trouble when run WITH interrupts.
maybe-signal-io-thread-events after run-gtk should be sufficient.

* src/gtk/thread.scm, src/runtime/thread.scm:

"tracing?" -> "trace?" for consistency.
---
 src/gtk/gobject.scm    | 225 ++++++++++++++++++++++++++---------------
 src/gtk/gtk-object.scm |  51 ++++++----
 src/gtk/gtk.pkg        |  63 ++++++------
 src/gtk/main.scm       |  39 +++----
 src/gtk/scm-layout.scm | 149 +++++++++++++--------------
 src/gtk/thread.scm     |  46 +++++----
 src/runtime/thread.scm |   6 +-
 7 files changed, 334 insertions(+), 245 deletions(-)

diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm
index 71f711ede..75fe76d63 100644
--- a/src/gtk/gobject.scm
+++ b/src/gtk/gobject.scm
@@ -36,7 +36,7 @@ USA.
   (alien define accessor
 	 initializer (lambda () (make-alien '|GObject|)))
 
-  ;; A pair, shared with finalize thunk closures.  The cdr of this
+  ;; A pair, shared with cleanup thunks.  The cdr of this
   ;; pair is the alist associating signal names with Scheme callback
   ;; IDs and toolkit handles.  In this alist, a callback ID will be #f
   ;; if the signal was disconnected.
@@ -50,36 +50,35 @@ USA.
   ;; Arrange for all gobject signal handlers to be de-registered if
   ;; GCed.  The object itself is g_object_unref'ed.
   (add-gc-cleanup object
-		  (gobject-finalize-thunk
-		   (gobject-alien object)
-		   (gobject-signals object))))
-
-(define (gobject-finalize-thunk alien signals)
-  ;; Return a thunk closed over ALIEN and SIGNALS (but not the gobject).
-  (lambda ()
-    (gobject-finalize! alien signals)))
-
-(define (gobject-finalize! alien signals)
-  ;; This is finalization from Scheme perspective, not necessarily the
-  ;; toolkit's.
-
+		  (gobject-cleanup-thunk (gobject-alien object)
+					 (gobject-signals object))))
+
+(define (gobject-cleanup-thunk alien signals)
+  ;; Return a thunk closed over ALIEN and SIGNALS (but not the
+  ;; gobject).
+  (named-lambda (gobject::cleanup-thunk)
+    (trace ";gobject::cleanup-thunk "alien"\n")
+    (gobject-cleanup alien signals)
+    (trace ";gobject::cleanup-thunk done with "alien"\n")))
+
+(define (gobject-cleanup alien signals)
+  ;; Run as a gc-cleanup, without-interrupts.  Calls g_object_unref
+  ;; (if necessary), and de-registers the Scheme signal handlers.
+  (trace ";gobject::cleanup "alien"\n")
   (if (not (alien-null? alien))
       (begin
 	(C-call "g_object_unref" alien)
 	(alien-null! alien)))
-
   (for-each (lambda (name.id.handle)
-	      (let ((id.handle (cdr name.id.handle)))
-		;; Hacking this ID.HANDLE pair atomically.
-		(without-interrupts
-		 (lambda ()
-		   (let ((id (car id.handle)))
-		     (if id
-			 (begin
-			   (de-register-c-callback id)
-			   (set-car! id.handle #f)
-			   (set-cdr! id.handle #f))))))))
-	    (cdr signals)))
+	      (let* ((id.handle (cdr name.id.handle))
+		     (id (car id.handle)))
+		(if id
+		    (begin
+		      (de-register-c-callback id)
+		      (set-car! id.handle #f)
+		      (set-cdr! id.handle #f)))))
+	    (cdr signals))
+  (trace ";gobject::cleanup done with "alien"\n"))
 
 (define (gobject-unref object)
   ;; Calls g_object_unref to release Scheme's reference to the toolkit
@@ -87,9 +86,9 @@ USA.
   ;; called once (per wrapper object).
   (without-interrupts
    (lambda ()
-     (gobject-finalize! (gobject-alien object) (gobject-signals object)))))
+     (gobject-cleanup (gobject-alien object) (gobject-signals object)))))
 
-(define (g-signal-connect object alien-function closure)
+(define (g-signal-connect object alien-function handler)
   ;; Allocate a callback and connect it with g_signal_connect_...  The
   ;; signal name is assumed to be the same as ALIEN-FUNCTION's name,
   ;; e.g.  in
@@ -114,7 +113,7 @@ USA.
      (lambda ()
        (let ((id (car id.handle)))
 	 (if (not id)
-	     (let ((newid (register-c-callback closure)))
+	     (let ((newid (register-c-callback handler)))
 	       (set-car! id.handle newid)
 	       (set-cdr! id.handle
 			 (C-call "g_signal_connect_data"
@@ -166,13 +165,18 @@ USA.
 ;;; check first for a nulled alien before freeing a resource, and null
 ;;; that alien without interrupts after the resource is freed.
 
-(define gc-cleanups '())
+;;; These cleanups are run by the gtk-thread, for easy error handling.
+;;; They are rather complex to run at after-gc interrupt level (as
+;;; gc-daemons).  They callout and thus may run callbacks that run
+;;; callouts...
+
+(define gc-cleanups)
 
 (define (initialize-gc-cleanups!)
-  (set! gc-cleanups '())
-  (add-gc-daemon! run-gc-cleanups))
+  (set! gc-cleanups '()))
 
 (define (run-gc-cleanups)
+  (trace ";run-gc-cleanups\n")
   (let loop ((alist gc-cleanups)
 	     (prev #f))
     (if (pair? alist)
@@ -184,7 +188,8 @@ USA.
 	      (if prev
 		  (set-cdr! prev next)
 		  (set! gc-cleanups next))
-	      (loop next prev))))))
+	      (loop next prev)))))
+  (trace ";run-gc-cleanups done\n"))
 
 (define (reset-gc-cleanups!)
   (set! gc-cleanups '()))
@@ -489,56 +494,79 @@ USA.
      (<gobject>)
   (port define standard initial-value #f)
   (thread define standard initial-value #f)
+  (size define standard initial-value #f)
+  (pixbuf define standard initial-value #f)
   (error-message define standard initial-value #f)
-  (pixbuf define standard initializer (lambda () (make-alien '|GdkPixbuf|))))
+  (closed? define standard initial-value #f)
+  (size-hook define standard initial-value #f
+	     modifier %set-pixbuf-loader-size-hook!)
+  (pixbuf-hook define standard initial-value #f
+	       modifier %set-pixbuf-loader-pixbuf-hook!)
+  (update-hook define standard initial-value #f)
+  (close-hook define standard initial-value #f
+	      modifier %set-pixbuf-loader-close-hook!))
+
+(define-class (<pixbuf> (constructor ()))
+    (<gobject>))
+
+(define-method initialize-instance ((pixbuf <pixbuf>))
+  (call-next-method pixbuf)
+  (set-alien/ctype! (gobject-alien pixbuf) '|GdkPixbuf|))
 
 (define-method initialize-instance ((loader <pixbuf-loader>))
   (call-next-method loader)
-  (add-gc-cleanup loader (pixbuf-loader-finalize-thunk
-			  (pixbuf-loader-pixbuf loader)))
   (C-call "gdk_pixbuf_loader_new" (gobject-alien loader))
+  (g-signal-connect loader (C-callback "size_prepared")
+		    (pixbuf-loader-size-prepared loader))
   (g-signal-connect loader (C-callback "area_prepared")
-		    (pixbuf-loader-area-prepared loader)))
-
-(define (pixbuf-loader-finalize-thunk pixbuf-alien)
-  (named-lambda (pixbuf-loader::finalize-thunk)
-
-    (if (not (alien-null? pixbuf-alien))
-	(begin
-	  (C-call "g_object_unref" pixbuf-alien)
-	  (alien-null! pixbuf-alien)))
-    ;; Signals finalized by initialize-instance(<gobject>...) method's
-    ;; gc-cleanup.
-    ))
+		    (pixbuf-loader-area-prepared loader))
+  (g-signal-connect loader (C-callback "area_updated")
+		    (pixbuf-loader-area-updated loader)))
+
+(define (pixbuf-loader-size-prepared loader)
+  (named-lambda (pixbuf-loader::size-prepared GdkPixbufLoader width height)
+    GdkPixbufLoader ;;Ignored.
+    (trace "; pixbuf-loader::size-prepared "loader" "width" "height"\n")
+    (let ((size (pixbuf-loader-size loader)))
+      (if size (ferror loader" already has a size: "(car size)"x"(cdr size)))
+      (set-pixbuf-loader-size! loader (cons width height))
+      (let ((receiver (pixbuf-loader-size-hook loader)))
+	(if receiver (receiver width height))))))
 
 (define (pixbuf-loader-area-prepared loader)
   (named-lambda (pixbuf-loader::area-prepared GdkPixbufLoader)
-
-    (let ((pixbuf (pixbuf-loader-pixbuf loader)))
-      (C-call "gdk_pixbuf_loader_get_pixbuf" pixbuf GdkPixbufLoader)
-      (C-call "g_object_ref" pixbuf))))
-
-(define-integrable (pixbuf-loader-started? loader)
-  (not (eq? #f (pixbuf-loader-port loader))))
-
-(define-integrable (pixbuf-loader-done? loader)
-  (let ((port (pixbuf-loader-port loader)))
-    (and port (not (port/input-open? port)))))
+    (trace "; pixbuf-loader::area-prepared "loader"\n")
+    (let* ((pixbuf (let ((p (pixbuf-loader-pixbuf loader)))
+		     (if p
+			 (ferror loader" already has a pixbuf: "p)
+			 (make-pixbuf))))
+	   (alien (gobject-alien pixbuf)))
+      (C-call "gdk_pixbuf_loader_get_pixbuf" alien GdkPixbufLoader)
+      (C-call "g_object_ref" #f alien)
+      (set-pixbuf-loader-pixbuf! loader pixbuf)
+      (let ((receiver (pixbuf-loader-pixbuf-hook loader)))
+	(if receiver (receiver pixbuf))))))
+
+(define (pixbuf-loader-area-updated loader)
+  (named-lambda (pixbuf-loader::area-updated  GdkPixbufLoader x y width height)
+    GdkPixbufLoader ;;Ignored.
+    (let ((rect (make-rect x y width height)))
+      (trace "; pixbuf-loader::area-updated "loader" "rect"\n")
+      (let ((receiver (pixbuf-loader-update-hook loader)))
+	(if receiver (receiver rect))))))
 
 (define (start-pixbuf-loader loader input-port)
   (without-interrupts
    (lambda ()
-     (if (pixbuf-loader-started? loader)
-	 (if (pixbuf-loader-done? loader)
-	     (ferror loader" is already finished.")
-	     (ferror loader" has already started.")))
-     (set-pixbuf-loader-port! loader input-port)))
-  (set-pixbuf-loader-thread!
-   loader (create-pixbuf-loader-thread loader)))
+     (if (pixbuf-loader-port loader)
+	 (ferror loader" has already started."))
+     (set-pixbuf-loader-port! loader input-port)
+     (set-pixbuf-loader-thread! loader (create-pixbuf-loader-thread loader)))))
 
 (define (create-pixbuf-loader-thread loader)
   (create-thread
    #f (lambda ()
+	(trace "; "loader" started in "(current-thread)"\n")
 	(let ((port (pixbuf-loader-port loader))
 	      (alien (gobject-alien loader))
 	      (GError-ptr (malloc (C-sizeof "*") '(* |GError|)))
@@ -546,39 +574,74 @@ USA.
 	  (C->= GError-ptr "* GError" 0)
 	  (let ((buff-address (external-string-descriptor buff)))
 
+	    (define (note-done)
+	      (without-interrupts
+	       (lambda ()
+		 (set-pixbuf-loader-closed?! loader #t)
+		 (close-input-port port)
+		 (trace "; "loader" closed by "(current-thread)"\n")
+		 (let ((proc (pixbuf-loader-close-hook loader)))
+		   (if proc
+		       (proc loader))))))
+
 	    (define (note-error)
 	      (let* ((GError (C-> GError-ptr "*" (make-alien '|GError|)))
-		     (message (and (not (alien-null? GError))
-				   (c-peek-cstring
-				    (C-> GError "GError message")))))
-		(set-pixbuf-loader-error-message!
-		 loader (or message "Bogus GError address."))
+		     (message (or (and (not (alien-null? GError))
+				       (c-peek-cstring
+					(C-> GError "GError message")))
+				  "GError not set.")))
+		(set-pixbuf-loader-error-message! loader message)
 		(C-call "g_error_free" GError)
-		(free GError-ptr)))
+		(free GError-ptr)
+		(note-done)))
 
 	    (let loop ()
 	      (let ((n (input-port/read-string! port buff)))
-		;; Adaptively grow the buff if n == 4200?
 		(cond ((and (fix:zero? n) (eof-object? (peek-char port)))
-		       (if (fix:zero?
-			    (C-call "gdk_pixbuf_loader_close" alien GError-ptr))
+		       (if (fix:zero? (C-call "gdk_pixbuf_loader_close"
+					      alien GError-ptr))
 			   (note-error)
-			   (close-input-port port))
-		       ;; (gobject-unref loader)  Need to ref the pixbuf first!
-		       unspecific)
+			   (note-done)))
 		      ((not (fix:zero?
 			     (C-call "gdk_pixbuf_loader_write"
 				     alien buff-address n GError-ptr)))
 		       (loop))
 		      (else
-		       (note-error)
-		       unspecific)))))))))
+		       (note-error))))))))))
 
 (define (load-pixbuf-from-file loader filename)
   (start-pixbuf-loader
    loader (open-binary-input-file (->namestring (->truename filename)))))
 
+(define (set-pixbuf-loader-size-hook! loader receiver)
+  (without-interrupts
+   (lambda ()
+     (%set-pixbuf-loader-size-hook! loader receiver)
+     (let ((size (pixbuf-loader-size loader)))
+       (if size (receiver (car size) (cdr size)))))))
+
+(define (set-pixbuf-loader-pixbuf-hook! loader receiver)
+  (without-interrupts
+   (lambda ()
+     (%set-pixbuf-loader-pixbuf-hook! loader receiver)
+     (let ((pixbuf (pixbuf-loader-pixbuf loader)))
+       (if pixbuf (receiver pixbuf))))))
+
+(define (set-pixbuf-loader-close-hook! loader thunk)
+  (without-interrupts
+   (lambda ()
+     (%set-pixbuf-loader-close-hook! loader thunk)
+     (if (pixbuf-loader-closed? loader)
+	 (thunk)))))
+
 (define (initialize-package!)
+  (initialize-gc-cleanups!)
   (add-event-receiver! event:after-restore reset-quark-cache!)
   (add-event-receiver! event:after-restore reset-gc-cleanups!)
-  unspecific)
\ No newline at end of file
+  unspecific)
+
+(define trace? #f)
+
+(define-syntax trace
+  (syntax-rules ()
+    ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
diff --git a/src/gtk/gtk-object.scm b/src/gtk/gtk-object.scm
index 16f4268d0..ba7f0302d 100644
--- a/src/gtk/gtk-object.scm
+++ b/src/gtk/gtk-object.scm
@@ -24,7 +24,7 @@ USA.
 |#
 
 ;;;; GtkObjects/GtkWidgets/GtkContainers
-;;; package: (gtk object)
+;;; package: (gtk gtk-object)
 
 
 (c-include "gtk")
@@ -35,35 +35,42 @@ USA.
 (define-method initialize-instance ((object <gtk-object>))
   ;; Arrange for all gtk-objects to be destroyed by gtk_object_destroy
   ;; when GCed.  Does NOT chain (further) up; gtk-object-cleanup is
-  ;; sufficient.  g_object_unref probably should NOT be called!
+  ;; sufficient.
   (add-gc-cleanup object
-		  (gtk-object-cleanup-thunk
-		   (gobject-alien object)
-		   (gobject-signals object))))
+		  (gtk-object-cleanup-thunk (gobject-alien object)
+					    (gobject-signals object))))
 
 (define (gtk-object-cleanup-thunk alien signals)
   ;; Return a thunk closed over ALIEN and SIGNALS (but not the gtk-object).
- (lambda ()
-   (gtk-object-cleanup alien signals)))
+  (named-lambda (gtk-object::cleanup-thunk)
+    (trace ";gtk-object::cleanup-thunk "alien"\n")
+    (gtk-object-cleanup alien signals)
+    (trace ";gtk-object::cleanup-thunk done with "alien"\n")))
 
 (define (gtk-object-cleanup alien signals)
-  (without-interrupts
-   (lambda ()
-     (if (not (alien-null? alien))
-	 (begin
-	   (C-call "gtk_object_destroy" alien)
-	   (alien-null! alien)))))
+  ;; Run as a gc-cleanup, without-interrupts.  Calls
+  ;; gtk_object_destroy (if necessary), and de-registers the Scheme
+  ;; signal handlers.
+  (trace ";gtk-object::cleanup "alien"\n")
+  (if (not (alien-null? alien))
+      (begin
+	(C-call "gtk_object_destroy" alien)
+	(alien-null! alien)))
   ;; De-register signals.  Nulled alien will not be g_object_unrefed.
-  (gobject-finalize! alien signals))
+  (gobject-cleanup alien signals)
+  (trace ";gtk-object::cleanup done with "alien"\n"))
 
 (define-generic gtk-object-destroy (object))
 
 (define-method gtk-object-destroy ((object <gtk-object>))
   ;; Calls gtk_object_destroy and sets the destroyed? flag.
-  (if (not (gtk-object-destroyed? object))
-      (begin
-	(set-gtk-object-destroyed?! object #t)
-	(gtk-object-cleanup (gobject-alien object) (gobject-signals object)))))
+  (without-interrupts
+   (lambda ()
+     (if (not (gtk-object-destroyed? object))
+	 (begin
+	   (set-gtk-object-destroyed?! object #t)
+	   (gtk-object-cleanup
+	    (gobject-alien object) (gobject-signals object)))))))
 
 
 ;;;; GtkAdjustments
@@ -323,4 +330,10 @@ USA.
   (C-call "gtk_window_set_title" (gobject-alien window) string))
 
 (define (gtk-window-set-default-size window width height)
-  (C-call "gtk_window_set_default_size" (gobject-alien window) width height))
\ No newline at end of file
+  (C-call "gtk_window_set_default_size" (gobject-alien window) width height))
+
+(define trace? #f)
+
+(define-syntax trace
+  (syntax-rules ()
+    ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index f2c604997..957ee35e9 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -12,43 +12,24 @@ Gtk System Packaging |#
   (parent ())
   (files "gtk"))
 
-(define-package (gtk main)
-  (parent (gtk))
-  (files "main")
-  (import (runtime load)
-	  *unused-command-line*
-	  hook/process-command-line
-	  default/process-command-line)
-  (export (gtk)
-	  gtk-time-slice-window?
-	  gtk-time-slice-window!
-	  gtk-select-trace?
-	  gtk-select-trace!)
-  (initialization (initialize-package!)))
-
-(define-package (gtk thread)
-  (parent (runtime thread))
-  (files "thread")
-  (export (gtk)
-	  create-gtk-thread
-	  kill-gtk-thread)
-  (import (runtime primitive-io)
-	  select-registry-handle))
-
 (define-package (gtk gobject)
   (parent (gtk))
   (files "gobject")
   (export (gtk)
 	  <gobject> gobject-alien
-	  gobject-unref gobject-finalized? gobject-finalize!
+	  gobject-unref gobject-finalized?
 	  g-signal-connect g-signal-disconnect add-gc-cleanup
 	  gobject-get-property gobject-set-properties
 	  gquark-from-string gquark-to-string
 	  <pixbuf-loader> make-pixbuf-loader load-pixbuf-from-file
-	  pixbuf-loader-started? pixbuf-loader-done?)
+	  pixbuf-loader-size-hook set-pixbuf-loader-size-hook!
+	  pixbuf-loader-pixbuf-hook set-pixbuf-loader-pixbuf-hook!
+	  pixbuf-loader-update-hook set-pixbuf-loader-update-hook!
+	  pixbuf-loader-close-hook set-pixbuf-loader-close-hook!
+	  pixbuf-loader-pixbuf pixbuf-loader-error-message)
   (initialization (initialize-package!)))
 
-(define-package (gtk object)
+(define-package (gtk gtk-object)
   (parent (gtk))
   (files "gtk-object")
   (export (gtk)
@@ -70,7 +51,7 @@ Gtk System Packaging |#
 	  pango-font-families pango-context-list-families
 	  pango-font-family-get-name pango-font-family-is-monospace?
 	  pango-font-family-faces pango-font-face-get-name)
-  (import (gtk gobject) gobject-finalize! gobject-signals))
+  (import (gtk gobject) gobject-cleanup gobject-signals))
 
 (define-package (gtk widget)
   (parent (gtk))
@@ -107,10 +88,32 @@ Gtk System Packaging |#
 	  text-item? text-item-xy-to-index
 	  call-with-text-item-grapheme-rect
 
-	  <image-item> add-image-item-from-file
+	  <image-item> add-image-item-from-file))
 
-	  image-item-area-updated image-item-area-prepared
-	  image-item-size-prepared))
+(define-package (gtk thread)
+  (parent (runtime thread))
+  (files "thread")
+  (export (gtk)
+	  create-gtk-thread
+	  kill-gtk-thread)
+  (import (gtk gobject)
+	  run-gc-cleanups)
+  (import (runtime primitive-io)
+	  select-registry-handle))
+
+(define-package (gtk main)
+  (parent (gtk))
+  (files "main")
+  (import (runtime load)
+	  *unused-command-line*
+	  hook/process-command-line
+	  default/process-command-line)
+  (export (gtk)
+	  gtk-time-slice-window?
+	  gtk-time-slice-window!
+	  gtk-select-trace?
+	  gtk-select-trace!)
+  (initialization (initialize-package!)))
 
 (define-package (gtk event-viewer)
   (parent (gtk))
diff --git a/src/gtk/main.scm b/src/gtk/main.scm
index 292fecc3d..ec7ac3d77 100644
--- a/src/gtk/main.scm
+++ b/src/gtk/main.scm
@@ -36,15 +36,18 @@ USA.
      (apply make-primitive-procedure (cdr form)))))
 
 (define (initialize-package!)
-  (let ((processor hook/process-command-line))
-    (set! hook/process-command-line
-	  (lambda (line)
-	    (processor (list->vector (gtk-init (vector->list line))))
-	    (gtk-main+))))
-  (gtk-init *unused-command-line*)
+  (let ((program-name ((ucode-primitive scheme-program-name 0))))
+    (let ((processor hook/process-command-line))
+      (set! hook/process-command-line
+	    (lambda (line)
+	      (processor
+	       (list->vector
+		(gtk-init program-name (vector->list line))))
+	      (gtk-main+))))
+    (gtk-init program-name *unused-command-line*))
   (gtk-main+))
 
-(define (gtk-init args)
+(define (gtk-init name args)
   ;; Call gtk_init_check.  Signals an error if gtk_init_check returns 0.
   ;; Returns a list of unused ARGS.
   (let ((arg-count (guarantee-list-of-type->length
@@ -52,24 +55,26 @@ USA.
 		    'GTK-INIT))
 	(vars-size (+ (C-sizeof "int")		;gtk_init_check return var
 		      (C-sizeof "* * char"))))	;gtk_init_check return var
-    (let* ((vector-size
-	    (* (C-sizeof "* char") (+ arg-count 1))) ; null terminated vector
+    (guarantee-string name 'GTK-INIT)
+    (let* ((words (cons name args))
+	   (vector-size
+	    (* (C-sizeof "* char") (+ 1 arg-count)))
 	   (total-size
 	    (+ vars-size vector-size
 	       (fold-left (lambda (sum arg)
 			    (+ sum (string-length arg) 1)) ;null terminated
-			  0 args)))
+			  0 words)))
 	   (bytes (malloc total-size #f))
 	   (vector (alien-byte-increment bytes vars-size))
-	   (arg-scan (alien-byte-increment vector vector-size))
+	   (word-scan (alien-byte-increment vector vector-size))
 	   (vector-scan (copy-alien vector))
 	   (count-var bytes)
 	   (vector-var (alien-byte-increment count-var (C-sizeof "int"))))
-      (for-each (lambda (arg)
-		  (c-poke-pointer! vector-scan arg-scan)
-		  (c-poke-string! arg-scan arg))
-		args)
-      (C->= count-var "int" arg-count)
+      (for-each (lambda (word)
+		  (c-poke-pointer! vector-scan word-scan)
+		  (c-poke-string! word-scan word))
+		words)
+      (C->= count-var "int" (+ 1 arg-count))
       (C->= vector-var "* * char" vector)
       (if (fix:zero? (C-call "gtk_init_check" count-var vector-var))
 	  (error "Could not initialize Gtk.")
@@ -82,7 +87,7 @@ USA.
 			       (cons (c-peek-cstringp! vector-scan) args))
 			 (reverse! args)))))
 	      (free bytes)
-	      new-args))))))
+	      (cdr new-args)))))))
 
 (define (gtk-main+)
   ;; Establishes a GMainLoop in which scheme is an idle task.  
diff --git a/src/gtk/scm-layout.scm b/src/gtk/scm-layout.scm
index b0ce10865..451183184 100644
--- a/src/gtk/scm-layout.scm
+++ b/src/gtk/scm-layout.scm
@@ -26,8 +26,6 @@ USA.
 ;;;; A <scm-widget> implementing a scrollable GtkDrawingArea-like widget.
 ;;; package: (gtk layout)
 
-(declare (usual-integrations))
-
 
 (c-include "gtk")
 
@@ -146,7 +144,7 @@ USA.
   (named-lambda (scm-layout::size-request GtkWidget GtkRequisition)
     GtkWidget ;;Ignored.
 
-;;;    (%trace ";((scm-layout-size-request "widget") "GtkWidget" "
+;;;    (trace ";((scm-layout-size-request "widget") "GtkWidget" "
 ;;;	    GtkRequisition")\n")
 
     (let ((alien (gobject-alien widget)))
@@ -154,13 +152,13 @@ USA.
 	    (height(C-> alien "GtkWidget requisition height")))
 	(C->= GtkRequisition "GtkRequisition width" width)
 	(C->= GtkRequisition "GtkRequisition height" height)
-	(%trace "; Requisition: "widget"x"height" from "widget"\n")
+	(trace "; Requisition: "widget"x"height" from "widget"\n")
 	))))
 
 (define (scm-layout-size-allocate widget)
   (named-lambda (scm-layout::size-allocate GtkWidget GtkAllocation)
 
-;;;    (%trace ";((scm-layout-size-allocate "widget") "GtkWidget" "GtkAllocation")\n")
+;;;    (trace ";((scm-layout-size-allocate "widget") "GtkWidget" "GtkAllocation")\n")
 
     (let ((x (C-> GtkAllocation "GtkAllocation x"))
 	  (y (C-> GtkAllocation "GtkAllocation y"))
@@ -168,7 +166,7 @@ USA.
 	  (height (C-> GtkAllocation "GtkAllocation height"))
 	  (rect (scm-layout-geometry widget)))
       (set-rect! rect x y width height)
-      (%trace "; Allocation: "rect" to "widget"\n")
+      (trace "; Allocation: "rect" to "widget"\n")
       (set-rect-size! (scm-layout-on-screen-area widget) width height)
       ;; For the random toolkit GtkWidget method.
       (C->= GtkWidget "GtkWidget allocation x" x)
@@ -184,7 +182,7 @@ USA.
 (define (scm-layout-realize widget)
   (named-lambda (scm-layout::realize GtkWidget)
 
-;;;    (%trace ";((scm-layout-realize "widget") "GtkWidget")\n")
+;;;    (trace ";((scm-layout-realize "widget") "GtkWidget")\n")
 
     ;; ScmWidget automatically sets GTK_REALIZED.
 
@@ -193,7 +191,11 @@ USA.
 	  (GtkStyle (C-> GtkWidget "GtkWidget style"))
 	  (parent-GdkWindow (make-alien '|GdkWindow|))
 	  (GdkVisual (make-alien '|GdkVisual|))
-	  (GdkColormap (make-alien '|GdkColormap|)))
+	  (GdkColormap (make-alien '|GdkColormap|))
+	  (check-!null (lambda (alien message)
+			 (if (alien-null? alien)
+			     (ferror "scm-layout: "message)
+			     alien))))
 
       ;; Create widget window.
 
@@ -223,7 +225,7 @@ USA.
       (check-!null main-GdkWindow "Could not create main window.")
       (C->= GtkWidget "GtkWidget window" main-GdkWindow)
       (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget)
-      (%trace "; Realize "widget" on "main-GdkWindow"\n")
+      (trace "; Realize "widget" on "main-GdkWindow"\n")
 
       ;; Style
 
@@ -237,7 +239,7 @@ USA.
 (define (scm-layout-event widget)
   (named-lambda (scm-layout::event GtkWidget GdkEvent)
     GtkWidget widget ;;Ignored, thus far.
-;;;    (%trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n")
+;;;    (trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n")
 
     (let ((type (C-> GdkEvent "GdkEvent any type")))
 
@@ -251,13 +253,13 @@ USA.
 		   (drawing (scm-layout-drawing widget))
 		   (widget-window (scm-layout-window widget)))
 	       (cond ((not (alien=? window widget-window))
-		      (%trace "; Expose a strange window "window
+		      (trace "; Expose a strange window "window
 			      " (not "widget-window").\n"))
 		     (drawing
 		      (let* ((scroll (scm-layout-on-screen-area widget))
 			     (offx (rect-x scroll))
 			     (offy (rect-y scroll)))
-			(%trace "; Expose area "widget"x"height"+"x"+"y
+			(trace "; Expose area "width"x"height"+"x"+"y
 				" of "widget".\n")
 			(drawing-expose drawing widget window
 					(make-rect (int:+ x offx) (int:+ y offy)
@@ -267,7 +269,7 @@ USA.
 	     (let ((name (C-enum "GdkEventType" type))
 		   (addr (alien/address-string
 			  (C-> GdkEvent "GdkEvent any window"))))
-	       (%trace "; "name" on "GtkWidget" (window 0x"addr").\n")))))
+	       (trace "; "name" on "GtkWidget" (window 0x"addr").\n")))))
     1 ;;TRUE -- "handled" -- done.
     ))
 
@@ -276,11 +278,11 @@ USA.
 		 GtkWidget hGtkAdjustment vGtkAdjustment)
     GtkWidget ;;Ignored.
 
-;;;    (%trace ";((scm-layout-set-scroll-adjustments "widget")"
+;;;    (trace ";((scm-layout-set-scroll-adjustments "widget")"
 ;;;	    " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n")
     (let ((haddr (alien/address-string hGtkAdjustment))
 	  (vaddr (alien/address-string vGtkAdjustment)))
-      (%trace "; Adjustments: 0x"haddr" 0x"vaddr"\n"))
+      (trace "; Adjustments: 0x"haddr" 0x"vaddr"\n"))
     (connect-adjustment (scm-layout-hadjustment widget) hGtkAdjustment
 			widget set-scm-layout-hadjustment!)
     (connect-adjustment (scm-layout-vadjustment widget) vGtkAdjustment
@@ -315,7 +317,7 @@ USA.
   (named-lambda (scm-layout::adjustment-value-changed GtkAdjustment)
     GtkAdjustment ;;Ignored.
 
-;;;    (%trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")"
+;;;    (trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")"
 ;;;	    " "GtkAdjustment")\n")
 
     (let ((alien-widget (gobject-alien widget))
@@ -329,7 +331,7 @@ USA.
 	(cond ((eq? adjustment vadjustment)
 	       (let* ((y (rect-y window-area))
 		      (dy (int:- value y)))
-		 (%trace "; Vadjustment to "value" (dy:"dy")\n")
+		 (trace "; Vadjustment to "value" (dy:"dy")\n")
 		 (if (not (int:zero? dy))
 		     (let ((width (rect-width window-area)))
 		       (set-rect-y! window-area value)
@@ -345,7 +347,7 @@ USA.
 	       (let* ((x (rect-x window-area))
 		      (height (rect-height window-area))
 		      (dx (int:- value x)))
-		 (%trace "; Hadjustment to "value" (dx:"dx")\n")
+		 (trace "; Hadjustment to "value" (dx:"dx")\n")
 		 (if (not (int:zero? dx))
 		     (begin
 		       (set-rect-x! window-area value)
@@ -407,7 +409,7 @@ USA.
 (define (drawing-damage item #!optional rect)
   ;; Invalidates any widget areas affected by RECT in ITEM.  By
   ;; default, RECT is ITEM's entire area.
-;;;  (%trace ";(drawing-damage "drawing" "item")\n")
+;;;  (trace ";(drawing-damage "drawing" "item")\n")
 
   (let ((area (if (default-object? rect)
 		  (drawn-item-area item)
@@ -573,7 +575,7 @@ USA.
 
 (define-method drawn-item-expose ((item <box-item>) widget window area)
   area ;;Ignored.  Assumed clipping already set.
-;;;  (%trace "; (Re)Drawing "item" on "widget".\n")
+;;;  (trace "; (Re)Drawing "item" on "widget".\n")
 
   (let ((widgets (drawn-item-widgets item)))
     (if (or (eq? #f widgets)
@@ -635,7 +637,7 @@ USA.
 
 (define-method drawn-item-expose ((item <hline-item>) widget window area)
   area ;;Ignored.  Assumed clipping already set.
-;;;  (%trace "; (Re)Drawing "item" on "widget".\n")
+;;;  (trace "; (Re)Drawing "item" on "widget".\n")
 
   (let ((widgets (drawn-item-widgets item)))
     (if (or (eq? #f widgets)
@@ -668,7 +670,7 @@ USA.
 
 (define-method drawn-item-expose ((item <vline-item>) widget window area)
   area ;;Ignored.  Assumed clipping already set.
-;;;  (%trace "; (Re)Drawing "item" on "widget".\n")
+;;;  (trace "; (Re)Drawing "item" on "widget".\n")
 
   (let ((widgets (drawn-item-widgets item)))
     (if (or (eq? #f widgets)
@@ -710,19 +712,22 @@ USA.
 (define-method initialize-instance ((item <text-item>) where)
   (call-next-method item where)
   (add-gc-cleanup item
-		  (text-item-finalize-thunk (text-item-pango-layout item))))
+		  (text-item-cleanup-thunk (text-item-pango-layout item))))
 
-(define (text-item-finalize-thunk pango-layout)
-  ;; Return a thunk closed over PANGO-LAYOUT (NOT the item).
-  (lambda ()
+(define (text-item-cleanup-thunk pango-layout)
+  ;; Return a thunk closed over PANGO-LAYOUT (but not the item).
+  ;; Thunk is run as a gc-cleanup, without-interrupts.
+  (named-lambda (text-item::cleanup-thunk)
+    (trace ";text-item::cleanup-thunk "pango-layout"\n")
     (if (not (alien-null? pango-layout))
 	(begin
 	  (C-call "g_object_unref" pango-layout)
-	  (alien-null! pango-layout)))))
+	  (alien-null! pango-layout)))
+    (trace ";text-item::cleanup-thunk done with "pango-layout"\n")))
 
 (define-method drawn-item-expose ((item <text-item>) widget window area)
   area ;;Ignored.  Assumed clipping already set.
-;;;  (%trace "; (Re)Drawing "item" on "widget".\n")
+;;;  (trace "; (Re)Drawing "item" on "widget".\n")
 
   (let ((widgets (drawn-item-widgets item)))
     (if (or (eq? #f widgets)
@@ -805,56 +810,57 @@ USA.
 
 (define-class (<image-item> (constructor add-image-item (drawing) 1))
     (<drawn-item>)
-  (pixbuf-loader define accessor
-		 initializer make-pixbuf-loader)
-  (pixbuf define standard initial-value #f))
+  ;; This slot is set to a <pixbuf> soon after loading has begun.
+  (pixbuf define standard initial-value #f)
+  ;; This slot is set to #f when the pixbuf has been successfully loaded.
+  (loader define standard initializer make-pixbuf-loader))
 
 (define-method initialize-instance ((item <image-item>) where)
   (call-next-method item where)
-  (let ((loader (image-item-pixbuf-loader item)))
-    (g-signal-connect loader (C-callback "size_prepared")
-		      (image-item-size-prepared item))
-    (g-signal-connect loader (C-callback "area_prepared")
-		      (image-item-area-prepared item))
-    (g-signal-connect loader (C-callback "area_updated")
-		      (image-item-area-updated item))))
+  (let ((loader (image-item-loader item)))
+    (set-pixbuf-loader-size-hook! loader (image-item-size-prepared item))
+    (set-pixbuf-loader-pixbuf-hook! loader (image-item-pixbuf-prepared item))
+    (set-pixbuf-loader-update-hook! loader (image-item-pixbuf-updated item))
+    (set-pixbuf-loader-close-hook! loader (image-item-pixbuf-loaded item))))
 
 (define (image-item-size-prepared item)
-  (named-lambda (image-item::size-prepared GdkPixbufLoader width height)
-    GdkPixbufLoader ;;Ignored.
-    (%trace "; image-item::size-prepared "item" "width" "height"\n")
-
+  (named-lambda (image-item::size-prepared width height)
+    (trace "; image-item::size-prepared "item" "width" "height"\n")
     (%set-drawn-item-size! item width height)))
 
-(define (image-item-area-prepared item)
-  (named-lambda (image-item::area-prepared GdkPixbufLoader)
-    GdkPixbufLoader ;;Ignored.
-
-    (let ((loader (image-item-pixbuf-loader item))
-	  (pixbuf (if (not (image-item-pixbuf item))
-		      (let ((a (make-alien '|GdkPixbuf|)))
-			(set-image-item-pixbuf! item a)
-			a)
-		      (ferror "Image-item "item" already has a pixbuf!"))))
-      (C-call "gdk_pixbuf_loader_get_pixbuf" pixbuf (gobject-alien loader))
-      ;; Fill with non-background (non-fg) color? (Pick from a GtkStyle!!!)
-      (%trace "; image-item::area-prepared "item" ("pixbuf")\n"))))
-
-(define (image-item-area-updated item)
-  (named-lambda (image-item::area-updated GdkPixbufLoader x y width height)
-    GdkPixbufLoader ;;Ignored.
-
-    (let ((rect (make-rect x y width height)))
-      (%trace "; image-item::area-updated "item" "rect"\n")
-      (drawing-damage item rect))))
+(define (image-item-pixbuf-prepared item)
+  (named-lambda (image-item::pixbuf-prepared pixbuf)
+    (trace "; image-item::pixbuf-prepared "item" "pixbuf"\n")
+    (set-image-item-pixbuf! item pixbuf)))
+
+(define (image-item-pixbuf-updated item)
+  (named-lambda (image-item::pixbuf-updated rectangle)
+    (trace "; image-item::pixbuf-updated "item" "rectangle"\n")
+    (drawing-damage item rectangle)))
+
+(define (image-item-pixbuf-loaded item)
+  (named-lambda (image-item::pixbuf-loaded loader)
+    (trace "; image-item::pixbuf-loaded "item" ("(image-item-pixbuf item)")"
+	    " "(pixbuf-loader-error-message loader)"\n")
+    (if (not (pixbuf-loader-error-message loader))
+	(begin
+	  (set-image-item-loader! item #f)
+	  (gobject-unref loader))
+	(begin
+	  ;; Hack the pixbuf with a "broken image" overlay?
+	  ;;
+	  ;; Leave the loader, with dead thread and closed
+	  ;; input-port, for debugging purposes.
+	  unspecific))))
 
 (define-method drawn-item-expose ((item <image-item>) widget window area)
-;;;  (%trace "; (Re)Drawing "item" on "widget".\n")
+;;;  (trace "; (Re)Drawing "item" on "widget".\n")
 
   (let ((widgets (drawn-item-widgets item)))
     (if (or (eq? #f widgets)
 	    (memq widget widgets))
-	(let ((pixbuf (image-item-pixbuf item)))
+	(let ((pixbuf (let ((p (image-item-pixbuf item)))
+			(if p (gobject-alien p) #f))))
 	  (if (and pixbuf (not (alien-null? pixbuf)))
 	      (let ((item-area (drawn-item-area item))
 		    (scroll (scm-layout-on-screen-area widget))
@@ -885,7 +891,7 @@ USA.
 (define (add-image-item-from-file drawing where filename)
   ;; WHERE can be 'TOP (or #f) or 'BOTTOM.
   (let ((item (add-image-item drawing (check-where where))))
-    (load-pixbuf-from-file (image-item-pixbuf-loader item) filename)
+    (load-pixbuf-from-file (image-item-loader item) filename)
     item))
 
 (define (check-where where)
@@ -909,12 +915,7 @@ USA.
 	  obj)
       (ferror "Not a non-negative integer: "obj)))
 
-(define (check-!null alien message)
-  (if (alien-null? alien)
-      (ferror "scm-layout: "message)
-      alien))
-
-(define %trace? #f)
-(define (%trace . objects)
-  (if %trace?
+(define trace? #f)
+(define (trace . objects)
+  (if trace?
       (apply outf-console objects)))
\ No newline at end of file
diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm
index 066edf4ae..44b618534 100644
--- a/src/gtk/thread.scm
+++ b/src/gtk/thread.scm
@@ -28,13 +28,6 @@ USA.
 ;;; parent: (runtime thread)
 
 
-(define tracing? #f)
-
-(define-syntax trace
-  (syntax-rules ()
-    ((_ . MSG)
-     (if tracing? ((lambda () (outf-console . MSG)))))))
-
 (define gtk-thread #f)
 
 ;;; With the following thread always running, the runtime system
@@ -46,23 +39,27 @@ USA.
   (set! gtk-thread
 	(create-thread
 	 #f (lambda ()
-	      (let ((self (current-thread)))
+	      (let ((self (current-thread))
+		    (done-tick 0))
 		(let gtk-thread-loop ()
-		  (let ((time (time-limit self)))
-		    (trace ";run-gtk until "time"\n")
-		    ((ucode-primitive run-gtk 2)
-		     (select-registry-handle io-registry) time)
-		    (trace ";run-gtk done at "(real-time-clock)"\n"))
-		  (signal-thread-events)
+		  (without-interrupts
+		   (lambda ()
+		     (let ((gc-tick (car (gc-timestamp))))
+		       (if (fix:< done-tick gc-tick)
+			   (begin
+			     (run-gc-cleanups)
+			     (set! done-tick gc-tick))))))
+		  (without-interrupts
+		   (lambda ()
+		     (let ((time (time-limit self)))
+		       (trace ";run-gtk until "time"\n")
+		       ((ucode-primitive run-gtk 2)
+			(select-registry-handle io-registry) time)
+		       (trace ";run-gtk done at "(real-time-clock)"\n"))
+		     (maybe-signal-io-thread-events)))
 		  (yield-current-thread)
 		  (gtk-thread-loop)))))))
 
-(define (signal-thread-events)
-  ;; NOTE: This should match the start of thread-timer-interrupt-handler.
-  (set! next-scheduled-timeout #f)
-  (deliver-timer-events)
-  (maybe-signal-io-thread-events))
-
 (define (time-limit self)
   (if (thread/next self)
       0
@@ -76,4 +73,11 @@ USA.
 (define (kill-gtk-thread)
   (if (not gtk-thread) (error "A GTk thread is not running."))
   (signal-thread-event
-   gtk-thread (lambda () (exit-current-thread #t))))
\ No newline at end of file
+   gtk-thread (lambda () (exit-current-thread #t))))
+
+(define trace? #f)
+
+(define-syntax trace
+  (syntax-rules ()
+    ((_ . MSG)
+     (if trace? ((lambda () (outf-console . MSG)))))))
\ No newline at end of file
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 18306a3b3..ee209f48f 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -103,7 +103,7 @@ USA.
   (set! timer-interval 100)
   (initialize-io-blocking)
   (add-event-receiver! event:after-restore initialize-io-blocking)
-  (set! tracing? #f)
+  (set! trace? #f)
   (detach-thread (make-thread #f))
   (add-event-receiver! event:before-exit stop-thread-timer))
 
@@ -323,12 +323,12 @@ USA.
 	     (flo:set-environment! fp-env)
 	     (%resume-current-thread thread))))))
 
-(define tracing? #f)
+(define trace? #f)
 
 (define-syntax trace
   (syntax-rules ()
     ((_ . MSG)
-     (if tracing? ((lambda () (outf-console . MSG)))))))
+     (if trace? ((lambda () (outf-console . MSG)))))))
 
 (define (yield-current-thread)
   (without-interrupts
-- 
2.25.1