X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=71eb25e96912cd83b90e41473c04d11711f5d3fe;hb=de19b78acd2ecb0f6caedaaedee35031f0c61c1c;hp=3937dadfee12d1eb6cd634441e91adfbd5b11e8c;hpb=955ce74879cc8220d4c97bb1c0f3becd26ad68fc;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 3937dad..71eb25e 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -17,30 +17,25 @@
 (use-package :test-util)
 (use-package "ASSERTOID")
 
-(setf sb-unix::*on-dangerous-select* :error)
+(setf sb-unix::*on-dangerous-wait* :error)
 
 (defun wait-for-threads (threads)
   (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
   (assert (not (some #'sb-thread:thread-alive-p threads))))
 
-(assert (eql 1 (length (list-all-threads))))
+(with-test (:name (:threads :trivia))
+  (assert (eql 1 (length (list-all-threads))))
 
-(assert (eq *current-thread*
-            (find (thread-name *current-thread*) (list-all-threads)
-                  :key #'thread-name :test #'equal)))
+  (assert (eq *current-thread*
+              (find (thread-name *current-thread*) (list-all-threads)
+                    :key #'thread-name :test #'equal)))
 
-(assert (thread-alive-p *current-thread*))
+  (assert (thread-alive-p *current-thread*)))
 
-(let ((a 0))
-  (interrupt-thread *current-thread* (lambda () (setq a 1)))
-  (assert (eql a 1)))
-
-(let ((spinlock (make-spinlock)))
-  (with-spinlock (spinlock)))
-
-(let ((mutex (make-mutex)))
-  (with-mutex (mutex)
-    mutex))
+(with-test (:name (:with-mutex :basics))
+  (let ((mutex (make-mutex)))
+    (with-mutex (mutex)
+      mutex)))
 
 (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
     void
@@ -49,6 +44,11 @@
     void
   (where sb-alien:unsigned-long))
 
+(with-test (:name (:interrupt-thread :basics :no-unwinding))
+  (let ((a 0))
+    (interrupt-thread *current-thread* (lambda () (setq a 1)))
+    (assert (eql a 1))))
+
 (with-test (:name (:interrupt-thread :deferrables-blocked))
   (sb-thread:interrupt-thread sb-thread:*current-thread*
                               (lambda ()
@@ -70,19 +70,21 @@
 
 #-sb-thread (sb-ext:quit :unix-status 104)
 
-(with-test (:name (:interrupt-thread :deferrables-unblocked-by-spinlock))
-  (let ((spinlock (sb-thread::make-spinlock))
+;;;; Now the real tests...
+
+(with-test (:name (:interrupt-thread :deferrables-unblocked-by-lock))
+  (let ((lock (sb-thread::make-mutex))
         (thread (sb-thread:make-thread (lambda ()
                                          (loop (sleep 1))))))
-    (sb-thread::get-spinlock spinlock)
+    (sb-thread::grab-mutex lock)
     (sb-thread:interrupt-thread thread
                                 (lambda ()
                                   (check-deferrables-blocked-or-lose 0)
-                                  (sb-thread::get-spinlock spinlock)
+                                  (sb-thread::grab-mutex lock)
                                   (check-deferrables-unblocked-or-lose 0)
                                   (sb-ext:quit)))
     (sleep 1)
-    (sb-thread::release-spinlock spinlock)))
+    (sb-thread::release-mutex lock)))
 
 ;;; compare-and-swap
 
@@ -105,23 +107,23 @@
 (defincf incf-svref/0 svref 0)
 
 (defmacro def-test-cas (name init incf op)
-  `(progn
-     (defun ,name (n)
-       (declare (fixnum n))
-       (let* ((x ,init)
-              (run nil)
-              (threads
-               (loop repeat 10
-                     collect (sb-thread:make-thread
-                              (lambda ()
-                                (loop until run
-                                   do (sb-thread:thread-yield))
-                                (loop repeat n do (,incf x)))))))
-         (setf run t)
-         (dolist (th threads)
-           (sb-thread:join-thread th))
-         (assert (= (,op x) (* 10 n)))))
-     (,name 200000)))
+  `(with-test (:name ,name)
+     (flet ((,name (n)
+              (declare (fixnum n))
+              (let* ((x ,init)
+                     (run nil)
+                     (threads
+                      (loop repeat 10
+                            collect (sb-thread:make-thread
+                                     (lambda ()
+                                       (loop until run
+                                             do (sb-thread:thread-yield))
+                                       (loop repeat n do (,incf x)))))))
+                (setf run t)
+                (dolist (th threads)
+                  (sb-thread:join-thread th))
+                (assert (= (,op x) (* 10 n))))))
+       (,name 200000))))
 
 (def-test-cas test-cas-car (cons 0 nil) incf-car car)
 (def-test-cas test-cas-cdr (cons nil 0) incf-cdr cdr)
@@ -136,6 +138,7 @@
                                                              (svref x 1)))
 (format t "~&compare-and-swap tests done~%")
 
+(with-test (:name (:threads :more-trivia)))
 (let ((old-threads (list-all-threads))
       (thread (make-thread (lambda ()
                              (assert (find *current-thread* *all-threads*))
@@ -147,16 +150,16 @@
   (sleep 3)
   (assert (not (thread-alive-p thread))))
 
-(with-test (:name '(:join-thread :nlx :default))
+(with-test (:name (:join-thread :nlx :default))
   (let ((sym (gensym)))
     (assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit)))
                                  :default sym)))))
 
-(with-test (:name '(:join-thread :nlx :error))
+(with-test (:name (:join-thread :nlx :error))
   (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
                  join-thread-error))
 
-(with-test (:name '(:join-thread :multiple-values))
+(with-test (:name (:join-thread :multiple-values))
   (assert (equal '(1 2 3)
                  (multiple-value-list
                   (join-thread (make-thread (lambda () (values 1 2 3))))))))
@@ -191,134 +194,169 @@
 
 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
   (format o "void loop_forever() { while(1) ; }~%"))
-(sb-ext:run-program
- #-sunos "cc" #+sunos "gcc"
- (or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC"
-                                  "-shared" "-o" "threads-foreign.so" "threads-foreign.c")
-     #+darwin '(#+x86-64 "-arch" #+x86-64 "x86_64"
-                "-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
-     (error "Missing shared library compilation options for this platform"))
- :search t)
+(sb-ext:run-program "/bin/sh"
+                    '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
+                      "-o" "threads-foreign.so" "threads-foreign.c")
+                    :environment (test-util::test-env))
 (sb-alien:load-shared-object (truename "threads-foreign.so"))
 (sb-alien:define-alien-routine loop-forever sb-alien:void)
 (delete-file "threads-foreign.c")
 
+
 ;;; elementary "can we get a lock and release it again"
-(let ((l (make-mutex :name "foo"))
-      (p *current-thread*))
-  (assert (eql (mutex-value l) nil) nil "1")
-  (sb-thread:get-mutex l)
-  (assert (eql (mutex-value l) p) nil "3")
-  (sb-thread:release-mutex l)
-  (assert (eql (mutex-value l) nil) nil "5"))
-
-(labels ((ours-p (value)
-           (eq *current-thread* value)))
-  (let ((l (make-mutex :name "rec")))
+(with-test (:name (:mutex :basics))
+  (let ((l (make-mutex :name "foo"))
+        (p *current-thread*))
     (assert (eql (mutex-value l) nil) nil "1")
-    (sb-thread:with-recursive-lock (l)
-      (assert (ours-p (mutex-value l)) nil "3")
+    (sb-thread:get-mutex l)
+    (assert (eql (mutex-value l) p) nil "3")
+    (sb-thread:release-mutex l)
+    (assert (eql (mutex-value l) nil) nil "5")))
+
+(with-test (:name (:with-recursive-lock :basics))
+  (labels ((ours-p (value)
+             (eq *current-thread* value)))
+    (let ((l (make-mutex :name "rec")))
+      (assert (eql (mutex-value l) nil) nil "1")
       (sb-thread:with-recursive-lock (l)
-        (assert (ours-p (mutex-value l)) nil "4"))
-      (assert (ours-p (mutex-value l)) nil "5"))
-    (assert (eql (mutex-value l) nil) nil "6")))
-
-(labels ((ours-p (value)
-           (eq *current-thread* value)))
-  (let ((l (make-spinlock :name "rec")))
-    (assert (eql (spinlock-value l) nil) nil "1")
-    (with-recursive-spinlock (l)
-      (assert (ours-p (spinlock-value l)) nil "3")
-      (with-recursive-spinlock (l)
-        (assert (ours-p (spinlock-value l)) nil "4"))
-      (assert (ours-p (spinlock-value l)) nil "5"))
-    (assert (eql (spinlock-value l) nil) nil "6")))
+        (assert (ours-p (mutex-value l)) nil "3")
+        (sb-thread:with-recursive-lock (l)
+          (assert (ours-p (mutex-value l)) nil "4"))
+        (assert (ours-p (mutex-value l)) nil "5"))
+      (assert (eql (mutex-value l) nil) nil "6"))))
 
 (with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
   (let ((l (make-mutex :name "a mutex")))
     (with-mutex (l)
       (with-recursive-lock (l)))))
 
-(with-test (:name (:spinlock :nesting-spinlock-and-recursive-spinlock))
-  (let ((l (make-spinlock :name "a spinlock")))
-    (with-spinlock (l)
-      (with-recursive-spinlock (l)))))
-
-(let ((l (make-spinlock :name "spinlock")))
-  (assert (eql (spinlock-value l) nil) ((spinlock-value l))
-          "spinlock not free (1)")
-  (with-spinlock (l)
-    (assert (eql (spinlock-value l) *current-thread*) ((spinlock-value l))
-            "spinlock not taken"))
-  (assert (eql (spinlock-value l) nil) ((spinlock-value l))
-          "spinlock not free (2)"))
-
 ;; test that SLEEP actually sleeps for at least the given time, even
 ;; if interrupted by another thread exiting/a gc/anything
-(let ((start-time (get-universal-time)))
-  (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
-  (sleep 5)
-  (assert (>= (get-universal-time) (+ 5 start-time))))
-
-
-(let ((queue (make-waitqueue :name "queue"))
-      (lock (make-mutex :name "lock"))
-      (n 0))
-  (labels ((in-new-thread ()
-             (with-mutex (lock)
-               (assert (eql (mutex-value lock) *current-thread*))
-               (format t "~A got mutex~%" *current-thread*)
-               ;; now drop it and sleep
-               (condition-wait queue lock)
-               ;; after waking we should have the lock again
-               (assert (eql (mutex-value lock) *current-thread*))
-               (assert (eql n 1))
-               (decf n))))
-    (make-thread #'in-new-thread)
-    (sleep 2)                           ; give it  a chance to start
-    ;; check the lock is free while it's asleep
-    (format t "parent thread ~A~%" *current-thread*)
-    (assert (eql (mutex-value lock) nil))
-    (with-mutex (lock)
-      (incf n)
-      (condition-notify queue))
-    (sleep 1)))
-
-(let ((queue (make-waitqueue :name "queue"))
-      (lock (make-mutex :name "lock")))
-  (labels ((ours-p (value)
-             (eq *current-thread* value))
-           (in-new-thread ()
-             (with-recursive-lock (lock)
-               (assert (ours-p (mutex-value lock)))
-               (format t "~A got mutex~%" (mutex-value lock))
-               ;; now drop it and sleep
-               (condition-wait queue lock)
-               ;; after waking we should have the lock again
-               (format t "woken, ~A got mutex~%" (mutex-value lock))
-               (assert (ours-p (mutex-value lock))))))
-    (make-thread #'in-new-thread)
-    (sleep 2)                           ; give it  a chance to start
-    ;; check the lock is free while it's asleep
-    (format t "parent thread ~A~%" *current-thread*)
-    (assert (eql (mutex-value lock) nil))
-    (with-recursive-lock (lock)
-      (condition-notify queue))
-    (sleep 1)))
-
-(let ((mutex (make-mutex :name "contended")))
-  (labels ((run ()
-             (let ((me *current-thread*))
-               (dotimes (i 100)
-                 (with-mutex (mutex)
-                   (sleep .03)
-                   (assert (eql (mutex-value mutex) me)))
-                 (assert (not (eql (mutex-value mutex) me))))
-               (format t "done ~A~%" *current-thread*))))
-    (let ((kid1 (make-thread #'run))
-          (kid2 (make-thread #'run)))
-      (format t "contention ~A ~A~%" kid1 kid2)
-      (wait-for-threads (list kid1 kid2)))))
+(with-test (:name (:sleep :continue-sleeping-after-interrupt))
+  (let ((start-time (get-universal-time)))
+    (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
+    (sleep 5)
+    (assert (>= (get-universal-time) (+ 5 start-time)))))
+
+
+(with-test (:name (:condition-wait :basics-1))
+  (let ((queue (make-waitqueue :name "queue"))
+        (lock (make-mutex :name "lock"))
+        (n 0))
+    (labels ((in-new-thread ()
+               (with-mutex (lock)
+                 (assert (eql (mutex-value lock) *current-thread*))
+                 (format t "~A got mutex~%" *current-thread*)
+                 ;; now drop it and sleep
+                 (condition-wait queue lock)
+                 ;; after waking we should have the lock again
+                 (assert (eql (mutex-value lock) *current-thread*))
+                 (assert (eql n 1))
+                 (decf n))))
+      (make-thread #'in-new-thread)
+      (sleep 2)            ; give it  a chance to start
+      ;; check the lock is free while it's asleep
+      (format t "parent thread ~A~%" *current-thread*)
+      (assert (eql (mutex-value lock) nil))
+      (with-mutex (lock)
+        (incf n)
+        (condition-notify queue))
+      (sleep 1))))
+
+(with-test (:name (:condition-wait :basics-2))
+  (let ((queue (make-waitqueue :name "queue"))
+        (lock (make-mutex :name "lock")))
+    (labels ((ours-p (value)
+               (eq *current-thread* value))
+             (in-new-thread ()
+               (with-recursive-lock (lock)
+                 (assert (ours-p (mutex-value lock)))
+                 (format t "~A got mutex~%" (mutex-value lock))
+                 ;; now drop it and sleep
+                 (condition-wait queue lock)
+                 ;; after waking we should have the lock again
+                 (format t "woken, ~A got mutex~%" (mutex-value lock))
+                 (assert (ours-p (mutex-value lock))))))
+      (make-thread #'in-new-thread)
+      (sleep 2)            ; give it  a chance to start
+      ;; check the lock is free while it's asleep
+      (format t "parent thread ~A~%" *current-thread*)
+      (assert (eql (mutex-value lock) nil))
+      (with-recursive-lock (lock)
+        (condition-notify queue))
+      (sleep 1))))
+
+(with-test (:name (:mutex :contention))
+  (let ((mutex (make-mutex :name "contended")))
+    (labels ((run ()
+               (let ((me *current-thread*))
+                 (dotimes (i 100)
+                   (with-mutex (mutex)
+                     (sleep .03)
+                     (assert (eql (mutex-value mutex) me)))
+                   (assert (not (eql (mutex-value mutex) me))))
+                 (format t "done ~A~%" *current-thread*))))
+      (let ((kid1 (make-thread #'run))
+            (kid2 (make-thread #'run)))
+        (format t "contention ~A ~A~%" kid1 kid2)
+        (wait-for-threads (list kid1 kid2))))))
+
+;;; GRAB-MUTEX
+
+(with-test (:name (:grab-mutex :waitp nil))
+  (let ((m (make-mutex)))
+    (with-mutex (m)
+      (assert (null (join-thread (make-thread
+                                  #'(lambda ()
+                                      (grab-mutex m :waitp nil)))))))))
+
+(with-test (:name (:grab-mutex :timeout :acquisition-fail))
+  (let ((m (make-mutex))
+        (w (make-semaphore)))
+    (with-mutex (m)
+      (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))
+  (let ((m (make-mutex))
+        (child))
+    (with-mutex (m)
+      (setq child (make-thread #'(lambda () (grab-mutex m :timeout 1.0))))
+      (sleep 0.2))
+    (assert (eq (join-thread child) 't))))
+
+(with-test (:name (:grab-mutex :timeout+deadline))
+  (let ((m (make-mutex))
+        (w (make-semaphore)))
+    (with-mutex (m)
+      (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))
+  (let ((m (make-mutex)))
+    (with-mutex (m)
+      (assert (eq (join-thread
+                   (make-thread #'(lambda ()
+                                    (sb-sys:with-deadline (:seconds 0.0)
+                                      (handler-case
+                                          (grab-mutex m :waitp nil)
+                                        (sb-sys:deadline-timeout ()
+                                          :deadline))))))
+                  'nil)))))
 
 ;;; semaphores
 
@@ -387,6 +425,15 @@
     (assert (try-semaphore sem))
     (assert (zerop (semaphore-count sem)))))
 
+(with-test (:name (:try-semaphore :trivial-fail :n>1))
+  (assert (eq (try-semaphore (make-semaphore :count 1) 2) 'nil)))
+
+(with-test (:name (:try-semaphore :trivial-success :n>1))
+  (let ((sem (make-semaphore :count 10)))
+    (assert (try-semaphore sem 5))
+    (assert (try-semaphore sem 5))
+    (assert (zerop (semaphore-count sem)))))
+
 (with-test (:name (:try-semaphore :emulate-wait-on-semaphore))
   (flet ((busy-wait-on-semaphore (sem)
            (loop until (try-semaphore sem) do (sleep 0.001))))
@@ -406,12 +453,12 @@
     ;; threads-being-interrupted will perform TRY-SEMAPHORE on that
     ;; semaphore, and MORE-WAITERS are new threads trying to wait on
     ;; the semaphore during the interruption-fire.
-    (let* ((sem (make-semaphore :count 50))
+    (let* ((sem (make-semaphore :count 100))
            (waiters (make-threads 20 #'(lambda ()
                                          (wait-on-semaphore sem))))
            (triers  (make-threads 40 #'(lambda ()
                                          (sleep (random 0.01))
-                                         (try-semaphore sem))))
+                                         (try-semaphore sem (1+ (random 5))))))
            (more-waiters
             (loop repeat 10
                   do (kill-thread (nth (random 40) triers))
@@ -448,35 +495,40 @@
 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
 ;; in pseudo-atomic
 
-(let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
+(with-test (:name (:interrupt-thread :more-basics))
+  (let ((child (test-interrupt (lambda () (loop)))))
+    (terminate-thread child)))
 
-(test-interrupt #'loop-forever :quit)
+(with-test (:name (:interrupt-thread :interrupt-foreign-loop))
+  (test-interrupt #'loop-forever :quit))
 
-(let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
-  (terminate-thread child)
-  (wait-for-threads (list child)))
+(with-test (:name (:interrupt-thread :interrupt-sleep))
+  (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
+    (terminate-thread child)
+    (wait-for-threads (list child))))
 
-(let ((lock (make-mutex :name "loctite"))
-      child)
-  (with-mutex (lock)
-    (setf child (test-interrupt
-                 (lambda ()
-                   (with-mutex (lock)
-                     (assert (eql (mutex-value lock) *current-thread*)))
-                   (assert (not (eql (mutex-value lock) *current-thread*)))
-                   (sleep 10))))
-    ;;hold onto lock for long enough that child can't get it immediately
-    (sleep 5)
-    (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
-    (format t "parent releasing lock~%"))
-  (terminate-thread child)
-  (wait-for-threads (list child)))
+(with-test (:name (:interrupt-thread :interrupt-mutex-acquisition))
+  (let ((lock (make-mutex :name "loctite"))
+        child)
+    (with-mutex (lock)
+      (setf child (test-interrupt
+                   (lambda ()
+                     (with-mutex (lock)
+                       (assert (eql (mutex-value lock) *current-thread*)))
+                     (assert (not (eql (mutex-value lock) *current-thread*)))
+                     (sleep 10))))
+      ;;hold onto lock for long enough that child can't get it immediately
+      (sleep 5)
+      (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
+      (format t "parent releasing lock~%"))
+    (terminate-thread child)
+    (wait-for-threads (list child))))
 
 (format t "~&locking test done~%")
 
 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 
-(progn
+(with-test (:name (:interrupt-thread :interrupt-consing-child))
   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
     (let ((killers
            (loop repeat 4 collect
@@ -494,19 +546,21 @@
 
 (format t "~&multi interrupt test done~%")
 
-(let ((c (make-thread (lambda () (loop (alloc-stuff))))))
-  ;; NB this only works on x86: other ports don't have a symbol for
-  ;; pseudo-atomic atomicity
-  (dotimes (i 100)
-    (sleep (random 0.1d0))
-    (interrupt-thread c
-                      (lambda ()
-                        (princ ".") (force-output)
-                        (assert (thread-alive-p *current-thread*))
-                        (assert
-                         (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
-  (terminate-thread c)
-  (wait-for-threads (list c)))
+#+(or x86 x86-64) ;; x86oid-only, see internal commentary.
+(with-test (:name (:interrupt-thread :interrupt-consing-child :again))
+  (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
+    ;; NB this only works on x86: other ports don't have a symbol for
+    ;; pseudo-atomic atomicity
+    (dotimes (i 100)
+      (sleep (random 0.1d0))
+      (interrupt-thread c
+                        (lambda ()
+                          (princ ".") (force-output)
+                          (assert (thread-alive-p *current-thread*))
+                          (assert
+                           (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
+    (terminate-thread c)
+    (wait-for-threads (list c))))
 
 (format t "~&interrupt test done~%")
 
@@ -520,24 +574,26 @@
   (unless (typep i 'fixnum)
     (error "!!!!!!!!!!!")))
 
-(let ((c (make-thread
-          (lambda ()
-            (handler-bind ((error #'(lambda (cond)
-                                      (princ cond)
-                                      (sb-debug:backtrace
-                                       most-positive-fixnum))))
-              (loop (check-interrupt-count (counter-n *interrupt-counter*))))))))
-  (let ((func (lambda ()
-                (princ ".")
-                (force-output)
-                (sb-ext:atomic-incf (counter-n *interrupt-counter*)))))
-    (setf (counter-n *interrupt-counter*) 0)
-    (dotimes (i 100)
-      (sleep (random 0.1d0))
-      (interrupt-thread c func))
-    (loop until (= (counter-n *interrupt-counter*) 100) do (sleep 0.1))
-    (terminate-thread c)
-    (wait-for-threads (list c))))
+(with-test (:name (:interrupt-thread :interrupt-ATOMIC-INCF))
+  (let ((c (make-thread
+            (lambda ()
+              (handler-bind ((error #'(lambda (cond)
+                                        (princ cond)
+                                        (sb-debug:backtrace
+                                         most-positive-fixnum))))
+                (loop (check-interrupt-count
+                       (counter-n *interrupt-counter*))))))))
+    (let ((func (lambda ()
+                  (princ ".")
+                  (force-output)
+                  (sb-ext:atomic-incf (counter-n *interrupt-counter*)))))
+      (setf (counter-n *interrupt-counter*) 0)
+      (dotimes (i 100)
+        (sleep (random 0.1d0))
+        (interrupt-thread c func))
+      (loop until (= (counter-n *interrupt-counter*) 100) do (sleep 0.1))
+      (terminate-thread c)
+      (wait-for-threads (list c)))))
 
 (format t "~&interrupt count test done~%")
 
@@ -578,54 +634,56 @@
                                   (throw 'xxx *runningp*)))
     (assert (sb-thread:join-thread thread))))
 
-(let (a-done b-done)
-  (make-thread (lambda ()
-                 (dotimes (i 100)
-                   (sb-ext:gc) (princ "\\") (force-output))
-                 (setf a-done t)))
-  (make-thread (lambda ()
-                 (dotimes (i 25)
-                   (sb-ext:gc :full t)
-                   (princ "/") (force-output))
-                 (setf b-done t)))
-  (loop
-   (when (and a-done b-done) (return))
-   (sleep 1)))
+(with-test (:name (:two-threads-running-gc))
+  (let (a-done b-done)
+    (make-thread (lambda ()
+                   (dotimes (i 100)
+                     (sb-ext:gc) (princ "\\") (force-output))
+                   (setf a-done t)))
+    (make-thread (lambda ()
+                   (dotimes (i 25)
+                     (sb-ext:gc :full t)
+                     (princ "/") (force-output))
+                   (setf b-done t)))
+    (loop
+      (when (and a-done b-done) (return))
+      (sleep 1))))
 
 (terpri)
 
 (defun waste (&optional (n 100000))
   (loop repeat n do (make-string 16384)))
 
-(loop for i below 100 do
-      (princ "!")
-      (force-output)
-      (sb-thread:make-thread
-       #'(lambda ()
-           (waste)))
-      (waste)
-      (sb-ext:gc))
+(with-test (:name (:one-thread-runs-gc-while-other-conses))
+  (loop for i below 100 do
+        (princ "!")
+        (force-output)
+        (sb-thread:make-thread
+         #'(lambda ()
+             (waste)))
+        (waste)
+        (sb-ext:gc)))
 
 (terpri)
 
 (defparameter *aaa* nil)
-(loop for i below 100 do
-      (princ "!")
-      (force-output)
-      (sb-thread:make-thread
-       #'(lambda ()
-           (let ((*aaa* (waste)))
-             (waste))))
-      (let ((*aaa* (waste)))
-        (waste))
-      (sb-ext:gc))
+(with-test (:name (:one-thread-runs-gc-while-other-conses :again))
+  (loop for i below 100 do
+        (princ "!")
+        (force-output)
+        (sb-thread:make-thread
+         #'(lambda ()
+             (let ((*aaa* (waste)))
+               (waste))))
+        (let ((*aaa* (waste)))
+          (waste))
+        (sb-ext:gc)))
 
 (format t "~&gc test done~%")
 
 ;; this used to deadlock on session-lock
-(sb-thread:make-thread (lambda () (sb-ext:gc)))
-;; expose thread creation races by exiting quickly
-(sb-thread:make-thread (lambda ()))
+(with-test (:name (:no-session-deadlock))
+  (sb-thread:make-thread (lambda () (sb-ext:gc))))
 
 (defun exercise-syscall (fn reference-errno)
   (sb-thread:make-thread
@@ -643,71 +701,79 @@
               (sb-ext:quit :unix-status 1)))))))
 
 ;; (nanosleep -1 0) does not fail on FreeBSD
-(let* (#-freebsd
-       (nanosleep-errno (progn
-                          (sb-unix:nanosleep -1 0)
-                          (sb-unix::get-errno)))
-       (open-errno (progn
-                     (open "no-such-file"
-                           :if-does-not-exist nil)
-                     (sb-unix::get-errno)))
-       (threads
-        (list
-         #-freebsd
-         (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
-         (exercise-syscall (lambda () (open "no-such-file"
-                                            :if-does-not-exist nil))
-                           open-errno)
-         (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
-  (sleep 10)
-  (princ "terminating threads")
-  (dolist (thread threads)
-    (sb-thread:terminate-thread thread)))
+(with-test (:name (:exercising-concurrent-syscalls))
+  (let* (#-freebsd
+         (nanosleep-errno (progn
+                            (sb-unix:nanosleep -1 0)
+                            (sb-unix::get-errno)))
+         (open-errno (progn
+                       (open "no-such-file"
+                             :if-does-not-exist nil)
+                       (sb-unix::get-errno)))
+         (threads
+          (list
+           #-freebsd
+           (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
+           (exercise-syscall (lambda () (open "no-such-file"
+                                              :if-does-not-exist nil))
+                             open-errno)
+           (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
+    (sleep 10)
+    (princ "terminating threads")
+    (dolist (thread threads)
+      (sb-thread:terminate-thread thread))))
 
 (format t "~&errno test done~%")
 
-(loop repeat 100 do
-      (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
-        (sb-thread:interrupt-thread
-         thread
-         (lambda ()
-           (assert (find-restart 'sb-thread:terminate-thread))))))
+(with-test (:name (:terminate-thread-restart))
+  (loop repeat 100 do
+        (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
+          (sb-thread:interrupt-thread
+           thread
+           (lambda ()
+             (assert (find-restart 'sb-thread:terminate-thread)))))))
 
 (sb-ext:gc :full t)
 
 (format t "~&thread startup sigmask test done~%")
 
-;; FIXME: What is this supposed to test?
-(sb-debug::enable-debugger)
-(let* ((main-thread *current-thread*)
-       (interruptor-thread
-        (make-thread (lambda ()
-                       (sleep 2)
-                       (interrupt-thread main-thread
-                                         (lambda ()
-                                           (with-interrupts
-                                             (break))))
-                       (sleep 2)
-                       (interrupt-thread main-thread #'continue))
-                     :name "interruptor")))
-  (with-session-lock (*session*)
-    (sleep 3))
-  (loop while (thread-alive-p interruptor-thread)))
+(with-test (:name (:debugger-no-hang-on-session-lock-if-interrupted))
+  (sb-debug::enable-debugger)
+  (let* ((main-thread *current-thread*)
+         (interruptor-thread
+          (make-thread (lambda ()
+                         (sleep 2)
+                         (interrupt-thread main-thread
+                                           (lambda ()
+                                             (with-interrupts
+                                               (break))))
+                         (sleep 2)
+                         (interrupt-thread main-thread #'continue))
+                       :name "interruptor")))
+    (with-session-lock (*session*)
+      (sleep 3))
+    (loop while (thread-alive-p interruptor-thread))))
 
 (format t "~&session lock test done~%")
 
-(loop repeat 20 do
-      (wait-for-threads
-       (loop for i below 100 collect
-             (sb-thread:make-thread (lambda ())))))
+;; expose thread creation races by exiting quickly
+(with-test (:name (:no-thread-creation-race :light))
+  (sb-thread:make-thread (lambda ())))
+
+(with-test (:name (:no-thread-creation-race :heavy))
+  (loop repeat 20 do
+        (wait-for-threads
+         (loop for i below 100 collect
+               (sb-thread:make-thread (lambda ()))))))
 
 (format t "~&creation test done~%")
 
 ;; interrupt handlers are per-thread with pthreads, make sure the
 ;; handler installed in one thread is global
-(sb-thread:make-thread
- (lambda ()
-   (sb-ext:run-program "sleep" '("1") :search t :wait nil)))
+(with-test (:name (:global-interrupt-handler))
+  (sb-thread:make-thread
+   (lambda ()
+     (sb-ext:run-program "sleep" '("1") :search t :wait nil))))
 
 ;;;; Binding stack safety
 
@@ -747,11 +813,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)
@@ -778,7 +845,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.
@@ -928,31 +1001,6 @@
 |     (mp:make-process #'roomy)))
 |#
 
-;;; KLUDGE: No deadlines while waiting on lutex-based condition variables. This test
-;;; would just hang.
-#-sb-lutex
-(with-test (:name (:condition-variable :wait-multiple))
-  (loop repeat 40 do
-        (let ((waitqueue (sb-thread:make-waitqueue :name "Q"))
-              (mutex (sb-thread:make-mutex :name "M"))
-              (failedp nil))
-          (format t ".")
-          (finish-output t)
-          (let ((threads (loop repeat 200
-                               collect
-                               (sb-thread:make-thread
-                                (lambda ()
-                                  (handler-case
-                                      (sb-sys:with-deadline (:seconds 0.01)
-                                        (sb-thread:with-mutex (mutex)
-                                          (sb-thread:condition-wait waitqueue
-                                                                    mutex)
-                                          (setq failedp t)))
-                                    (sb-sys:deadline-timeout (c)
-                                      (declare (ignore c)))))))))
-            (mapc #'sb-thread:join-thread threads)
-            (assert (not failedp))))))
-
 (with-test (:name (:condition-variable :notify-multiple))
   (flet ((tester (notify-fun)
            (let ((queue (make-waitqueue :name "queue"))
@@ -993,30 +1041,29 @@
 ;;; Make sure that a deadline handler is not invoked twice in a row in
 ;;; CONDITION-WAIT. See LP #512914 for a detailed explanation.
 ;;;
-#-sb-lutex    ; See KLUDGE above: no deadlines for condition-wait+lutexes.
 (with-test (:name (:condition-wait :deadlines :LP-512914))
-  (let ((n 2) ; was empirically enough to trigger the bug
+  (let ((n 2)                      ; was empirically enough to trigger the bug
         (mutex (sb-thread:make-mutex))
         (waitq (sb-thread:make-waitqueue))
         (threads nil)
         (deadline-handler-run-twice? nil))
     (dotimes (i n)
       (let ((child
-             (sb-thread:make-thread
-              #'(lambda ()
-                  (handler-bind
-                      ((sb-sys:deadline-timeout
-                        (let ((already? nil))
-                          #'(lambda (c)
-                              (when already?
-                                (setq deadline-handler-run-twice? t))
-                              (setq already? t)
-                              (sleep 0.2)
-                              (sb-thread:condition-broadcast waitq)
-                              (sb-sys:defer-deadline 10.0 c)))))
-                    (sb-sys:with-deadline (:seconds 0.1)
-                      (sb-thread:with-mutex (mutex)
-                        (sb-thread:condition-wait waitq mutex))))))))
+              (sb-thread:make-thread
+               #'(lambda ()
+                   (handler-bind
+                       ((sb-sys:deadline-timeout
+                          (let ((already? nil))
+                            #'(lambda (c)
+                                (when already?
+                                  (setq deadline-handler-run-twice? t))
+                                (setq already? t)
+                                (sleep 0.2)
+                                (sb-thread:condition-broadcast waitq)
+                                (sb-sys:defer-deadline 10.0 c)))))
+                     (sb-sys:with-deadline (:seconds 0.1)
+                       (sb-thread:with-mutex (mutex)
+                         (sb-thread:condition-wait waitq mutex))))))))
         (push child threads)))
     (mapc #'sb-thread:join-thread threads)
     (assert (not deadline-handler-run-twice?))))
@@ -1047,7 +1094,8 @@
                            (sb-sys:defer-deadline 10.0 c))))
                    (sb-sys:with-deadline (:seconds 0.1)
                      (sb-thread:with-mutex (mutex)
-                       (sb-thread:condition-wait waitq mutex)))))))
+                       (sb-thread:condition-wait waitq mutex)))))
+             :name "A"))
     (setq B (sb-thread:make-thread
              #'(lambda ()
                  (thread-yield)
@@ -1066,7 +1114,8 @@
                            (sb-sys:defer-deadline 10.0 c))))
                    (sb-sys:with-deadline (:seconds 0.1)
                      (sb-thread:with-mutex (mutex)
-                       (sb-thread:condition-wait waitq mutex)))))))
+                       (sb-thread:condition-wait waitq mutex)))))
+             :name "B"))
     (sb-thread:join-thread A)
     (sb-thread:join-thread B)
     (let ((A-result (list A-holds? A-interrupts-enabled?))
@@ -1078,7 +1127,10 @@
       ;; behaviour.
       (cond ((equal A-result '(t t)) (assert (equal B-result '(nil t))))
             ((equal B-result '(t t)) (assert (equal A-result '(nil t))))
-            (t (error "Failure: fall through."))))))
+            (t
+             (error "Failure: fell through wit A: ~S, B: ~S"
+                    A-result
+                    B-result))))))
 
 (with-test (:name (:mutex :finalization))
   (let ((a nil))
@@ -1120,7 +1172,7 @@
 
 (format t "infodb test done~%")
 
-(with-test (:name (:backtrace))
+(with-test (:name :backtrace)
   ;; Printing backtraces from several threads at once used to hang the
   ;; whole SBCL process (discovered by accident due to a timer.impure
   ;; test misbehaving). The cause was that packages weren't even
@@ -1139,7 +1191,7 @@
 
 (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
 
-(with-test (:name (:gc-deadlock))
+(with-test (:name :gc-deadlock)
   ;; Prior to 0.9.16.46 thread exit potentially deadlocked the
   ;; GC due to *all-threads-lock* and session lock. On earlier
   ;; versions and at least on one specific box this test is good enough
@@ -1158,7 +1210,7 @@
                (sb-thread:make-thread
                 (lambda ()
                   (sleep (random 0.001)))
-                :name (list :sleep i))
+                :name (format nil "SLEEP-~D" i))
                (sb-thread:make-thread
                 (lambda ()
                   ;; KLUDGE: what we are doing here is explicit,
@@ -1168,7 +1220,7 @@
                   (sb-thread::with-all-threads-lock
                     (sb-thread::with-session-lock (sb-thread::*session*)
                       (sb-ext:gc))))
-                :name (list :gc i)))
+                :name (format nil "GC-~D" i)))
          (error (e)
            (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e)
            (sleep 0.1)
@@ -1246,7 +1298,7 @@
   (format t "ok~%")
   (force-output))
 
-(with-test (:name '(:hash-cache :subtypep))
+(with-test (:name (:hash-cache :subtypep))
   (dotimes (i 10)
     (sb-thread:make-thread #'subtypep-hash-cache-test)))
 (format t "hash-cache tests done~%")
@@ -1299,3 +1351,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)))))