X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=b4e5bba343a93bb373a1b41192ed8a2c7414fe4d;hb=0b5119848b6b8713e473fa669356645747e11dbd;hp=48bf07ee101a8fd0e20a0e704a179ecb47d0052b;hpb=13adeede88d026548e4d2da497f93d8024706a2b;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 48bf07e..b4e5bba 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -13,6 +13,11 @@ (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))) + (assert (eql 1 (length (list-all-threads)))) (assert (eq *current-thread* @@ -54,7 +59,8 @@ ;; Start NTHREADS idle threads. (dotimes (i nthreads) (sb-thread:make-thread (lambda () - (sb-thread:condition-wait queue mutex) + (with-mutex (mutex) + (sb-thread:condition-wait queue mutex)) (sb-ext:quit)))) (let ((start-time (get-internal-run-time))) (funcall function) @@ -176,7 +182,66 @@ (format t "done ~A~%" *current-thread*)))) (let ((kid1 (make-thread #'run)) (kid2 (make-thread #'run))) - (format t "contention ~A ~A~%" kid1 kid2)))) + (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))) @@ -199,7 +264,8 @@ (test-interrupt #'loop-forever :quit) (let ((child (test-interrupt (lambda () (loop (sleep 2000)))))) - (terminate-thread child)) + (terminate-thread child) + (wait-for-threads (list child))) (let ((lock (make-mutex :name "loctite")) child) @@ -214,7 +280,8 @@ (sleep 5) (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock)))) (format t "parent releasing lock~%")) - (terminate-thread child)) + (terminate-thread child) + (wait-for-threads (list child))) (format t "~&locking test done~%") @@ -230,11 +297,10 @@ (sleep (random 0.1d0)) (princ ".") (force-output) - (sb-thread:interrupt-thread - thread - (lambda ())))))))) - (loop while (some #'thread-alive-p killers) do (sleep 0.1)) - (sb-thread:terminate-thread thread))) + (sb-thread:interrupt-thread thread (lambda ())))))))) + (wait-for-threads killers) + (sb-thread:terminate-thread thread) + (wait-for-threads (list thread)))) (sb-ext:gc :full t)) (format t "~&multi interrupt test done~%") @@ -242,15 +308,15 @@ (let ((c (make-thread (lambda () (loop (alloc-stuff)))))) ;; NB this only works on x86: other ports don't have a symbol for ;; pseudo-atomic atomicity - (format t "new thread ~A~%" c) (dotimes (i 100) (sleep (random 0.1d0)) (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)) + (terminate-thread c) + (wait-for-threads (list c))) (format t "~&interrupt test done~%") @@ -278,9 +344,9 @@ (dotimes (i 100) (sleep (random 0.1d0)) (interrupt-thread c func)) - (format t "~&waiting for interrupts to arrive~%") (loop until (= *interrupt-count* 100) do (sleep 0.1)) - (terminate-thread c))) + (terminate-thread c) + (wait-for-threads (list c)))) (format t "~&interrupt count test done~%") @@ -393,6 +459,29 @@ (loop while (thread-alive-p interruptor-thread))) (format t "~&session lock test done~%") + +(wait-for-threads + (loop for i below 2000 collect + (sb-thread:make-thread (lambda ())))) + +(format t "~&creation test done~%") + +;; watch out for *current-thread* being the parent thread after exit +(let* (sap + (thread (sb-thread:make-thread + (lambda () + (setq sap (thread-sap-for-id + (thread-os-thread *current-thread*))))))) + (wait-for-threads (list thread)) + (assert (null (symbol-value-in-thread 'sb-thread:*current-thread* + sap)))) + +;; 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* @@ -405,9 +494,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)