1.0.48.16: deadlock detection fixes

 * The same deadlock may be reported in multiple threads: adjust tests
   to account for that.

 * CHECK-DEADLOCK/DEADLOCK-CHAIN could signal an error if the deadlock
   had disappeared between its detection and building up the chain due
   to one of the involved threads unwinding.

   To flush out issues like this a bit better, added looping to some
   of the deadlock tests.

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index ba189b3..89c5111 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -443,9 +443,11 @@ HOLDING-MUTEX-P."
                             (detect-deadlock other-lock)))))))
              (deadlock-chain (thread lock)
                (let* ((other-thread (lock-owner lock))
-                      (other-lock (thread-waiting-for other-thread)))
+                      (other-lock (when other-thread
+                                    (thread-waiting-for other-thread))))
                  (cond ((not other-thread)
-                        ;; The deadlock is gone -- maybe someone timed out?
+                        ;; The deadlock is gone -- maybe someone unwound
+                        ;; from the same deadlock already?
                         (return-from check-deadlock nil))
                        ((consp other-lock)
                         ;; There's a timeout -- no deadlock.

diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index aaa32ca..9b6e91e 100644 (file)
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -307,28 +307,33 @@
 
 #+sb-thread
 (with-test (:name deadlock-detection.1)
-  (flet ((test (ma mb sa sb)
-           (lambda ()
-             (handler-case
-                 (sb-thread:with-mutex (ma)
-                   (sb-thread:signal-semaphore sa)
-                   (sb-thread:wait-on-semaphore sb)
-                   (sb-thread:with-mutex (mb)
-                     :ok))
-               (sb-thread:thread-deadlock (e)
-                 (princ e)
-                 :deadlock)))))
-    (let* ((m1 (sb-thread:make-mutex :name "M1"))
-           (m2 (sb-thread:make-mutex :name "M2"))
-           (s1 (sb-thread:make-semaphore :name "S1"))
-           (s2 (sb-thread:make-semaphore :name "S2"))
-           (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
-           (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
-      ;; One will deadlock, and the other will then complete normally
-      (let ((res (list (sb-thread:join-thread t1)
-                       (sb-thread:join-thread t2))))
-        (assert (or (equal '(:deadlock :ok) res)
-                    (equal '(:ok :deadlock) res)))))))
+  (loop
+    repeat 1000
+    do (flet ((test (ma mb sa sb)
+                (lambda ()
+                  (handler-case
+                      (sb-thread:with-mutex (ma)
+                        (sb-thread:signal-semaphore sa)
+                        (sb-thread:wait-on-semaphore sb)
+                        (sb-thread:with-mutex (mb)
+                          :ok))
+                    (sb-thread:thread-deadlock (e)
+                      (princ e)
+                      :deadlock)))))
+         (let* ((m1 (sb-thread:make-mutex :name "M1"))
+                (m2 (sb-thread:make-mutex :name "M2"))
+                (s1 (sb-thread:make-semaphore :name "S1"))
+                (s2 (sb-thread:make-semaphore :name "S2"))
+                (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
+                (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
+           ;; One will deadlock, and the other will then complete normally.
+           ;; ...except sometimes, when we get unlucky, and both will do
+           ;; the deadlock detection in parallel and both signal.
+           (let ((res (list (sb-thread:join-thread t1)
+                            (sb-thread:join-thread t2))))
+             (assert (or (equal '(:deadlock :ok) res)
+                         (equal '(:ok :deadlock) res)
+                         (equal '(:deadlock :deadlock) res))))))))
 
 #+sb-thread
 (with-test (:name deadlock-detection.2)
@@ -401,28 +406,33 @@
 
 #+sb-thread
 (with-test (:name deadlock-detection.4)
-  (flet ((test (ma mb sa sb)
-           (lambda ()
-             (handler-case
-                 (sb-thread::with-spinlock (ma)
-                   (sb-thread:signal-semaphore sa)
-                   (sb-thread:wait-on-semaphore sb)
-                   (sb-thread::with-spinlock (mb)
-                     :ok))
-               (sb-thread:thread-deadlock (e)
-                 (princ e)
-                 :deadlock)))))
-    (let* ((m1 (sb-thread::make-spinlock :name "M1"))
-           (m2 (sb-thread::make-spinlock :name "M2"))
-           (s1 (sb-thread:make-semaphore :name "S1"))
-           (s2 (sb-thread:make-semaphore :name "S2"))
-           (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
-           (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
-      ;; One will deadlock, and the other will then complete normally
-      (let ((res (list (sb-thread:join-thread t1)
-                       (sb-thread:join-thread t2))))
-        (assert (or (equal '(:deadlock :ok) res)
-                    (equal '(:ok :deadlock) res)))))))
+  (loop
+    repeat 1000
+    do (flet ((test (ma mb sa sb)
+                (lambda ()
+                  (handler-case
+                      (sb-thread::with-spinlock (ma)
+                        (sb-thread:signal-semaphore sa)
+                        (sb-thread:wait-on-semaphore sb)
+                        (sb-thread::with-spinlock (mb)
+                          :ok))
+                    (sb-thread:thread-deadlock (e)
+                      (princ e)
+                      :deadlock)))))
+         (let* ((m1 (sb-thread::make-spinlock :name "M1"))
+                (m2 (sb-thread::make-spinlock :name "M2"))
+                (s1 (sb-thread:make-semaphore :name "S1"))
+                (s2 (sb-thread:make-semaphore :name "S2"))
+                (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
+                (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
+           ;; One will deadlock, and the other will then complete normally
+           ;; ...except sometimes, when we get unlucky, and both will do
+           ;; the deadlock detection in parallel and both signal.
+           (let ((res (list (sb-thread:join-thread t1)
+                            (sb-thread:join-thread t2))))
+             (assert (or (equal '(:deadlock :ok) res)
+                         (equal '(:ok :deadlock) res)
+                         (equal '(:deadlock :deadlock) res))))))))
 
 #+sb-thread
 (with-test (:name deadlock-detection.5)

diff --git a/version.lisp-expr b/version.lisp-expr
index 78f6210..ff8ac68 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.48.15"
+"1.0.48.16"