1.0.33.22: fix WITH-MUTEX docstring

[sbcl.git] / tests / threads.impure.lisp

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 3672c92..3eb0fe0 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -42,8 +42,48 @@
   (with-mutex (mutex)
     mutex))
 
+(sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
+    void
+  (where sb-alien:unsigned-long))
+(sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
+    void
+  (where sb-alien:unsigned-long))
+
+(with-test (:name (:interrupt-thread :deferrables-blocked))
+  (sb-thread:interrupt-thread sb-thread:*current-thread*
+                              (lambda ()
+                                (check-deferrables-blocked-or-lose 0))))
+
+(with-test (:name (:interrupt-thread :deferrables-unblocked))
+  (sb-thread:interrupt-thread sb-thread:*current-thread*
+                              (lambda ()
+                                (with-interrupts
+                                  (check-deferrables-unblocked-or-lose 0)))))
+
+(with-test (:name (:interrupt-thread :nlx))
+  (catch 'xxx
+    (sb-thread:interrupt-thread sb-thread:*current-thread*
+                                (lambda ()
+                                  (check-deferrables-blocked-or-lose 0)
+                                  (throw 'xxx nil))))
+  (check-deferrables-unblocked-or-lose 0))
+
 #-sb-thread (sb-ext:quit :unix-status 104)
 
+(with-test (:name (:interrupt-thread :deferrables-unblocked-by-spinlock))
+  (let ((spinlock (sb-thread::make-spinlock))
+        (thread (sb-thread:make-thread (lambda ()
+                                         (loop (sleep 1))))))
+    (sb-thread::get-spinlock spinlock)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                  (check-deferrables-blocked-or-lose 0)
+                                  (sb-thread::get-spinlock spinlock)
+                                  (check-deferrables-unblocked-or-lose 0)
+                                  (sb-ext:quit)))
+    (sleep 1)
+    (sb-thread::release-spinlock spinlock)))
+
 ;;; compare-and-swap
 
 (defmacro defincf (name accessor &rest args)
@@ -113,7 +153,8 @@
                                  :default sym)))))
 
 (with-test (:name '(:join-thread :nlx :error))
-  (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))))
+  (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
+                 join-thread-error))
 
 (with-test (:name '(:join-thread :multiple-values))
   (assert (equal '(1 2 3)
@@ -415,7 +456,8 @@
 
 (format t "~&interrupt test done~%")
 
-(defparameter *interrupt-count* 0)
+(defstruct counter (n 0 :type sb-vm:word))
+(defvar *interrupt-counter* (make-counter))
 
 (declaim (notinline check-interrupt-count))
 (defun check-interrupt-count (i)
@@ -430,21 +472,58 @@
                                       (princ cond)
                                       (sb-debug:backtrace
                                        most-positive-fixnum))))
-              (loop (check-interrupt-count *interrupt-count*)))))))
+              (loop (check-interrupt-count (counter-n *interrupt-counter*))))))))
   (let ((func (lambda ()
                 (princ ".")
                 (force-output)
-                (sb-impl::atomic-incf/symbol *interrupt-count*))))
-    (setq *interrupt-count* 0)
+                (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 (= *interrupt-count* 100) do (sleep 0.1))
+    (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~%")
 
+(defvar *runningp* nil)
+
+(with-test (:name (:interrupt-thread :no-nesting))
+  (let ((thread (sb-thread:make-thread
+                 (lambda ()
+                   (catch 'xxx
+                     (loop))))))
+    (declare (special runningp))
+    (sleep 0.2)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                    (let ((*runningp* t))
+                                      (sleep 1))))
+    (sleep 0.2)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                  (throw 'xxx *runningp*)))
+    (assert (not (sb-thread:join-thread thread)))))
+
+(with-test (:name (:interrupt-thread :nesting))
+  (let ((thread (sb-thread:make-thread
+                 (lambda ()
+                   (catch 'xxx
+                     (loop))))))
+    (declare (special runningp))
+    (sleep 0.2)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                  (let ((*runningp* t))
+                                    (sb-sys:with-interrupts
+                                      (sleep 1)))))
+    (sleep 0.2)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                  (throw 'xxx *runningp*)))
+    (assert (sb-thread:join-thread thread))))
+
 (let (a-done b-done)
   (make-thread (lambda ()
                  (dotimes (i 100)
@@ -550,7 +629,10 @@
        (interruptor-thread
         (make-thread (lambda ()
                        (sleep 2)
-                       (interrupt-thread main-thread #'break)
+                       (interrupt-thread main-thread
+                                         (lambda ()
+                                           (with-interrupts
+                                             (break))))
                        (sleep 2)
                        (interrupt-thread main-thread #'continue))
                      :name "interruptor")))
@@ -792,6 +874,31 @@
 |     (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"))