Use builtin SBCL thread API in test runner, or bordeaux-threads for #-sbcl

PiperOrigin-RevId: 710096890

Author: common-lisp-dev-copybara

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

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))

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))

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.")