From 10b1110439bdf86b52f39cff401e36f6d6a1d2a0 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 8 Aug 2012 00:21:00 +0900
Subject: [PATCH] Fixing mutex-unlock! with paused thread waiting on
 mutex-lock!

---
 lib/srfi/18/interface.scm | 22 ++++++++-----
 tests/thread-tests.scm    | 67 +++++++++++++++++++++++++++++++++------
 2 files changed, 71 insertions(+), 18 deletions(-)

diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm
index d7fef274..f724c443 100644
--- a/lib/srfi/18/interface.scm
+++ b/lib/srfi/18/interface.scm
@@ -36,18 +36,24 @@
 (define (mutex-lock! mutex . o)
   (let ((timeout (and (pair? o) (car o)))
         (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t)))
-    (cond ((%mutex-lock! mutex (timeout->seconds timeout) thread))
-	  (else
-	   (thread-yield!)
-	   (not (thread-timeout?))))))
+    (cond
+     ((%mutex-lock! mutex (timeout->seconds timeout) thread))
+     (else
+      (thread-yield!)
+      ;; If we timed out, fail.
+      (if (thread-timeout?)
+          #f
+          ;; Otherwise the lock was released, try again.
+          (mutex-lock! mutex timeout thread))))))
 
 (define (mutex-unlock! mutex . o)
   (let ((condvar (and (pair? o) (car o)))
         (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f)))
-    (cond ((%mutex-unlock! mutex condvar (timeout->seconds timeout)))
-	  (else
-	   (thread-yield!)
-	   (not (thread-timeout?))))))
+    (cond
+     ((%mutex-unlock! mutex condvar (timeout->seconds timeout)))
+     (else
+      (thread-yield!)
+      (not (thread-timeout?))))))
 
 (define (join-timeout-exception? x)
   (and (exception? x)
diff --git a/tests/thread-tests.scm b/tests/thread-tests.scm
index d40dec7b..bbe08b0a 100644
--- a/tests/thread-tests.scm
+++ b/tests/thread-tests.scm
@@ -5,17 +5,64 @@
 
 (test-begin "threads")
 
-(test "no threads" (begin 'ok) 'ok)
-(test "unstarted thread" (let ((t (make-thread (lambda () (error "oops"))))) 'ok) 'ok)
-(test "ignored thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok) 'ok)
-(test "ignored thread hangs" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) 'ok) 'ok)
-(test "joined thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) (thread-join! t) 'ok) 'ok)
-(test "joined thread hangs, timeout" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) (thread-join! t 0.1 'timeout)) 'timeout)
+(test "no threads" 'ok (begin 'ok))
 
-(test "basic mutex" (let ((m (make-mutex))) (and (mutex? m) 'ok)) 'ok)
-(test "mutex unlock" (let ((m (make-mutex))) (and (mutex-unlock! m) 'ok)) 'ok)
-(test "mutex lock/unlock" (let ((m (make-mutex))) (and (mutex-lock! m) (mutex-unlock! m) 'ok)) 'ok)
-(test "mutex lock timeout" (let* ((m (make-mutex)) (t (make-thread (lambda () (mutex-lock! m))))) (thread-start! t) (thread-yield!) (if (mutex-lock! m 0.1) 'fail 'timeout)) 'timeout)
+(test "unstarted thread" 'ok
+  (let ((t (make-thread (lambda () (error "oops"))))) 'ok))
+
+(test "ignored thread terminates" 'ok
+  (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok))
+
+(test "ignored thread hangs" 'ok
+  (let ((t (make-thread (lambda () (let lp () (lp))))))
+    (thread-start! t)
+    'ok))
+
+(test "joined thread terminates" 'ok
+  (let ((t (make-thread (lambda () 'oops))))
+    (thread-start! t)
+    (thread-join! t)
+    'ok))
+
+(test "joined thread hangs, timeout" 'timeout
+  (let ((t (make-thread (lambda () (let lp () (lp))))))
+    (thread-start! t)
+    (thread-join! t 0.1 'timeout)))
+
+(test "basic mutex" 'ok
+  (let ((m (make-mutex)))
+    (and (mutex? m) 'ok)))
+
+(test "mutex unlock" 'ok
+  (let ((m (make-mutex)))
+    (and (mutex-unlock! m) 'ok)))
+
+(test "mutex lock/unlock" 'ok
+  (let ((m (make-mutex)))
+    (and (mutex-lock! m)
+         (mutex-unlock! m)
+         'ok)))
+
+(test "mutex lock/lock" 'timeout
+  (let ((m (make-mutex)))
+    (and (mutex-lock! m)
+         (if (mutex-lock! m 0.1) 'fail 'timeout))))
+
+(test "mutex lock timeout" 'timeout
+  (let* ((m (make-mutex))
+         (t (make-thread (lambda () (mutex-lock! m)))))
+    (thread-start! t)
+    (thread-yield!)
+    (if (mutex-lock! m 0.1) 'fail 'timeout)))
+
+(test "mutex lock/unlock/lock/lock" 'timeout
+  (let* ((m (make-mutex))
+         (t (make-thread (lambda () (mutex-unlock! m)))))
+    (mutex-lock! m)
+    (thread-start! t)
+    (if (mutex-lock! m 0.1)
+        (if (mutex-lock! m 0.1) 'fail-second 'timeout)
+        'bad-timeout)))
 
 ;(test "basic condition-variable" () 'ok)
 ;(test "condition-variable signal" () 'ok)