From a83a927bdbd6d5b971aa6f8172b78a2cdf34a5ef Mon Sep 17 00:00:00 2001
From: Neil Jerram <neil@ossau.uklinux.net>
Date: Sat, 23 May 2009 17:55:58 +0100
Subject: [PATCH] Fix wait-condition-variable so that it doesn't leave asyncs blocked

* libguile/threads.c (fat_mutex_unlock): Unblock asyncs when breaking
  out of loop.

* test-suite/tests/threads.test (asyncs-still-working?): New function,
  to test if asyncs are working (i.e. unblocked).  Use this throughout
  threads.test, in particular before and after the "timed locking
  succeeds if mutex unlocked within timeout" test.
---
 libguile/threads.c            |    1 +
 test-suite/tests/threads.test |   35 +++++++++++++++++++++++++++++++++--
 2 files changed, 34 insertions(+), 2 deletions(-)

diff --git a/libguile/threads.c b/libguile/threads.c
index bb874e2..947e595 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1491,6 +1491,7 @@ fat_mutex_unlock (SCM mutex, SCM cond,
 	    {
 	      if (relock)
 		scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner);
+	      t->block_asyncs--;
 	      break;
 	    }
 
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index caace7f..bd9f2f3 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -21,6 +21,12 @@
   :use-module (ice-9 threads)
   :use-module (test-suite lib))
 
+(define (asyncs-still-working?)
+  (let ((a #f))
+    (system-async-mark (lambda ()
+			 (set! a #t)))
+    (equal? '(a b c) '(a b c))
+    a))
 
 (if (provided? 'threads)
     (begin
@@ -101,6 +107,9 @@
 
       (with-test-prefix "n-for-each-par-map"
 
+	(pass-if "asyncs are still working 2"
+	  (asyncs-still-working?))
+
 	(pass-if "0 in limit 10"
 	  (n-for-each-par-map 10 noop noop '())
 	  #t)
@@ -143,12 +152,18 @@
 
       (with-test-prefix "lock-mutex"
 
+	(pass-if "asyncs are still working 3"
+	  (asyncs-still-working?))
+
 	(pass-if "timed locking fails if timeout exceeded"
 	  (let ((m (make-mutex)))
 	    (lock-mutex m)
 	    (let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
 	      (not (join-thread t)))))
 
+	(pass-if "asyncs are still working 6"
+	  (asyncs-still-working?))
+
         (pass-if "timed locking succeeds if mutex unlocked within timeout"
 	  (let* ((m (make-mutex))
 		 (c (make-condition-variable))
@@ -164,7 +179,12 @@
 	      (unlock-mutex cm)
 	      (sleep 1)
 	      (unlock-mutex m)
-	      (join-thread t)))))
+	      (join-thread t))))
+
+	(pass-if "asyncs are still working 7"
+	  (asyncs-still-working?))
+
+	)
 
       ;;
       ;; timed mutex unlocking
@@ -172,12 +192,18 @@
 
       (with-test-prefix "unlock-mutex"
 
+	(pass-if "asyncs are still working 5"
+	  (asyncs-still-working?))
+
         (pass-if "timed unlocking returns #f if timeout exceeded"
           (let ((m (make-mutex))
 		(c (make-condition-variable)))
 	    (lock-mutex m)
 	    (not (unlock-mutex m c (current-time)))))
 
+	(pass-if "asyncs are still working 4"
+	  (asyncs-still-working?))
+
         (pass-if "timed unlocking returns #t if condition signaled"
 	  (let ((m1 (make-mutex))
 		(m2 (make-mutex))
@@ -226,7 +252,12 @@
 
 	(pass-if "timed joining succeeds if thread exits within timeout"
           (let ((t (begin-thread (begin (sleep 1) #t))))
-	    (join-thread t (+ (current-time) 2)))))
+	    (join-thread t (+ (current-time) 2))))
+
+	(pass-if "asyncs are still working 1"
+	  (asyncs-still-working?))
+
+	)
 
       ;;
       ;; thread cancellation
-- 
1.5.6.5