>From 5f4e77f4f8444878655a5046d92fd624ad262646 Mon Sep 17 00:00:00 2001
From: Christian Kellermann <address@hidden>
Date: Tue, 10 Dec 2013 12:41:54 +0100
Subject: [PATCH] Go back to sleep when thread-join! is called without timeout.

This patch fixes an issue discovered by Michael Greenly. When a signal
handler is called a thread waiting for another with thread-join! got
woken up and the code assumed this could have happened only because
the other thread died or the timeout occured. Hence if the waited-for
thread is not in state terminated or dead a timeout exception is
thrown.

With this patch the thread is put back to blocking state (for
termination of the waited-for thread) if no timeout has been given.

Note: This is reliably triggered only when the signal is delivered
external from the CHICKEN process.

The patch also refactors the code to explicitly match the expected
thread states and errors out in the else clause.

A test case for this situation has been added and is enabled on unix
systems (a patch for the runtests.bat is missing).
---
 srfi-18.scm                   | 22 ++++++++++-------
 tests/runtests.sh             |  6 +++++
 tests/srfi-18-signal-test.scm | 55 +++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 75 insertions(+), 8 deletions(-)
 create mode 100644 tests/srfi-18-signal-test.scm

diff --git a/srfi-18.scm b/srfi-18.scm
index 3f8cf25..9aef911 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -183,15 +183,21 @@
 		   (##sys#make-structure 
 		    'condition '(uncaught-exception)
 		    (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) ]
-		[else
-		 (return
-		  (if tosupplied
-		      toval
-		      (##sys#signal
-		       (##sys#make-structure 'condition '(join-timeout-exception) '())) ) ) ] ) ) )
-	   (##sys#thread-block-for-termination! ct thread) 
+		[(blocked ready)
+                 (if limit
+                     (return
+                      (if tosupplied
+                          toval
+                          (##sys#signal
+                           (##sys#make-structure 'condition '(join-timeout-exception) '())) ) )
+                     (##sys#thread-block-for-termination! ct thread) ) ]
+                [else
+                 (##sys#error 'thread-join!
+                              "Internal scheduler error: unknown thread state: "
+                              ct (##sys#slot thread 3)) ] ) ) )
+	   (##sys#thread-block-for-termination! ct thread)
 	   (##sys#schedule) ) ) ) ) ) )
-	   
+
 (define (thread-terminate! thread)
   (##sys#check-structure thread 'thread 'thread-terminate!)
   (when (eq? thread ##sys#primordial-thread)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 16e4bc2..7cc9950 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -68,6 +68,7 @@ interpret="../csi -n -include-path .."
 
 rm -f *.exe *.so *.o *.import.* a.out ../foo.import.*
 
+
 echo "======================================== compiler tests ..."
 $compile compiler-tests.scm
 ./a.out
@@ -329,6 +330,11 @@ echo "======================================== srfi-18 tests ..."
 $interpret -s simple-thread-test.scm
 $interpret -s mutex-test.scm
 
+echo "======================================== srfi-18 thread-join! tests ..."
+$compile srfi-18-signal-test.scm
+./a.out & echo "sleeping and sending SIGINT to a.out (pid $!)" && sleep 1 && kill -s 2 $!
+wait $!
+
 echo "======================================== data-structures tests ..."
 $interpret -s data-structures-tests.scm
 
diff --git a/tests/srfi-18-signal-test.scm b/tests/srfi-18-signal-test.scm
new file mode 100644
index 0000000..7761558
--- /dev/null
+++ b/tests/srfi-18-signal-test.scm
@@ -0,0 +1,55 @@
+(require-extension srfi-18)
+(require-extension posix)
+
+(define done #f)
+
+; set done = true on control-c
+(set-signal-handler! signal/int (lambda (signal) (set! done #t)))
+
+(define (work-loop count)
+  (if (> count 100)
+      (error "Loop limit exceeded"))
+  (if done
+      (newline)
+      (begin
+        (display ".")
+        (thread-sleep! 0.25)
+        (work-loop (add1 count)))))
+
+(define (new-thread)
+  (set! done #f)
+  (make-thread (lambda () (work-loop 0))))
+
+
+;; Needs external signal it seems
+(display "Correct handling of thread-join! with external signals: ")
+(let ((t (new-thread)))
+  (thread-start! t)
+  (thread-join! t))
+
+(display "graceful termination, this is good")
+
+(display "thread-join with timeout")
+(let ((t (new-thread)))
+  (condition-case
+   (begin
+     (thread-start! t)
+     (thread-join! t 1))
+   [(join-timeout-exception)
+    (print "timeout exception as expected")
+    (thread-terminate! t)]
+   [exn () (thread-terminate! t)
+        (signal exn)]))
+
+
+(display "thread-join with return value")
+
+(let ((t (new-thread)))
+  (assert (condition-case
+           (begin
+             (thread-start! t)
+             (thread-join! t 1 'bla))
+           [(join-timeout-exception) (print "timeout exception as expected")(thread-terminate! t)]
+           [exn () (thread-terminate! t)(signal exn)]) 'bla))
+
+(print "done.")
-- 
1.8.3.2