1.0.26.4: less pessimal waitqueues

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

diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index 6b58125..cb1a827 100644 (file)
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -20,6 +20,24 @@
 
 (use-package :test-util)
 
+(with-test (:name mutex-owner)
+  ;; Make sure basics are sane on unithreaded ports as well
+  (let ((mutex (make-mutex)))
+    (get-mutex mutex)
+    (assert (eq *current-thread* (mutex-value mutex)))
+    (handler-bind ((warning #'error))
+      (release-mutex mutex))
+    (assert (not (mutex-value mutex)))))
+
+(with-test (:name spinlock-owner)
+  ;; Make sure basics are sane on unithreaded ports as well
+  (let ((spinlock (sb-thread::make-spinlock)))
+    (sb-thread::get-spinlock spinlock)
+    (assert (eq *current-thread* (sb-thread::spinlock-value spinlock)))
+    (handler-bind ((warning #'error))
+      (sb-thread::release-spinlock spinlock))
+    (assert (not (sb-thread::spinlock-value spinlock)))))
+
 ;;; Terminating a thread that's waiting for the terminal.
 
 #+sb-thread
@@ -54,14 +72,13 @@
 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
 
 #+sb-thread
-(with-test (:name without-interrupts+get-mutex
-            :fails-on :sb-lutex)
+(with-test (:name without-interrupts+get-mutex)
   (let* ((lock (make-mutex))
-         (foo (get-mutex lock))
+         (bar (progn (get-mutex lock) nil))
          (thread (make-thread (lambda ()
                                 (sb-sys:without-interrupts
-                                  (with-mutex (lock)
-                                    :fini))))))
+                                    (with-mutex (lock)
+                                      (setf bar t)))))))
     (sleep 1)
     (assert (thread-alive-p thread))
     (terminate-thread thread)
@@ -70,4 +87,73 @@
     (release-mutex lock)
     (sleep 1)
     (assert (not (thread-alive-p thread)))
-    (assert (eq :fini (join-thread thread)))))
+    (assert (eq :aborted (join-thread thread :default :aborted)))
+    (assert bar)))
+
+#+sb-thread
+(with-test (:name parallel-find-class)
+  (let* ((oops nil)
+         (threads (loop repeat 10
+                        collect (make-thread (lambda ()
+                                               (handler-case
+                                                   (loop repeat 10000
+                                                         do (find-class (gensym) nil))
+                                                 (serious-condition ()
+                                                   (setf oops t))))))))
+    (mapcar #'sb-thread:join-thread threads)
+    (assert (not oops))))
+
+#+sb-thread
+(with-test (:name :semaphore-multiple-waiters)
+  (let ((semaphore (make-semaphore :name "test sem")))
+    (labels ((make-readers (n i)
+               (values
+                (loop for r from 0 below n
+                      collect
+                      (sb-thread:make-thread
+                       (lambda ()
+                         (let ((sem semaphore))
+                           (dotimes (s i)
+                             (sb-thread:wait-on-semaphore sem))))
+                       :name "reader"))
+                (* n i)))
+             (make-writers (n readers i)
+               (let ((j (* readers i)))
+                 (multiple-value-bind (k rem) (truncate j n)
+                   (values
+                    (let ((writers
+                           (loop for w from 0 below n
+                                 collect
+                                 (sb-thread:make-thread
+                                  (lambda ()
+                                    (let ((sem semaphore))
+                                      (dotimes (s k)
+                                        (sb-thread:signal-semaphore sem))))
+                                  :name "writer"))))
+                      (assert (zerop rem))
+                      writers)
+                    (+ rem (* n k))))))
+             (test (r w n)
+               (multiple-value-bind (readers x) (make-readers r n)
+                 (assert (= (length readers) r))
+                 (multiple-value-bind (writers y) (make-writers w r n)
+                   (assert (= (length writers) w))
+                   (assert (= x y))
+                   (mapc #'sb-thread:join-thread writers)
+                   (mapc #'sb-thread:join-thread readers)
+                   (assert (zerop (sb-thread:semaphore-count semaphore)))
+                   (values)))))
+      (assert
+       (eq :ok
+           (handler-case
+               (sb-ext:with-timeout 10
+                 (test 1 1 100)
+                 (test 2 2 10000)
+                 (test 4 2 10000)
+                 (test 4 2 10000)
+                 (test 10 10 10000)
+                 (test 10 1 10000)
+                 :ok)
+             (sb-ext:timeout ()
+               :timeout)))))))
+