Added maybe-yield-gtk, for callbacks that unblock threads.

diff --git a/src/gtk/gtk-shim.h b/src/gtk/gtk-shim.h
index e6ec83ecff7f9ac179fe8ec4ffa71c7578a99681..b4fda5ae6f9d1b0251167b7f66ffc17f62d4ec74 100644 (file)
--- a/src/gtk/gtk-shim.h
+++ b/src/gtk/gtk-shim.h
@@ -51,6 +51,7 @@ extern GtkWidget* scm_widget_new (void);
 extern gboolean start_gtk (int *argc, char ***argv);
 extern void     stop_gtk (void);
 extern void     run_gtk (unsigned long registry, double time);
+extern void     yield_gtk (void);
 extern gboolean gtk_time_slice_window_p (void);
 extern void     gtk_time_slice_window (gboolean open_p);
 extern gboolean gtk_select_trace_p (void);

diff --git a/src/gtk/gtk.cdecl b/src/gtk/gtk.cdecl
index d12ddbcbd6b4acf72dbbfa01b3d6708f1ccb7bc4..02c44ebabf2662bae104965cec102eefc3bbcee9 100644 (file)
--- a/src/gtk/gtk.cdecl
+++ b/src/gtk/gtk.cdecl
@@ -47,6 +47,7 @@ USA.
 (extern gboolean start_gtk (argc_loc (* int)) (argv_loc (* (* (* char)))))
 (extern void     stop_gtk)
 (extern void     run_gtk (registry ulong) (time double))
+(extern void     yield_gtk)
 (extern gboolean gtk_time_slice_window_p)
 (extern void     gtk_time_slice_window (open_p gboolean))
 (extern gboolean gtk_select_trace_p)

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 58ba9e67f652d54e966a72666030afe480ff9a26..27a2a8e29544e3e1fc233c9eaf2d36a96aefc3dc 100644 (file)
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -254,19 +254,6 @@ USA.
          find-c-includes
          c-enum-constant-values))
 
-(define-package (gtk thread)
-  (parent (runtime thread))
-  (files "thread")
-  ;;(depends-on)
-  (export ()
-         stop-gtk-thread)
-  (import (gtk gobject)
-         run-gc-cleanups)
-  (import (gtk main)
-         run-gtk)
-  (import (runtime primitive-io)
-         select-registry-handle))
-
 (define-package (gtk main)
   (parent (gtk))
   (files "main")
@@ -287,6 +274,20 @@ USA.
          gtk-select-trace?
          gtk-select-trace!))
 
+(define-package (gtk thread)
+  (parent (runtime thread))
+  (files "thread")
+  ;;(depends-on "main")
+  (export ()
+         stop-gtk-thread)
+  (import (gtk gobject)
+         run-gc-cleanups)
+  (import (gtk main)
+         run-gtk
+         yield-gtk)
+  (import (runtime primitive-io)
+         select-registry-handle))
+
 (define-package (gtk event-viewer)
   (parent (gtk))
   (files "gtk-ev")

diff --git a/src/gtk/gtkio.c.stay b/src/gtk/gtkio.c.stay
index c04a24c1463d9a72775643cd05ea30e063b2f0cd..e9bcb78b2440d19fb53f62762d5d1f15c3e04397 100644 (file)
--- a/src/gtk/gtkio.c.stay
+++ b/src/gtk/gtkio.c.stay
@@ -44,6 +44,11 @@ struct _SchemeSource
 
   /* When to give up waiting. */
   double time_limit;
+
+  /* TRUE when Scheme has a runnable thread.  Set to FALSE at the
+     start of run_gtk.  Set to TRUE by a callback that has made a
+     Scheme thread runnable.  */
+  gboolean runnable;
 };
 typedef struct _SchemeSource SchemeSource;
 
