X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=f9bec102ca542fed5b9d1afef800687a0d03c91b;hb=a8781d6c5b68a6b08315e98f70a407d992e07363;hp=5aa51926051c96a92f2e18eacb56a88571d0ec02;hpb=a98bbf0cf10b8136707995a00a1c7240c05d02a9;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 5aa5192..f9bec10 100644
--- 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)))
 
@@ -183,6 +185,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)
@@ -417,6 +477,12 @@
   (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)))
+
 #|  ;; a cll post from eric marsden
 | (defun crash ()
 |   (setq *debugger-hook*
@@ -429,9 +495,3 @@
 |     (mp:make-process #'roomy)
 |     (mp:make-process #'roomy)))
 |#
-
-;; give the other thread time to die before we leave, otherwise the
-;; overall exit status is 0, not 104
-(sleep 2)
-
-(sb-ext:quit :unix-status 104)