Timeout -1 is forever. Turn off thread timer in toolkit.

Reworked scheme_source_prepare/check to implement timeout -1, reduce
calls to OS_real_time_clock, and improve tracing.

diff --git a/src/gtk/gtkio.c.stay b/src/gtk/gtkio.c.stay
index b3d16427eccd9b859f69a9e241f5be50c47d8424..e6d70b5111b3766cfe411fe208ffcf0fcac210b6 100644 (file)
--- a/src/gtk/gtkio.c.stay
+++ b/src/gtk/gtkio.c.stay
@@ -96,24 +96,46 @@ scheme_source_prepare (GSource * source, gint * timeout)
      dispatching. */
 
   SchemeSource * src = (SchemeSource *)source;
-  double dtime = OS_real_time_clock ();
-  int timeo = src->time_limit - dtime;
-  if (timeo <= 0
-      || src->runnable
+
+  if (src->runnable
       || pending_interrupts_p ()
       || OS_process_any_status_change ())
     {
       trace (";scheme_source_prepare: ready (%s)\n",
-            timeo <= 0 ? "timeout"
-            : src->runnable ? "thread"
+            src->runnable ? "thread"
             : pending_interrupts_p () ? "interrupt"
             : "subprocess");
-      return (TRUE);           /* Ready for immediate dispatch. */
+      *timeout = 0;
+      return (TRUE);
     }
+  if (src->time_limit == -1.0)
+    {
+      trace (";scheme_source_prepare: waiting\n");
+      *timeout = -1;
+      return (FALSE);
+    }
+  if (src->time_limit == 0.0)
+    {
+      trace (";scheme_source_prepare: polling\n");
+      /* 0 here does not allow expose events to be delivered? */
+      *timeout = 0;
+      return (FALSE);
+    }
+  {
+    double dtime = OS_real_time_clock ();
+    gint timeo = ceil (src->time_limit - dtime);
+
+    if (timeo <= 0)
+      {
+       trace (";scheme_source_prepare: ready (timeout)\n");
+       *timeout = 0;
+       return (TRUE);
+      }
 
-  trace (";scheme_source_prepare: polling for %dmsec\n", timeo);
-  *timeout = timeo;
-  return (FALSE);      /* Poll/check before dispatching. */
+    trace (";scheme_source_prepare: polling for %dmsec\n", timeo);
+    *timeout = timeo;
+    return (FALSE);
+  }
 }
 
 static gboolean
@@ -122,19 +144,38 @@ scheme_source_check (GSource * source)
   /* Return TRUE when ready to dispatch (after the poll). */
 
   SchemeSource * src = (SchemeSource *)source;
-  if (src->runnable
+
+  if (src->time_limit == 0.0
+      || src->runnable
       || pending_interrupts_p ()
       || OS_process_any_status_change ()
       || pending_io (src))
     {
-      trace (";scheme_source_check: %s\n",
+      trace (";scheme_source_check: ready (%s)\n",
             src->runnable ? "thread"
             : pending_interrupts_p () ? "interrupt"
             : OS_process_any_status_change () ? "subprocess"
-            : "i/o ready");
-      return (TRUE);           /* Ready for immediate dispatch. */
+            : src->time_limit == 0.0 ? "" : "i/o");
+      return (TRUE);
     }
-  return (FALSE);              /* No I/O ready; no timeout. */
+  if (src->time_limit == -1.0)
+    {
+      trace (";scheme_source_check: waiting forever\n");
+      return (FALSE);
+    }
+  {
+    double dtime = OS_real_time_clock ();
+    gint timeo = ceil (src->time_limit - dtime);
+
+    if (timeo <= 0)
+      {
+       trace (";scheme_source_check: ready (timeout)\n");
+       return (TRUE);
+      }
+
+    trace (";scheme_source_check: waiting %dmsec\n", timeo);
+    return (FALSE);
+  }
 }
 
 static int

diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm
index 88b27d04f5d04bc1c012161abd348882f5260e2e..67bbbec676157d28425f833f5eccbc9d2851665c 100644 (file)
--- a/src/gtk/thread.scm
+++ b/src/gtk/thread.scm
@@ -60,12 +60,12 @@ USA.
                             (trigger-secondary-gc-daemons!)
                             (set! next-secondary-tick
                                   (fix:+ gc-tick secondary-gc-rate)))))))
-                 (without-interrupts
+                 (with-thread-timer-stopped
                   (lambda ()
-                    (let ((time (if (thread/next self)
-                                    0
-                                    (or next-scheduled-timeout
-                                        (no-threads-nor-timers)))))
+                    (let ((time (or (and (thread/next self) 0)
+                                    (and timer-records
+                                         (timer-record/time timer-records))
+                                    -1)))
                       (%trace ";run-gtk until "time"\n")
                       (run-gtk (select-registry-handle io-registry) time)
                       (%trace ";run-gtk done at "(real-time-clock)"\n"))
@@ -74,12 +74,6 @@ USA.
                  (gtk-thread-loop))))))
   (detach-thread gtk-thread))
 
-(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 (exit-gtk-thread)
   (let ((thread gtk-thread))
     (set! gtk-thread #f)