Re: deadlock in scm_join_thread(_timed)

[Neil Jerram]

address@hidden (Ludovic Courtès) writes:

> Hello!
>
> Neil Jerram <address@hidden> writes:
>
>> Here is a proposed patch for branch_release-1-8.
>
> At first sight this looks good to me.

Thanks!  And here's the corresponding patch for master.  It's slightly
different, because scm_join_thread_timed in master allows for the join
attempt timing out and should return a special timeout value in that
case.  Also I had to fix another problem, wait-condition-variable
leaving asyncs blocked, before I could reproduce the
scm_join_thread_timed issue in threads.test, so a patch for that
problem is attached too.

Regards,
      Neil

>From a83a927bdbd6d5b971aa6f8172b78a2cdf34a5ef Mon Sep 17 00:00:00 2001
From: Neil Jerram <address@hidden>
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

>From 01404cdfacabf49a7b834837bd3c2acebaefc591 Mon Sep 17 00:00:00 2001
From: Neil Jerram <address@hidden>
Date: Wed, 20 May 2009 21:55:35 +0100
Subject: [PATCH] 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.
---
 libguile/threads.c            |   10 ++++++++++
 test-suite/tests/threads.test |   26 +++++++++++++++++++++++++-
 2 files changed, 35 insertions(+), 1 deletions(-)

diff --git a/libguile/threads.c b/libguile/threads.c
index 947e595..d63c619 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 bd9f2f3..6d877b1 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -257,7 +257,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
-- 
1.5.6.5