From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Wed, 20 Jul 2011 17:43:09 +0000 (-0700)
Subject: Timeout -1 is forever.  Turn off thread timer in toolkit.
X-Git-Tag: mit-scheme-pucked-9.2.12~673
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d52f6fa9d5c0c4a119cd14d7176c212edd2fb6ae;p=mit-scheme.git

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 b3d16427e..e6d70b511 100644
--- 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 88b27d04f..67bbbec67 100644
--- 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)