;;;; 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*
;; 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)))))
(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"))
(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)
(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")
(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))
(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))))))
+ (eq *current-thread* 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 .03)
+ (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)))
(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))
(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~%")
(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~%")
(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~%")
(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)))
(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
(loop while (thread-alive-p interruptor-thread)))
(format t "~&session lock test done~%")
+
+(loop repeat 20 do
+ (wait-for-threads
+ (loop for i below 100 collect
+ (sb-thread:make-thread (lambda ())))))
+
+(format t "~&creation test done~%")
+
+;; 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*
| (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)
projects / sbcl.git / blobdiff