From 69990bc42314706e9d646ddd8f6b911f46d0052c Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Fri, 17 Aug 2012 18:17:03 -0400 Subject: [PATCH] Kill leftover threads after each test Otherwise, slightly broken tests manifest as hard failures in later tests. Thanks to Paul Khuong. --- tests/deadline.impure.lisp | 20 ++++---- tests/hash.impure.lisp | 8 +-- tests/packages.impure.lisp | 12 ++--- tests/run-tests.lisp | 1 + tests/test-util.lisp | 71 ++++++++++++++++++++------ tests/threads.impure.lisp | 121 ++++++++++++++++++++++---------------------- tests/threads.pure.lisp | 6 +-- tests/timer.impure.lisp | 4 +- 8 files changed, 143 insertions(+), 100 deletions(-) diff --git a/tests/deadline.impure.lisp b/tests/deadline.impure.lisp index 22d9ed0..44990e8 100644 --- a/tests/deadline.impure.lisp +++ b/tests/deadline.impure.lisp @@ -69,10 +69,10 @@ (assert-timeout (let ((lock (sb-thread:make-mutex)) (waitp t)) - (sb-thread:make-thread (lambda () - (sb-thread:grab-mutex lock) - (setf waitp nil) - (sleep 5))) + (make-join-thread (lambda () + (sb-thread:grab-mutex lock) + (setf waitp nil) + (sleep 5))) (loop while waitp do (sleep 0.01)) (sb-sys:with-deadline (:seconds 1) (sb-thread:grab-mutex lock))))) @@ -87,17 +87,17 @@ (assert-timeout (sb-sys:with-deadline (:seconds 1) (sb-thread:join-thread - (sb-thread:make-thread (lambda () (loop (sleep 1)))))))) + (make-kill-thread (lambda () (loop (sleep 1)))))))) (with-test (:name (:deadline :futex-wait-eintr) :skipped-on '(not :sb-thread)) (let ((lock (sb-thread:make-mutex)) (waitp t)) - (sb-thread:make-thread (lambda () - (sb-thread:grab-mutex lock) - (setf waitp nil) - (sleep 5))) + (make-join-thread (lambda () + (sb-thread:grab-mutex lock) + (setf waitp nil) + (sleep 5))) (loop while waitp do (sleep 0.01)) - (let ((thread (sb-thread:make-thread + (let ((thread (make-join-thread (lambda () (let ((start (get-internal-real-time))) (handler-case diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp index 6f35e19..db4c5fd 100644 --- a/tests/hash.impure.lisp +++ b/tests/hash.impure.lisp @@ -284,10 +284,10 @@ (sem (gensym))) `(let ((,sem (sb-thread::make-semaphore)) ,values) - (sb-thread:make-thread (lambda () - (setq ,values - (multiple-value-list (progn ,@body))) - (sb-thread::signal-semaphore ,sem))) + (make-join-thread (lambda () + (setq ,values + (multiple-value-list (progn ,@body))) + (sb-thread::signal-semaphore ,sem))) (sb-thread::wait-on-semaphore ,sem) (values-list ,values)))) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index 82ef917..0e78218 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -294,12 +294,12 @@ if a restart was invoked." (let* ((p (make-package :bug-511072)) (sem1 (sb-thread:make-semaphore)) (sem2 (sb-thread:make-semaphore)) - (t2 (sb-thread:make-thread (lambda () - (handler-bind ((error (lambda (c) - (sb-thread:signal-semaphore sem1) - (sb-thread:wait-on-semaphore sem2) - (abort c)))) - (make-package :bug-511072)))))) + (t2 (make-join-thread (lambda () + (handler-bind ((error (lambda (c) + (sb-thread:signal-semaphore sem1) + (sb-thread:wait-on-semaphore sem2) + (abort c)))) + (make-package :bug-511072)))))) (sb-thread:wait-on-semaphore sem1) (with-timeout 10 (assert (eq 'cons (read-from-string "CL:CONS")))) diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index dcf2f2c..2cdd163 100644 --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -69,6 +69,7 @@ (ecase (first fail) (:expected-failure "Expected failure:") (:unexpected-failure "Failure:") + (:leftover-thread "Leftover thread (broken):") (:unexpected-success "Unexpected success:") (:skipped-broken "Skipped (broken):") (:skipped-disabled "Skipped (irrelevant):")) diff --git a/tests/test-util.lisp b/tests/test-util.lisp index 8381019..43bafa0 100644 --- a/tests/test-util.lisp +++ b/tests/test-util.lisp @@ -2,7 +2,8 @@ (:use :cl :sb-ext) (:export #:with-test #:report-test-status #:*failures* #:really-invoke-debugger - #:*break-on-failure* #:*break-on-expected-failure*)) + #:*break-on-failure* #:*break-on-expected-failure* + #:make-kill-thread #:make-join-thread)) (in-package :test-util) @@ -12,14 +13,33 @@ (defvar *break-on-failure* nil) (defvar *break-on-expected-failure* nil) +(defvar *threads-to-kill*) +(defvar *threads-to-join*) + +#+sb-thread +(defun make-kill-thread (&rest args) + (let ((thread (apply #'sb-thread:make-thread args))) + (when (boundp '*threads-to-kill*) + (push thread *threads-to-kill*)) + thread)) + +#+sb-thread +(defun make-join-thread (&rest args) + (let ((thread (apply #'sb-thread:make-thread args))) + (when (boundp '*threads-to-join*) + (push thread *threads-to-join*)) + thread)) + (defun log-msg (&rest args) (format *trace-output* "~&::: ") (apply #'format *trace-output* args) (terpri *trace-output*) (force-output *trace-output*)) -(defmacro with-test ((&key fails-on broken-on skipped-on name) &body body) - (let ((block-name (gensym))) +(defmacro with-test ((&key fails-on broken-on skipped-on name) + &body body) + (let ((block-name (gensym)) + (threads (gensym "THREADS"))) `(progn (start-test) (cond @@ -28,18 +48,39 @@ ((skipped-p ,skipped-on) (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features")) (t - (block ,block-name - (handler-bind ((error (lambda (error) - (if (expected-failure-p ,fails-on) - (fail-test :expected-failure ',name error) - (fail-test :unexpected-failure ',name error)) - (return-from ,block-name)))) - (progn - (log-msg "Running ~S" ',name) - ,@body - (if (expected-failure-p ,fails-on) - (fail-test :unexpected-success ',name nil) - (log-msg "Success ~S" ',name)))))))))) + (let (#+sb-thread (,threads (sb-thread:list-all-threads)) + (*threads-to-join* nil) + (*threads-to-kill* nil)) + (block ,block-name + (handler-bind ((error (lambda (error) + (if (expected-failure-p ,fails-on) + (fail-test :expected-failure ',name error) + (fail-test :unexpected-failure ',name error)) + (return-from ,block-name)))) + (progn + (log-msg "Running ~S" ',name) + ,@body + #+sb-thread + (let ((any-leftover nil)) + (dolist (thread *threads-to-join*) + (ignore-errors (sb-thread:join-thread thread))) + (dolist (thread *threads-to-kill*) + (ignore-errors (sb-thread:terminate-thread thread))) + (setf ,threads (union (union *threads-to-kill* + *threads-to-join*) + ,threads)) + (dolist (thread (sb-thread:list-all-threads)) + (unless (or (not (sb-thread:thread-alive-p thread)) + (eql thread sb-thread:*current-thread*) + (member thread ,threads)) + (setf any-leftover thread) + (ignore-errors (sb-thread:terminate-thread thread)))) + (when any-leftover + (fail-test :leftover-thread ',name any-leftover) + (return-from ,block-name))) + (if (expected-failure-p ,fails-on) + (fail-test :unexpected-success ',name nil) + (log-msg "Success ~S" ',name))))))))))) (defun report-test-status () (with-standard-io-syntax diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 2354bac..196261d 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -86,8 +86,8 @@ (with-test (:name (:interrupt-thread :deferrables-unblocked-by-lock)) (let ((lock (sb-thread::make-mutex)) - (thread (sb-thread:make-thread (lambda () - (loop (sleep 1)))))) + (thread (make-kill-thread (lambda () + (loop (sleep 1)))))) (sb-thread::grab-mutex lock) (sb-thread:interrupt-thread thread (lambda () @@ -184,10 +184,10 @@ (mutex (sb-thread:make-mutex))) ;; Start NTHREADS idle threads. (dotimes (i nthreads) - (sb-thread:make-thread (lambda () - (with-mutex (mutex) - (sb-thread:condition-wait queue mutex)) - (sb-thread:abort-thread)))) + (make-join-thread (lambda () + (with-mutex (mutex) + (sb-thread:condition-wait queue mutex)) + (sb-thread:abort-thread)))) (let ((start-time (get-internal-run-time))) (funcall function) (prog1 (- (get-internal-run-time) start-time) @@ -286,7 +286,7 @@ ;; if interrupted by another thread exiting/a gc/anything (with-test (:name (:sleep :continue-sleeping-after-interrupt)) (let ((start-time (get-universal-time))) - (make-thread (lambda () (sleep 1) (sb-ext:gc :full t))) + (make-join-thread (lambda () (sleep 1) (sb-ext:gc :full t))) (sleep 5) (assert (>= (get-universal-time) (+ 5 start-time))))) @@ -305,7 +305,7 @@ (assert (eql (mutex-value lock) *current-thread*)) (assert (eql n 1)) (decf n)))) - (make-thread #'in-new-thread) + (make-join-thread #'in-new-thread) (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) @@ -329,7 +329,7 @@ ;; 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) + (make-join-thread #'in-new-thread) (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) @@ -430,19 +430,19 @@ (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))) + (make-join-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))) + (make-join-thread (lambda () + (signal-semaphore sem) + (setq signalled-p t))) (loop until signalled-p) (wait-on-semaphore sem) (assert signalled-p))) @@ -450,8 +450,8 @@ (defun test-semaphore-multiple-signals (wait-on-semaphore) (let* ((sem (make-semaphore :count 5)) (threads (loop repeat 20 collecting - (make-thread (lambda () - (funcall wait-on-semaphore sem)))))) + (make-join-thread (lambda () + (funcall wait-on-semaphore sem)))))) (flet ((count-live-threads () (count-if #'thread-alive-p threads))) (sleep 0.5) @@ -532,7 +532,7 @@ (format t "~&semaphore tests done~%") (defun test-interrupt (function-to-interrupt &optional quit-p) - (let ((child (make-thread function-to-interrupt))) + (let ((child (make-kill-thread function-to-interrupt))) ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child) (sleep 2) (format t "interrupting child ~A~%" child) @@ -581,7 +581,7 @@ (defun alloc-stuff () (copy-list '(1 2 3 4 5))) (with-test (:name (:interrupt-thread :interrupt-consing-child)) - (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff)))))) + (let ((thread (make-thread (lambda () (loop (alloc-stuff)))))) (let ((killers (loop repeat 4 collect (sb-thread:make-thread @@ -688,15 +688,15 @@ (with-test (:name (:two-threads-running-gc)) (let (a-done b-done) - (make-thread (lambda () - (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))) + (make-join-thread (lambda () + (dotimes (i 100) + (sb-ext:gc) (princ "\\") (force-output)) + (setf a-done t))) + (make-join-thread (lambda () + (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)))) @@ -710,7 +710,7 @@ (loop for i below 100 do (princ "!") (force-output) - (sb-thread:make-thread + (make-join-thread #'(lambda () (waste))) (waste) @@ -723,7 +723,7 @@ (loop for i below 100 do (princ "!") (force-output) - (sb-thread:make-thread + (make-join-thread #'(lambda () (let ((*aaa* (waste))) (waste)))) @@ -735,10 +735,10 @@ ;; this used to deadlock on session-lock (with-test (:name (:no-session-deadlock)) - (sb-thread:make-thread (lambda () (sb-ext:gc)))) + (make-join-thread (lambda () (sb-ext:gc)))) (defun exercise-syscall (fn reference-errno) - (sb-thread:make-thread + (make-kill-thread (lambda () (loop do (funcall fn) @@ -769,7 +769,7 @@ (exercise-syscall (lambda () (open "no-such-file" :if-does-not-exist nil)) open-errno) - (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1))))))) + (make-join-thread (lambda () (loop (sb-ext:gc) (sleep 1))))))) (sleep 10) (princ "terminating threads") (dolist (thread threads) @@ -779,7 +779,7 @@ (with-test (:name :all-threads-have-abort-restart) (loop repeat 100 do - (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1))))) + (let ((thread (make-kill-thread (lambda () (sleep 0.1))))) (sb-thread:interrupt-thread thread (lambda () @@ -810,7 +810,7 @@ ;; expose thread creation races by exiting quickly (with-test (:name (:no-thread-creation-race :light)) - (sb-thread:make-thread (lambda ()))) + (make-join-thread (lambda ()))) (with-test (:name (:no-thread-creation-race :heavy)) (loop repeat 20 do @@ -823,7 +823,7 @@ ;; interrupt handlers are per-thread with pthreads, make sure the ;; handler installed in one thread is global (with-test (:name (:global-interrupt-handler)) - (sb-thread:make-thread + (make-join-thread (lambda () (sb-ext:run-program "sleep" '("1") :search t :wait nil)))) @@ -876,11 +876,11 @@ (let (threads) (unwind-protect (progn - (push (sb-thread:make-thread #'exercise-binding) threads) - (push (sb-thread:make-thread (lambda () - (loop - (sleep 0.1) - (send-gc)))) + (push (make-kill-thread #'exercise-binding) threads) + (push (make-kill-thread (lambda () + (loop + (sleep 0.1) + (send-gc)))) threads) (sleep 4)) (mapc #'sb-thread:terminate-thread threads)))) @@ -909,7 +909,7 @@ ;; expect this to corrupt the image. (let* ((hash (make-hash-table)) (*errors* nil) - (threads (list (sb-thread:make-thread + (threads (list (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) @@ -917,7 +917,7 @@ ;;(princ "1") (force-output) (setf (gethash (random 100) hash) 'h))))) :name "writer") - (sb-thread:make-thread + (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) @@ -925,7 +925,7 @@ ;;(princ "2") (force-output) (remhash (random 100) hash))))) :name "reader") - (sb-thread:make-thread + (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) @@ -942,7 +942,7 @@ (with-test (:name (:synchronized-hash-table)) (let* ((hash (make-hash-table :synchronized t)) (*errors* nil) - (threads (list (sb-thread:make-thread + (threads (list (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) @@ -950,7 +950,7 @@ ;;(princ "1") (force-output) (setf (gethash (random 100) hash) 'h))))) :name "writer") - (sb-thread:make-thread + (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) @@ -958,7 +958,7 @@ ;;(princ "2") (force-output) (remhash (random 100) hash))))) :name "reader") - (sb-thread:make-thread + (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) @@ -978,28 +978,28 @@ (*errors* nil)) (loop repeat 50 do (setf (gethash (random 100) hash) 'xxx)) - (let ((threads (list (sb-thread:make-thread + (let ((threads (list (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) (loop until (eq t (gethash (random 100) hash)))))) :name "reader 1") - (sb-thread:make-thread + (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) (loop until (eq t (gethash (random 100) hash)))))) :name "reader 2") - (sb-thread:make-thread + (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) (loop until (eq t (gethash (random 100) hash)))))) :name "reader 3") - (sb-thread:make-thread + (make-kill-thread (lambda () (catch 'done (handler-bind ((serious-condition 'oops)) @@ -1017,7 +1017,7 @@ (with-test (:name (:hash-table-single-accessor-parallel-gc)) (let ((hash (make-hash-table)) (*errors* nil)) - (let ((threads (list (sb-thread:make-thread + (let ((threads (list (make-kill-thread (lambda () (handler-bind ((serious-condition 'oops)) (loop @@ -1026,7 +1026,7 @@ (remhash n hash) (setf (gethash n hash) 'h)))))) :name "accessor") - (sb-thread:make-thread + (make-kill-thread (lambda () (handler-bind ((serious-condition 'oops)) (loop @@ -1070,8 +1070,8 @@ (let ((threads (loop for x from 1 to 10 collect (let ((x x)) - (sb-thread:make-thread (lambda () - (test x))))))) + (make-kill-thread (lambda () + (test x))))))) (sleep 5) (with-mutex (lock) (funcall notify-fun queue)) @@ -1259,11 +1259,11 @@ (force-output)) (handler-case (if (oddp i) - (sb-thread:make-thread + (make-join-thread (lambda () (sleep (random 0.001))) :name (format nil "SLEEP-~D" i)) - (sb-thread:make-thread + (make-join-thread (lambda () ;; KLUDGE: what we are doing here is explicit, ;; but the same can happen because of a regular @@ -1351,8 +1351,9 @@ (force-output)) (with-test (:name (:hash-cache :subtypep)) - (dotimes (i 10) - (sb-thread:make-thread #'subtypep-hash-cache-test))) + (mapc #'join-thread + (loop repeat 10 + collect (sb-thread:make-thread #'subtypep-hash-cache-test)))) (format t "hash-cache tests done~%") ;;;; BLACK BOX TESTS diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index 2db34c2..d4a5192 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -495,12 +495,12 @@ :skipped-on '(not :sb-thread)) (assert (eq :error (handler-case - (join-thread (make-thread (lambda () (sleep 10))) :timeout 0.01) + (join-thread (make-join-thread (lambda () (sleep 10))) :timeout 0.01) (join-thread-error () :error)))) (let ((cookie (cons t t))) (assert (eq cookie - (join-thread (make-thread (lambda () (sleep 10))) + (join-thread (make-join-thread (lambda () (sleep 10))) :timeout 0.01 :default cookie))))) @@ -526,7 +526,7 @@ #+sb-thread (sb-thread::block-deferrable-signals)))))) (let* ((threads (loop for i from 1 upto 100 - collect (make-thread #'critical :name (format nil "T~A" i)))) + collect (make-join-thread #'critical :name (format nil "T~A" i)))) (safe nil) (unsafe nil) (interruptor (make-thread (lambda () diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp index e4bd2d5..19bc334 100644 --- a/tests/timer.impure.lisp +++ b/tests/timer.impure.lisp @@ -114,7 +114,7 @@ (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) (with-test (:name (:timer :other-thread) :skipped-on '(not :sb-thread)) - (let* ((thread (sb-thread:make-thread (lambda () (sleep 2)))) + (let* ((thread (make-kill-thread (lambda () (sleep 2)))) (timer (make-timer (lambda () (assert (eq thread sb-thread:*current-thread*))) :thread thread))) @@ -214,7 +214,7 @@ (assert ok)))) (with-test (:name (:with-timeout :dead-thread) :skipped-on '(not :sb-thread)) - (sb-thread:make-thread + (make-join-thread (lambda () (let ((timer (make-timer (lambda ())))) (schedule-timer timer 3) -- 1.7.10.4