Remove possible deadlock in scm_join_thread_timed

* libguile/threads.c (scm_join_thread_timed): Recheck t->exited before
  looping round to call block_self again, in case thread t has now
  exited.

* test-suite/tests/threads.test ("don't hang when joined thread
  terminates in SCM_TICK"): New test.

2 files changed, 35 insertions, 1 deletions

diff --git a/libguile/threads.c b/libguile/threads.c
index 947e59546..d63c6197e 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1161,6 +1161,16 @@ SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0,
 	  scm_i_pthread_mutex_unlock (&t->admin_mutex);
 	  SCM_TICK;
 	  scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
+
+	  /* Check for exit again, since we just released and
+	     reacquired the admin mutex, before the next block_self
+	     call (which would block forever if t has already
+	     exited). */
+	  if (t->exited)
+	    {
+	      res = t->result;
+	      break;
+	    }
 	}
     }
 
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index 62048eaba..6400d2dd8 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -265,7 +265,31 @@
 	(pass-if "asyncs are still working 1"
 	  (asyncs-still-working?))
 
-	)
+	;; scm_join_thread_timed has a SCM_TICK in the middle of it,
+	;; to allow asyncs to run (including signal delivery).  We
+	;; used to have a bug whereby if the joined thread terminated
+	;; at the same time as the joining thread is in this SCM_TICK,
+	;; scm_join_thread_timed would not notice and would hang
+	;; forever.  So in this test we are setting up the following
+	;; sequence of events.
+        ;;   T=0  other thread is created and starts running
+	;;   T=2  main thread sets up an async that will sleep for 10 seconds
+        ;;   T=2  main thread calls join-thread, which will...
+        ;;   T=2  ...call the async, which starts sleeping
+        ;;   T=5  other thread finishes its work and terminates
+        ;;   T=7  async completes, main thread continues inside join-thread.
+	(pass-if "don't hang when joined thread terminates in SCM_TICK"
+	  (let ((other-thread (make-thread sleep 5)))
+	    (letrec ((delay-count 10)
+		     (aproc (lambda ()
+			      (set! delay-count (- delay-count 1))
+			      (if (zero? delay-count)
+				  (sleep 5)
+				  (system-async-mark aproc)))))
+	      (sleep 2)
+	      (system-async-mark aproc)
+	      (join-thread other-thread)))
+	  #t))
 
       ;;
       ;; thread cancellation