From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 16 Nov 2014 18:53:41 +0000 (+0000)
Subject: Fix timed condition variable waits.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~110
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=110182e053e8c0de84e134cc0c74747365402242;p=mit-scheme.git

Fix timed condition variable waits.
---

diff --git a/src/runtime/condvar.scm b/src/runtime/condvar.scm
index afef65224..c1d23ce48 100644
--- a/src/runtime/condvar.scm
+++ b/src/runtime/condvar.scm
@@ -82,7 +82,7 @@ USA.
 (define (condition-variable-specific-set! condvar specific)
   (guarantee-condition-variable condvar 'SET-CONDITION-VARIABLE-SPECIFIC!)
   (set-condition-variable.specific! condvar specific))
-
+
 (define (unlock-thread-mutex-and-wait thread-mutex condvar #!optional timeout)
   (guarantee-condition-variable condvar 'CONDITION-VARIABLE-WAIT!/UNLOCK)
   (guarantee-thread-mutex thread-mutex 'CONDITION-VARIABLE-WAIT!/UNLOCK)
@@ -100,18 +100,31 @@ USA.
     (let ((blocked? (block-thread-events)))
       (with-lock (lambda () (enqueue-waiter! condvar waiter)))
       (unlock-thread-mutex thread-mutex)
-      (begin0
-	  (let loop ()
-	    (cond ((and (real? timeout) (<= (real-time-clock) timeout)) #f)
-		  ((waiter.done? waiter) #t)
-		  (else (suspend-current-thread) (loop))))
-	(with-lock
-	  (lambda ()
-	    ;; Signaller got interrupted or we timed out.  Clean up.
-	    (if (not (waiter-detached? condvar waiter))
-		(remove-waiter! condvar waiter))))
-	(if (not blocked?)
-	    (unblock-thread-events))))))
+      (let ((registration
+             (if (default-object? timeout)
+		 0
+                 (begin
+		   (guarantee-real timeout)
+		   (register-timer-event (- timeout (real-time-clock)) #f)))))
+	(begin0
+	    (let loop ()
+	      (cond ((and (not (default-object? timeout))
+			  (<= (real-time-clock) timeout))
+		     #f)
+		    ((waiter.done? waiter)
+		     #t)
+		    (else
+		     (suspend-current-thread)
+		     (loop))))
+	  (if (not (default-object? timeout))
+	      (deregister-timer-event registration))
+	  (with-lock
+	    (lambda ()
+	      ;; Signaller got interrupted or we timed out.  Clean up.
+	      (if (not (waiter-detached? condvar waiter))
+		  (remove-waiter! condvar waiter))))
+	  (if (not blocked?)
+	      (unblock-thread-events)))))))
 
 (define (condition-variable-signal! condvar)
   (guarantee-condition-variable condvar 'CONDITION-VARIABLE-SIGNAL!)