@@ -80,6 +85,7 @@ scheme_source_prepare (GSource * source, gint * timeout)
   double dtime = OS_real_time_clock ();
   int timeo = src->time_limit - dtime;
   if (timeo <= 0
+      || src->runnable
       || pending_interrupts_p ()
       || OS_process_any_status_change ())
     {
@@ -88,8 +94,9 @@ scheme_source_prepare (GSource * source, gint * timeout)
          if (timeo > 0)
            {
              outf_console (";scheme_source_prepare: %s\n",
-                           pending_interrupts_p ()
-                           ? "interrupt" : "subprocess");
+                           src->runnable ? "thread"
+                           : pending_interrupts_p () ? "interrupt"
+                           : "subprocess");
            }
          else
            {
@@ -117,21 +124,17 @@ scheme_source_check (GSource * source)
   /* Return TRUE when ready to dispatch (after the poll). */
 
   SchemeSource * src = (SchemeSource *)source;
-  double time = OS_real_time_clock ();
-  if (time > src->time_limit
-      || pending_io (src)
+  if (src->runnable
       || pending_interrupts_p ()
-      || OS_process_any_status_change ())
+      || OS_process_any_status_change ()
+      || pending_io (src))
     {
-      if (tracing_gtk_select
-         && (time > src->time_limit
-             || pending_interrupts_p ()
-             || OS_process_any_status_change ()))
+      if (tracing_gtk_select)
        {
          outf_console (";scheme_source_check: %s\n",
-                       pending_interrupts_p () ? "interrupt"
+                       src->runnable ? "thread"
+                       : pending_interrupts_p () ? "interrupt"
                        : OS_process_any_status_change () ? "subprocess"
-                       : time > src->time_limit ? "timeout"
                        : "i/o ready");
          outf_flush_console ();
        }
@@ -248,6 +251,7 @@ install_scheme_source (void)
     g_source_new (&scheme_source_funcs, sizeof (SchemeSource));
   scheme_source->gpollfds = NULL;
   scheme_source->time_limit = 0.0;
+  scheme_source->runnable = FALSE;
   g_source_attach ((GSource *) scheme_source, NULL);
 }
 
@@ -290,6 +294,7 @@ set_registry (SchemeSource * source, GSList * new, double time)
     clear_registry (source);
 
   source->time_limit = time;
+  source->runnable = FALSE;
   source->gpollfds = new;
   {
     GMainContext * context = g_source_get_context ((GSource *)source);
@@ -385,6 +390,12 @@ run_gtk (unsigned long registry, double time)
   abort_to_c ();
   /*NOTREACHED*/
 }
+
+void
+yield_gtk (void)
+{
+  scheme_source->runnable = TRUE;
+}
 \f
 
 /* Gtk Select Registries -- GSLists of GPollFDs. */

diff --git a/src/gtk/main.scm b/src/gtk/main.scm
index a796a801b41caf480ce8da3e0189d698c4cba134..7870c0aaec7a3da1c53e10602019b26f0557e062 100644 (file)
--- a/src/gtk/main.scm
+++ b/src/gtk/main.scm
@@ -81,9 +81,12 @@ USA.
              (create-gtk-thread)
              (cdr new-args)))))))
 
-(define (run-gtk select-registry-handle time)
+(define-integrable (run-gtk select-registry-handle time)
   (C-call "run_gtk" select-registry-handle time))
 
+(define-integrable (yield-gtk)
+  (C-call "yield_gtk"))
+
 (define (stop-gtk)
   ;; Sortof does the opposite of gtk-start.
   (without-interrupts

diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm
index 81b7083e469bb6d07873e0070c8db88c6439cdb7..d241f12a21c4bc861250b51b9c12fdac03497210 100644 (file)
--- a/src/gtk/thread.scm
+++ b/src/gtk/thread.scm
@@ -74,9 +74,17 @@ USA.
                  (gtk-thread-loop))))))
   (detach-thread gtk-thread))
 
-(define (no-threads-nor-timers)
-  ;; Wake up once a minute, just to see if you can...
-  (+ (real-time-clock) (* 60 1000)))
+(define-integrable (no-threads-nor-timers)
+  ;; Wake up once a minute, just to see if we can.
+  (let ((t (+ (real-time-clock) (* 60 1000))))
+    (%trace ";no-thread-nor-timers: wake up for no reason at "t"\n")
+    t))
+
+(define (maybe-yield-gtk)
+  ;; Used by callbacks that may have made threads runnable.
+  (%trace ";maybe-yield-gtk "(thread/next (current-thread)))
+  (if (thread/next (current-thread))
+      (yield-gtk)))
 
 (define (exit-gtk-thread)
   (let ((thread gtk-thread))