X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=b4e5bba343a93bb373a1b41192ed8a2c7414fe4d;hb=64d420902d31cb87ea752f09b314e4767816a9c9;hp=03465c41dbd563e6a25d8de49df0dac26056b972;hpb=ad3beba970fab6e451a461c9f9b14faf4ef17718;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 03465c4..b4e5bba 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -6,13 +6,18 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;; +;;; ;;;; This software is in the public domain and is provided with ;;;; absoluely no warranty. See the COPYING and CREDITS files for ;;;; more information. (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,18 +59,19 @@ ;; Start NTHREADS idle threads. (dotimes (i nthreads) (sb-thread:make-thread (lambda () - (sb-thread:condition-wait queue mutex) - (sb-ext:quit)))) + (with-mutex (mutex) + (sb-thread:condition-wait queue mutex)) + (sb-ext:quit)))) (let ((start-time (get-internal-run-time))) (funcall function) (prog1 (- (get-internal-run-time) start-time) - (sb-thread:condition-broadcast queue))))) + (sb-thread:condition-broadcast queue))))) (defun fact (n) "A function that does work with the CPU." (if (zerop n) 1 (* n (fact (1- n))))) (let ((work (lambda () (fact 15000)))) (let ((zero (scaling-test work 0)) - (four (scaling-test work 4))) + (four (scaling-test work 4))) ;; a slightly weak assertion, but good enough for starters. (assert (< four (* 1.5 zero))))) @@ -74,7 +80,7 @@ (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede) (format o "void loop_forever() { while(1) ; }~%")) -(sb-ext:run-program +(sb-ext:run-program "cc" (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c") (error "Missing shared library compilation options for this platform")) @@ -123,20 +129,20 @@ (lock (make-mutex :name "lock")) (n 0)) (labels ((in-new-thread () - (with-mutex (lock) - (assert (eql (mutex-value lock) *current-thread*)) - (format t "~A got mutex~%" *current-thread*) - ;; now drop it and sleep - (condition-wait queue lock) - ;; after waking we should have the lock again - (assert (eql (mutex-value lock) *current-thread*)) + (with-mutex (lock) + (assert (eql (mutex-value lock) *current-thread*)) + (format t "~A got mutex~%" *current-thread*) + ;; now drop it and sleep + (condition-wait queue lock) + ;; after waking we should have the lock again + (assert (eql (mutex-value lock) *current-thread*)) (assert (eql n 1)) (decf n)))) (make-thread #'in-new-thread) - (sleep 2) ; give it a chance to start + (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) - (assert (eql (mutex-value lock) nil)) + (assert (eql (mutex-value lock) nil)) (with-mutex (lock) (incf n) (condition-notify queue)) @@ -145,38 +151,97 @@ (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)))) - (in-new-thread () - (with-recursive-lock (lock) - (assert (ours-p (mutex-value lock))) - (format t "~A got mutex~%" (mutex-value lock)) - ;; now drop it and sleep - (condition-wait queue lock) - ;; after waking we should have the lock again - (format t "woken, ~A got mutex~%" (mutex-value lock)) - (assert (ours-p (mutex-value lock)))))) + (sb-vm:control-stack-pointer-valid-p + (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))) + (in-new-thread () + (with-recursive-lock (lock) + (assert (ours-p (mutex-value lock))) + (format t "~A got mutex~%" (mutex-value lock)) + ;; now drop it and sleep + (condition-wait queue lock) + ;; after waking we should have the lock again + (format t "woken, ~A got mutex~%" (mutex-value lock)) + (assert (ours-p (mutex-value lock)))))) (make-thread #'in-new-thread) - (sleep 2) ; give it a chance to start + (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) - (assert (eql (mutex-value lock) nil)) + (assert (eql (mutex-value lock) nil)) (with-recursive-lock (lock) (condition-notify queue)) (sleep 1))) (let ((mutex (make-mutex :name "contended"))) (labels ((run () - (let ((me *current-thread*)) - (dotimes (i 100) - (with-mutex (mutex) - (sleep .1) - (assert (eql (mutex-value mutex) me))) - (assert (not (eql (mutex-value mutex) me)))) - (format t "done ~A~%" *current-thread*)))) + (let ((me *current-thread*)) + (dotimes (i 100) + (with-mutex (mutex) + (sleep .1) + (assert (eql (mutex-value mutex) me))) + (assert (not (eql (mutex-value mutex) me)))) + (format t "done ~A~%" *current-thread*)))) (let ((kid1 (make-thread #'run)) - (kid2 (make-thread #'run))) - (format t "contention ~A ~A~%" kid1 kid2)))) + (kid2 (make-thread #'run))) + (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))) @@ -184,9 +249,9 @@ (sleep 2) (format t "interrupting child ~A~%" child) (interrupt-thread child - (lambda () - (format t "child pid ~A~%" *current-thread*) - (when quit-p (sb-ext:quit)))) + (lambda () + (format t "child pid ~A~%" *current-thread*) + (when quit-p (sb-ext:quit)))) (sleep 1) child)) @@ -199,22 +264,24 @@ (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) (with-mutex (lock) (setf child (test-interrupt - (lambda () - (with-mutex (lock) - (assert (eql (mutex-value lock) *current-thread*))) - (assert (not (eql (mutex-value lock) *current-thread*))) - (sleep 10)))) + (lambda () + (with-mutex (lock) + (assert (eql (mutex-value lock) *current-thread*))) + (assert (not (eql (mutex-value lock) *current-thread*))) + (sleep 10)))) ;;hold onto lock for long enough that child can't get it immediately (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~%") @@ -227,14 +294,13 @@ (sb-thread:make-thread (lambda () (loop repeat 25 do - (sleep (random 2d0)) + (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 1d0)) + (sleep (random 0.1d0)) (interrupt-thread c - (lambda () - (princ ".") (force-output) - (assert (eq (thread-state *current-thread*) :running)) - (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*))))) - (terminate-thread c)) + (lambda () + (princ ".") (force-output) + (assert (thread-alive-p *current-thread*)) + (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*))))) + (terminate-thread c) + (wait-for-threads (list c))) (format t "~&interrupt test done~%") @@ -276,24 +342,24 @@ (sb-impl::atomic-incf/symbol *interrupt-count*)))) (setq *interrupt-count* 0) (dotimes (i 100) - (sleep (random 1d0)) + (sleep (random 0.1d0)) (interrupt-thread c func)) - (sleep 1) - (assert (= 100 *interrupt-count*)) - (terminate-thread c))) + (loop until (= *interrupt-count* 100) do (sleep 0.1)) + (terminate-thread c) + (wait-for-threads (list c)))) (format t "~&interrupt count test done~%") (let (a-done b-done) (make-thread (lambda () - (dotimes (i 100) - (sb-ext:gc) (princ "\\") (force-output)) - (setf a-done t))) + (dotimes (i 100) + (sb-ext:gc) (princ "\\") (force-output)) + (setf a-done t))) (make-thread (lambda () - (dotimes (i 25) - (sb-ext:gc :full t) - (princ "/") (force-output)) - (setf b-done t))) + (dotimes (i 25) + (sb-ext:gc :full t) + (princ "/") (force-output)) + (setf b-done t))) (loop (when (and a-done b-done) (return)) (sleep 1))) @@ -339,7 +405,7 @@ (loop do (funcall fn) (let ((errno (sb-unix::get-errno))) - (sleep (random 1.0)) + (sleep (random 0.1d0)) (unless (eql errno reference-errno) (format t "Got errno: ~A (~A) instead of ~A~%" errno @@ -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)