From 64967b1b458db7c481d83eb485f5656fb0e01e2a Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 17 Jul 2011 11:07:26 -0700 Subject: [PATCH] Added maybe-yield-gtk, for callbacks that unblock threads. --- src/gtk/gtk-shim.h | 1 + src/gtk/gtk.cdecl | 1 + src/gtk/gtk.pkg | 27 ++++++++++++++------------- src/gtk/gtkio.c.stay | 35 +++++++++++++++++++++++------------ src/gtk/main.scm | 5 ++++- src/gtk/thread.scm | 14 +++++++++++--- 6 files changed, 54 insertions(+), 29 deletions(-) diff --git a/src/gtk/gtk-shim.h b/src/gtk/gtk-shim.h index e6ec83ecf..b4fda5ae6 100644 --- 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 d12ddbcbd..02c44ebab 100644 --- 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 58ba9e67f..27a2a8e29 100644 --- 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 c04a24c14..e9bcb78b2 100644 --- 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; +} /* Gtk Select Registries -- GSLists of GPollFDs. */ diff --git a/src/gtk/main.scm b/src/gtk/main.scm index a796a801b..7870c0aae 100644 --- 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 81b7083e4..d241f12a2 100644 --- 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)) -- 2.25.1