diff --git a/ace.test.asd b/ace.test.asd index 167d66d..6dfcbf2 100644 --- a/ace.test.asd +++ b/ace.test.asd @@ -21,7 +21,8 @@ :version "1.0" :author "Lisp Community" :license "MIT" - :depends-on (bordeaux-threads closer-mop trivial-garbage ace.core) + ;; FIXME: does it still need closer-mop? + :depends-on (#-sbcl bordeaux-threads closer-mop trivial-garbage ace.core) :in-order-to ((test-op (test-op :ace.test/tests))) :serial t :components diff --git a/main.lisp b/main.lisp index e62b47c..601b86b 100644 --- a/main.lisp +++ b/main.lisp @@ -17,15 +17,25 @@ (in-package :ace.test.main) +;;; Compatibility shims +#+sbcl +(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (import '(sb-thread:make-thread))) + (defun all-threads () (sb-thread:list-all-threads))) +#-sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (import '(bordeaux-threads:make-thread bordeaux-threads:all-threads))) + (defun start-timeout-watcher () "Runs a watcher for TIMEOUT minus 5 sec. and prints stack traces if not dead." - (let ((timeout (ace.test.runner:timeout))) + (let ((timeout (ace.test.runner:default-timeout))) (when (and timeout (> timeout 5)) (flet ((timeout-watcher () (sleep (- timeout 5)) (format *error-output* "INFO: The test is about to timeout.~%") (thread:print-backtraces))) - (thread:make-thread #'timeout-watcher :name "Timeout-Watcher"))))) + (make-thread #'timeout-watcher :name "Timeout-Watcher"))))) #+google3 (flag:define ace.test.runner::*parallel* t @@ -66,6 +76,5 @@ If ABORT is true, the process exits recklessly without cleaning up." (sb-thread:%dispose-thread-structs) ;; - thread structures (not threads) awaiting reuse in the recycle list (sb-alien:alien-funcall empty-thread-recyclebin)) - (format *error-output* "INFO: Exiting with ~D thread~:p remaining.~%" - (length (thread:all-threads))) + (format *error-output* "INFO: Exiting with ~D thread~:p remaining.~%" (length (all-threads))) (exit :timeout 10)) diff --git a/runner.lisp b/runner.lisp index a328a1e..386d74f 100644 --- a/runner.lisp +++ b/runner.lisp @@ -15,12 +15,6 @@ (defpackage #:ace.test.runner (:use #:common-lisp #:ace.core) - (:import-from #:ace.core.thread - #:join-thread - #:make-thread - #:with-timeout - #:make-mutex - #:with-mutex) (:import-from #:ace.core.tty #:ttyp #:*print-ansi*) @@ -35,6 +29,7 @@ #:missed #:*on-missed-expectation* #:alternate-truth-form) + (:import-from #+sbcl #:sb-ext #-sbcl #:bordeaux-threads #:timeout) (:export ;; Execution of tests. #:*checks-count* @@ -47,11 +42,28 @@ #:run-and-report-tests #:deregister-tests #:*debug-unit-tests* - #:timeout + ;; TIMEOUT is a symbol naming a condition, and it was confusing to also have it name a function, + ;; so the function is now named DEFAULT-TIMEOUT + #:default-timeout #:order)) (in-package #:ace.test.runner) +;;; Compatibility shims +#+sbcl +(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (import '(sb-thread:make-thread sb-thread:join-thread sb-thread:with-mutex))) + (defmacro with-timeout ((time) &body body) `(sb-ext:with-timeout ,time ,@body)) + (defun make-mutex (name) (sb-thread:make-mutex :name name))) +#-sbcl +(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (import '(bordeaux-threads:make-thread bordeaux-threads:join-thread))) + (defun make-mutex (name) (bordeaux-threads:make-lock name)) + (defmacro with-mutex ((lock) &body body) `(bordeaux-threads:with-lock-held (,lock) ,@body)) + (defmacro with-timeout (&whole form) `(bordeaux-threads:with-timeout ,@(cdr form)))) + ;;; Test execution. (declaim (list *unit-tests*)) @@ -326,7 +338,7 @@ Returns true if there was no error." (test-run-start-time run) (handler-bind ((missed #'on-warning) (error #'on-error) - (bordeaux-threads:timeout #'on-error)) + (timeout #'on-error)) (loop do (with-simple-restart (retry "Retry ~S" test) (return @@ -336,7 +348,7 @@ Returns true if there was no error." (funcall (symbol-function test))))))) (update-test-run run))))) -(defun timeout () +(defun default-timeout () "Return a value for the default test timeout in seconds." ;; The test timeout is provided by blaze test in the TEST_TIMEOUT variable. ;; See: http://bazel.build/docs/test-encyclopedia.html @@ -450,7 +462,7 @@ If PARALLEL is NIL, the PARALLEL tests will be empty.")) (let* ((run (make-test-run :test test :parallel (and parallel (not (get test 'order))) - :timeout (get test 'timeout (timeout)) + :timeout (get test 'timeout (default-timeout)) :output-stream (make-string-output-stream))) (package (symbol-package test)) (name (format nil "~@[~A::~]~A" @@ -563,6 +575,9 @@ If PARALLEL is NIL, the PARALLEL tests will be empty.")) (prog1 (report-tests (%run-tests :debug nil :verbose verbose :out out) :out out) ;; Cleanup Lisp-gc managed c-objects so asan doesn't complain + ;; This GC call assumes that cleanups are synchronous with completion of GC, + ;; but we've seen ASAN complains anyway as it requires lots of other help. + ;; So probably just remove this after further testing. (trivial-garbage:gc :full t))) (defun deregister-tests (&optional (select :all)) diff --git a/test.lisp b/test.lisp index 10cff54..00a8f17 100644 --- a/test.lisp +++ b/test.lisp @@ -20,11 +20,6 @@ #:run-tests #:order #:timeout) - ;; Use bordeaux-threads to minimize dependencies - ;; TODO(czak): Move to mocks.lisp. - (:import-from #:bordeaux-threads - #:make-recursive-lock - #:with-recursive-lock-held) (:export ;; Testing utilities. #:signals @@ -162,6 +157,13 @@ Example: ;;; ;;; Convenience for testing bad/unsafe legacy code that depends on global state. +(defun make-recursive-lock (name) + #+sbcl (sb-thread:make-mutex :name name) + #-sbcl (bordeaux-threads:make-recursive-lock name)) +(defmacro with-recursive-lock-held ((lock) &body body) + #+sbcl `(sb-thread:with-recursive-lock (,lock) ,@body) + #-sbcl `(bordeaux-threads:with-recursive-lock-held (,lock) ,@body)) + (defvar *unsafe-code-test-mutex* (make-recursive-lock "UNSAFE-CODE-TEST-MUTEX") "Used to serialize tests that mutate global space.")