X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.pure.lisp;h=e58cda7aa7d4512b20f9e208cb4d4ef14d9317a2;hb=219cc40793f9c82fb943b29a1846f898f4f9de1e;hp=3d6d119b4e8e9f0533c93de0f6c34887b513e732;hpb=b56c1a4dc22aa0ac827343667584aa6090b15f02;p=sbcl.git

diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index 3d6d119..e58cda7 100644
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -307,13 +307,10 @@
                 (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))))))))
+                         (equal '(:ok :deadlock) res))))))))
 
 (with-test (:name deadlock-detection.2 :skipped-on '(not :sb-thread))
   (let* ((m1 (sb-thread:make-mutex :name "M1"))
@@ -495,3 +492,60 @@
                 (join-thread (make-thread (lambda () (sleep 10)))
                              :timeout 0.01
                              :default cookie)))))
+
+(with-test (:name (:semaphore-notification :wait-on-semaphore)
+            :skipped-on '(not :sb-thread))
+  (let ((sem (make-semaphore))
+        (ok nil)
+        (n 0))
+    (flet ((critical ()
+             (let ((note (make-semaphore-notification)))
+               (sb-sys:without-interrupts
+                 (unwind-protect
+                      (progn
+                        (sb-sys:with-local-interrupts
+                          (wait-on-semaphore sem :notification note)
+                          (sleep (random 0.1)))
+                        (incf n))
+                   ;; Re-increment on exit if we decremented it.
+                   (when (semaphore-notification-status note)
+                     (signal-semaphore sem))
+                   ;; KLUDGE: Prevent interrupts after this point from
+                   ;; unwinding us, so that we can reason about the counts.
+                   #+sb-thread
+                   (sb-thread::block-deferrable-signals))))))
+      (let* ((threads (loop for i from 1 upto 100
+                            collect (make-thread #'critical :name (format nil "T~A" i))))
+             (safe nil)
+             (unsafe nil)
+             (interruptor (make-thread (lambda ()
+                                         (loop until ok)
+                                         (let (x)
+                                           (dolist (thread threads)
+                                             (cond (x
+                                                    (push thread unsafe)
+                                                    (sleep (random 0.1))
+                                                    (ignore-errors
+                                                     (terminate-thread thread)))
+                                                   (t
+                                                    (push thread safe)))
+                                             (setf x (not x))))))))
+        (signal-semaphore sem)
+        (setf ok t)
+        (join-thread interruptor)
+        (mapc #'join-thread safe)
+        (let ((k (count-if (lambda (th)
+                             (join-thread th :default nil))
+                           unsafe)))
+          (assert (= n (+ k (length safe))))
+          (assert unsafe))))))
+
+(with-test (:name (:semaphore-notification :try-sempahore)
+            :skipped-on '(not :sb-thread))
+  (let* ((sem (make-semaphore))
+         (note (make-semaphore-notification)))
+    (try-semaphore sem 1 note)
+    (assert (not (semaphore-notification-status note)))
+    (signal-semaphore sem)
+    (try-semaphore sem 1 note)
+    (assert (semaphore-notification-status note))))