~ chicken-core (chicken-5) e2700786c777b8ef353e92c66f8ccdeea7524cca
commit e2700786c777b8ef353e92c66f8ccdeea7524cca
Author: Christian Kellermann <ckeen@pestilenz.org>
AuthorDate: Tue Dec 10 12:41:54 2013 +0100
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Tue Dec 10 22:25:03 2013 +0100
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.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/NEWS b/NEWS
index 9c66c110..56987d05 100644
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,8 @@
- Export file-type from the posix unit (thanks to Alan Post).
- unsetenv has been fixed on Windows.
- SRFI-4 s8vectors now work correctly in compiled code on PowerPC and ARM.
+ - thread-join! now works correctly even if the waiting thread was
+ prematurely woken up by a signal.
- Platform support
- CHICKEN can now be built on AIX (contributed by Erik Falor)
diff --git a/distribution/manifest b/distribution/manifest
index 11c0aab3..10034894 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -120,6 +120,7 @@ tests/runtests.bat
tests/runbench.sh
tests/srfi-4-tests.scm
tests/srfi-13-tests.scm
+tests/srfi-18-signal-test.scm
tests/srfi-14-tests.scm
tests/srfi-45-tests.scm
tests/simple-thread-test.scm
diff --git a/srfi-18.scm b/srfi-18.scm
index 3f8cf252..cb4a06f3 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -167,31 +167,37 @@
(toval (and tosupplied (##sys#slot rest 0))) )
(##sys#call-with-current-continuation
(lambda (return)
- (let ([ct ##sys#current-thread])
+ (let ((ct ##sys#current-thread))
(when limit (##sys#thread-block-for-timeout! ct limit))
(##sys#setslot
ct 1
(lambda ()
(case (##sys#slot thread 3)
- [(dead)
+ ((dead)
(unless (##sys#slot ct 13) ; not unblocked by timeout
(##sys#remove-from-timeout-list ct))
- (apply return (##sys#slot thread 2))]
- [(terminated)
+ (apply return (##sys#slot thread 2)))
+ ((terminated)
(return
(##sys#signal
(##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)
+ (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) )
+ ((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 16e4bc26..9388a32f 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
@@ -328,6 +329,8 @@ $interpret -s condition-tests.scm
echo "======================================== srfi-18 tests ..."
$interpret -s simple-thread-test.scm
$interpret -s mutex-test.scm
+$compile srfi-18-signal-test.scm
+./a.out
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 00000000..a710192e
--- /dev/null
+++ b/tests/srfi-18-signal-test.scm
@@ -0,0 +1,67 @@
+#+mingw32
+(begin
+ (print "this test can not be run on Windows/mingw unless we find a way to send signals")
+ (exit))
+
+(use srfi-18 posix utils)
+
+(define done #f)
+
+; set done = true on timer expiration
+(set-signal-handler! signal/alrm (lambda (signal) (set! done #t)))
+
+(define (work-loop count)
+ (cond ((> count 100) (error "Loop limit exceeded"))
+ ((not done)
+ (display ".")
+ (thread-sleep! 0.25)
+ (work-loop (add1 count)))))
+
+(define (new-thread)
+ (set! done #f)
+ (make-thread (lambda () (work-loop 0))))
+
+;; Needs external signal (not from another thread) it seems,
+;; so let the OS deliver it to us when we're ready:
+(foreign-declare "#include <sys/time.h>")
+((foreign-lambda* void ()
+ "struct itimerval timer;"
+ "timer.it_value.tv_sec = 1;"
+ "timer.it_value.tv_usec = 0;"
+ "setitimer(ITIMER_REAL, &timer, NULL);"))
+
+(display "Testing correct handling of thread-join! with external signals:")
+(flush-output)
+(let ((t (new-thread)))
+ (thread-start! t)
+ (thread-join! t))
+
+(print " thread terminated gracefully, this is good")
+
+(display "thread-join with timeout: ")
+(flush-output)
+(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:")
+(flush-output)
+(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.")
Trap