[Guile-commits] GNU Guile branch, master, updated. 21346c4f5e30910e3950c40bc267bb4249973240

[Neil Jerram]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=21346c4f5e30910e3950c40bc267bb4249973240

The branch, master has been updated
       via  21346c4f5e30910e3950c40bc267bb4249973240 (commit)
       via  4201062de5e4f2eb7b2207a3c09e02a12b9bda50 (commit)
      from  b579617b2db0e83f620c5b856dcc320cea9d6d1f (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 21346c4f5e30910e3950c40bc267bb4249973240
Author: Neil Jerram <address@hidden>
Date:   Wed May 20 21:55:35 2009 +0100

    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.

commit 4201062de5e4f2eb7b2207a3c09e02a12b9bda50
Author: Neil Jerram <address@hidden>
Date:   Sat May 23 17:55:58 2009 +0100

    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.

-----------------------------------------------------------------------

Summary of changes:
 libguile/threads.c            |   11 +++++++
 test-suite/tests/threads.test |   67 +++++++++++++++++++++++++++++++++++++++-
 2 files changed, 76 insertions(+), 2 deletions(-)

diff --git a/libguile/threads.c b/libguile/threads.c
index bb874e2..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;
+           }
        }
     }
 
@@ -1491,6 +1501,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..6400d2d 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -21,6 +21,20 @@
   :use-module (ice-9 threads)
   :use-module (test-suite lib))
 
+(define (asyncs-still-working?)
+  (let ((a #f))
+    (system-async-mark (lambda ()
+                        (set! a #t)))
+    ;; The point of the following (equal? ...) is to go through
+    ;; primitive code (scm_equal_p) that includes a SCM_TICK call and
+    ;; hence gives system asyncs a chance to run.  Of course the
+    ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the
+    ;; near future we may be using the VM instead of the traditional
+    ;; compiler, and then we will still want asyncs-still-working? to
+    ;; work.  (The VM should probably have SCM_TICK calls too, but
+    ;; let's not rely on that here.)
+    (equal? '(a b c) '(a b c))
+    a))
 
 (if (provided? 'threads)
     (begin
@@ -101,6 +115,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 +160,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 +187,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 +200,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 +260,36 @@
 
        (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?))
+
+       ;; 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


hooks/post-receive
-- 
GNU Guile