X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=794ae61292d88ce1f5cd4cf722eb0e825deb866b;hb=c3af3cf3704ce01c71de96cc36c2798014fc9960;hp=424a6c273000e19757c98cca7d7b0be0bd56d085;hpb=b4799928d368c33c109c2d4a20629c1f8568b0ef;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 424a6c2..794ae61 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -344,11 +344,18 @@
 (with-test (:name (:grab-mutex :timeout :acquisition-fail))
   #+sb-lutex
   (error "Mutex timeout not supported here.")
-  (let ((m (make-mutex)))
+  (let ((m (make-mutex))
+        (w (make-semaphore)))
     (with-mutex (m)
-      (assert (null (join-thread (make-thread
-                                  #'(lambda ()
-                                      (grab-mutex m :timeout 0.1)))))))))
+      (let ((th (make-thread
+                 #'(lambda ()
+                     (prog1
+                         (grab-mutex m :timeout 0.1)
+                       (signal-semaphore w))))))
+        ;; Wait for it to -- otherwise the detect the deadlock chain
+        ;; from JOIN-THREAD.
+        (wait-on-semaphore w)
+        (assert (null (join-thread th)))))))
 
 (with-test (:name (:grab-mutex :timeout :acquisition-success))
   #+sb-lutex
@@ -363,16 +370,18 @@
 (with-test (:name (:grab-mutex :timeout+deadline))
   #+sb-lutex
   (error "Mutex timeout not supported here.")
-  (let ((m (make-mutex)))
+  (let ((m (make-mutex))
+        (w (make-semaphore)))
     (with-mutex (m)
-      (assert (eq (join-thread
-                   (make-thread #'(lambda ()
-                                    (sb-sys:with-deadline (:seconds 0.0)
-                                      (handler-case
-                                          (grab-mutex m :timeout 0.0)
-                                        (sb-sys:deadline-timeout ()
-                                          :deadline))))))
-                  :deadline)))))
+      (let ((th (make-thread #'(lambda ()
+                                 (sb-sys:with-deadline (:seconds 0.0)
+                                   (handler-case
+                                       (grab-mutex m :timeout 0.0)
+                                     (sb-sys:deadline-timeout ()
+                                       (signal-semaphore w)
+                                       :deadline)))))))
+        (wait-on-semaphore w)
+        (assert (eq (join-thread th) :deadline))))))
 
 (with-test (:name (:grab-mutex :waitp+deadline))
   #+sb-lutex
@@ -843,11 +852,12 @@
    ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
    ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
    ;; unbinding but values are not).
-   (let ((*x* nil))
+   (let ((*x* nil)
+         (binding-pointer-delta (ash 2 (- sb-vm:word-shift sb-vm:n-fixnum-tag-bits))))
      ;; bump bsp as if a BIND had just started
-     (incf sb-vm::*binding-stack-pointer* 2)
+     (incf sb-vm::*binding-stack-pointer* binding-pointer-delta)
      (wait-for-gc)
-     (decf sb-vm::*binding-stack-pointer* 2))))
+     (decf sb-vm::*binding-stack-pointer* binding-pointer-delta))))
 
 (with-test (:name (:binding-stack-gc-safety))
   (let (threads)
@@ -874,7 +884,13 @@
   (sb-debug:backtrace)
   (catch 'done))
 
-(with-test (:name (:unsynchronized-hash-table))
+(with-test (:name (:unsynchronized-hash-table)
+                  ;; FIXME: This test occasionally eats out craploads
+                  ;; of heap instead of expected error early. Not 100%
+                  ;; sure if it would finish as expected, but since it
+                  ;; hits swap on my system I'm not likely to find out
+                  ;; soon. Disabling for now. -- nikodemus
+            :skipped-on :sbcl)
   ;; We expect a (probable) error here: parellel readers and writers
   ;; on a hash-table are not expected to work -- but we also don't
   ;; expect this to corrupt the image.
@@ -1376,3 +1392,55 @@
             (format t "~%joined ~S~%" (sb-thread:thread-name th)))
           (list d1 d2 d3 i))))
 (format t "parallel defclass test done~%")
+
+(with-test (:name (:deadlock-detection :interrupts))
+  (let* ((m1 (sb-thread:make-mutex :name "M1"))
+         (m2 (sb-thread:make-mutex :name "M2"))
+         (t1 (sb-thread:make-thread
+              (lambda ()
+                (sb-thread:with-mutex (m1)
+                  (sleep 0.3)
+                  :ok))
+              :name "T1"))
+         (t2 (sb-thread:make-thread
+              (lambda ()
+                (sleep 0.1)
+                (sb-thread:with-mutex (m1 :wait-p t)
+                  (sleep 0.2)
+                  :ok))
+              :name "T2")))
+    (sleep 0.2)
+    (sb-thread:interrupt-thread t2 (lambda ()
+                                     (sb-thread:with-mutex (m2 :wait-p t)
+                                       (sleep 0.3))))
+    (sleep 0.05)
+    (sb-thread:interrupt-thread t1 (lambda ()
+                                     (sb-thread:with-mutex (m2 :wait-p t)
+                                       (sleep 0.3))))
+    ;; both threads should finish without a deadlock or deadlock
+    ;; detection error
+    (let ((res (list (sb-thread:join-thread t1)
+                     (sb-thread:join-thread t2))))
+      (assert (equal '(:ok :ok) res)))))
+
+(with-test (:name (:deadlock-detection :gc))
+  ;; To semi-reliably trigger the error (in SBCL's where)
+  ;; it was present you had to run this for > 30 seconds,
+  ;; but that's a bit long for a single test.
+  (let* ((stop (+ 5 (get-universal-time)))
+         (m1 (sb-thread:make-mutex :name "m1"))
+         (t1 (sb-thread:make-thread
+              (lambda ()
+                (loop until (> (get-universal-time) stop)
+                      do (sb-thread:with-mutex (m1)
+                           (eval `(make-array 24))))
+                :ok)))
+         (t2 (sb-thread:make-thread
+              (lambda ()
+                (loop until (> (get-universal-time) stop)
+                      do (sb-thread:with-mutex (m1)
+                           (eval `(make-array 24))))
+                :ok))))
+    (let ((res (list (sb-thread:join-thread t1)
+                     (sb-thread:join-thread t2))))
+      (assert (equal '(:ok :ok) res)))))