Permalink
Browse files

Kill leftover threads after each test

Otherwise, slightly broken tests manifest as hard failures in later
tests.

Thanks to Paul Khuong.
  • Loading branch information...
1 parent 5c6755e commit 69990bc42314706e9d646ddd8f6b911f46d0052c @pkhuong pkhuong committed with lichtblau Aug 17, 2012
View
@@ -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
View
@@ -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))))
View
@@ -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"))))
View
@@ -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):"))
View
@@ -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
Oops, something went wrong.

0 comments on commit 69990bc

Please sign in to comment.