0.9.5.46: threads

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

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 3e1c97c..8002d5b 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -13,6 +13,8 @@
 
 (in-package "SB-THREAD") ; this is white-box testing, really
 
+(use-package :test-util)
+
 (defun wait-for-threads (threads)
   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
 
@@ -97,8 +99,7 @@
   (assert (eql (mutex-value l) nil) nil "5"))
 
 (labels ((ours-p (value)
-           (sb-vm:control-stack-pointer-valid-p
-            (sb-sys:int-sap (sb-kernel:get-lisp-obj-address 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)
@@ -108,6 +109,11 @@
       (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)))))
+
 (let ((l (make-spinlock :name "spinlock"))
       (p *current-thread*))
   (assert (eql (spinlock-value l) 0) nil "1")
@@ -149,8 +155,7 @@
 (let ((queue (make-waitqueue :name "queue"))
       (lock (make-mutex :name "lock")))
   (labels ((ours-p (value)
-             (sb-vm:control-stack-pointer-valid-p
-              (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
+             (eq *current-thread* value))
            (in-new-thread ()
              (with-recursive-lock (lock)
                (assert (ours-p (mutex-value lock)))
@@ -174,7 +179,7 @@
              (let ((me *current-thread*))
                (dotimes (i 100)
                  (with-mutex (mutex)
-                   (sleep .1)
+                   (sleep .03)
                    (assert (eql (mutex-value mutex) me)))
                  (assert (not (eql (mutex-value mutex) me))))
                (format t "done ~A~%" *current-thread*))))
@@ -183,6 +188,64 @@
       (format t "contention ~A ~A~%" kid1 kid2)
       (wait-for-threads (list kid1 kid2)))))
 
+;;; semaphores
+
+(defmacro raises-timeout-p (&body body)
+  `(handler-case (progn (progn ,@body) nil)
+    (sb-ext:timeout () t)))
+
+(with-test (:name (:semaphore :wait-forever))
+  (let ((sem (make-semaphore :count 0)))
+    (assert (raises-timeout-p
+              (sb-ext:with-timeout 0.1
+                (wait-on-semaphore sem))))))
+
+(with-test (:name (:semaphore :initial-count))
+  (let ((sem (make-semaphore :count 1)))
+    (sb-ext:with-timeout 0.1
+      (wait-on-semaphore sem))))
+
+(with-test (:name (:semaphore :wait-then-signal))
+  (let ((sem (make-semaphore))
+        (signalled-p nil))
+    (make-thread (lambda ()
+                   (sleep 0.1)
+                   (setq signalled-p t)
+                   (signal-semaphore sem)))
+    (wait-on-semaphore sem)
+    (assert signalled-p)))
+
+(with-test (:name (:semaphore :signal-then-wait))
+  (let ((sem (make-semaphore))
+        (signalled-p nil))
+    (make-thread (lambda ()
+                   (signal-semaphore sem)
+                   (setq signalled-p t)))
+    (loop until signalled-p)
+    (wait-on-semaphore sem)
+    (assert signalled-p)))
+
+(with-test (:name (:semaphore :multiple-signals))
+  (let* ((sem (make-semaphore :count 5))
+         (threads (loop repeat 20
+                        collect (make-thread (lambda ()
+                                               (wait-on-semaphore sem))))))
+    (flet ((count-live-threads ()
+             (count-if #'thread-alive-p threads)))
+      (sleep 0.5)
+      (assert (= 15 (count-live-threads)))
+      (signal-semaphore sem 10)
+      (sleep 0.5)
+      (assert (= 5 (count-live-threads)))
+      (signal-semaphore sem 3)
+      (sleep 0.5)
+      (assert (= 2 (count-live-threads)))
+      (signal-semaphore sem 4)
+      (sleep 0.5)
+      (assert (= 0 (count-live-threads))))))
+
+(format t "~&semaphore tests done~%")
+
 (defun test-interrupt (function-to-interrupt &optional quit-p)
   (let ((child  (make-thread function-to-interrupt)))
     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
@@ -253,7 +316,7 @@
     (interrupt-thread c
                       (lambda ()
                         (princ ".") (force-output)
-                        (assert (eq (thread-state *current-thread*) :running))
+                        (assert (thread-alive-p *current-thread*))
                         (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
   (terminate-thread c)
   (wait-for-threads (list c)))
@@ -400,29 +463,34 @@
 
 (format t "~&session lock test done~%")
 
-(sb-ext:gc :full t)
 (loop repeat 20 do
       (wait-for-threads
        (loop for i below 100 collect
-             (sb-thread:make-thread (lambda ()))))
-      (sb-ext:gc :full t)
-      (princ "+")
-      (force-output))
+             (sb-thread:make-thread (lambda ())))))
 
 (format t "~&creation test done~%")
 
-;; watch out for *current-thread* being the parent thread after exit
-(let ((thread (sb-thread:make-thread (lambda ()))))
-  (wait-for-threads (list thread))
-  (assert (null (symbol-value-in-thread 'sb-thread:*current-thread*
-                                        thread))))
-
 ;; 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 (:thread-start :dynamic-values-and-gc))
+  (let ((gc-thread (sb-thread:make-thread (lambda ()
+                                            (loop (sleep (random 0.2))
+                                                  (sb-ext:gc :full t))))))
+    (wait-for-threads
+     (loop for i below 3000
+           when (zerop (mod i 30))
+           do (princ ".")
+           collect
+           (let ((*x* (lambda ())))
+             (declare (special *x*))
+             (sb-thread:make-thread (lambda () (functionp *x*))))))
+    (sb-thread:terminate-thread gc-thread)
+    (terpri)))
+
 #|  ;; a cll post from eric marsden
 | (defun crash ()
 |   (setq *debugger-hook*