master: Balance out threads.pure test times
snuglas via Sbcl-commits <[email protected]> Thu, 30 Apr 2026 22:44:07 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 84d5a7b46b4637ec27bd537a3125001d4e0bface (commit)
from 44c6928308e64daff70f67863c8d232e5e21bb85 (commit)
- Log -----------------------------------------------------------------
commit 84d5a7b46b4637ec27bd537a3125001d4e0bface
Author: Douglas Katzman <[email protected]>
Date: Thu Apr 30 18:34:46 2026 -0400
Balance out threads.pure test times
8 seconds in semaphore, 7 seconds in threads-slow, the rest can stay
---
tests/semaphore.pure.lisp | 134 ++++++++++++++++++++++++++++
tests/threads-slow.pure.lisp | 76 ++++++++++++++++
tests/threads.pure.lisp | 208 -------------------------------------------
3 files changed, 210 insertions(+), 208 deletions(-)
diff --git a/tests/semaphore.pure.lisp b/tests/semaphore.pure.lisp
new file mode 100644
index 000000000..f56da5e42
--- /dev/null
+++ b/tests/semaphore.pure.lisp
@@ -0,0 +1,134 @@
+ (use-package "SB-THREAD")
+
+(with-test (:name :semaphore-multiple-waiters :skipped-on (or (not :sb-thread) :gc-stress))
+ (let ((semaphore (make-semaphore :name "test sem")))
+ (labels ((make-readers (n i)
+ (values
+ (loop for r from 0 below n
+ collect
+ (make-thread
+ (lambda ()
+ (sb-ext:with-timeout 10
+ (let ((sem semaphore))
+ (dotimes (s i)
+ (wait-on-semaphore sem)))))
+ :name "reader"))
+ (* n i)))
+ (make-writers (n readers i)
+ (let ((j (* readers i)))
+ (multiple-value-bind (k rem) (truncate j n)
+ (values
+ (let ((writers
+ (loop for w from 0 below n
+ collect
+ (make-thread
+ (lambda ()
+ (sb-ext:with-timeout 10
+ (let ((sem semaphore))
+ (dotimes (s k)
+ (signal-semaphore sem)))))
+ :name "writer"))))
+ (assert (zerop rem))
+ writers)
+ (+ rem (* n k))))))
+ (test (r w n)
+ (multiple-value-bind (readers x) (make-readers r n)
+ (assert (= (length readers) r))
+ (multiple-value-bind (writers y) (make-writers w r n)
+ (assert (= (length writers) w))
+ (assert (= x y))
+ (mapc #'join-thread writers)
+ (mapc #'join-thread readers)
+ (assert (zerop (semaphore-count semaphore)))
+ (values)))))
+ (assert
+ (eq :ok
+ (sb-ext:with-timeout 20
+ (test 1 1 100)
+ (test 2 2 10000)
+ (test 4 2 10000)
+ (test 4 2 10000)
+ (test 10 10 10000)
+ (test 10 1 10000)
+ :ok))))))
+
+(with-test (:name (wait-on-semaphore :timeout :many-threads)
+ :skipped-on (not :sb-thread))
+ (let* ((count 10)
+ (semaphore (make-semaphore)))
+ ;; Add 10 tokens right away.
+ (signal-semaphore semaphore count)
+ ;; 100 threads try to decrement the semaphore by 1.
+ (let ((threads
+ (loop repeat 100
+ collect (make-thread
+ (lambda ()
+ (sleep (random 0.02))
+ (wait-on-semaphore semaphore :timeout 0.5))))))
+ ;; Add 10 more tokens while threads may already be waiting and
+ ;; decrementing.
+ (loop repeat (floor count 2) do (signal-semaphore semaphore 2))
+ ;; 20 threads should have been able to decrement the semaphore
+ ;; and obtain an updated count.
+ (let ((values (mapcar #'join-thread threads)))
+ ;; 20 threads should succeed waiting for the semaphore.
+ (assert (= (* 2 count) (count-if-not #'null values)))
+ ;; The updated semaphore count should be in [0,19] at all
+ ;; times.
+ (assert (every (lambda (value) (<= 0 value (1- (* 2 count))))
+ (remove nil values)))
+ ;; (At least) one thread should decrease the count to 0.
+ (assert (find 0 values))))))
+
+(with-test (:name (wait-on-semaphore semaphore-notification :lp-1038034)
+ :skipped-on (not :sb-thread))
+ ;; Test robustness of semaphore acquisition and notification with
+ ;; asynchronous thread termination... Which we know is currently
+ ;; fragile.
+ (dotimes (run 180)
+ (let ((sem (make-semaphore)))
+ ;; In CRITICAL, WAIT-ON-SEMAPHORE and SLEEP can be interrupted
+ ;; by TERMINATE-THREAD below. But the SIGNAL-SEMAPHORE cleanup
+ ;; cannot be interrupted.
+ (flet ((critical (sleep)
+ (let ((note (make-semaphore-notification)))
+ (sb-sys:without-interrupts
+ (unwind-protect
+ (sb-sys:with-local-interrupts
+ (wait-on-semaphore sem :notification note)
+ (sleep sleep))
+ ;; Re-increment on exit if we decremented it.
+ (when (semaphore-notification-status note)
+ (signal-semaphore sem)))))))
+ ;; Create /parallel/ threads trying to acquire and then signal
+ ;; the semaphore. Try to asynchronously abort T2 just as T1 is
+ ;; exiting.
+ (destructuring-bind (t1 t2 t3)
+ (loop for i from 1
+ for sleep in '(0.01 0.02 0.02)
+ collect (make-thread #'critical :arguments sleep
+ :name (format nil "T~A" i)))
+ (signal-semaphore sem)
+ (sleep 0.01)
+ (ignore-errors
+ (terminate-thread t2))
+ (flet ((safe-join-thread (thread &key timeout
+ abort)
+ (assert timeout)
+ (multiple-value-bind (value problem)
+ (join-thread thread
+ :timeout timeout
+ :default :timeout)
+ (unless (and abort
+ (eq problem :abort))
+ (when (eq value :timeout)
+ (assert (eq problem :timeout))
+ (error "Hang in (join-thread ~A) ?" thread))))))
+ (safe-join-thread t1 :timeout 60)
+ (safe-join-thread t2 :timeout 60 :abort t)
+ (safe-join-thread t3 :timeout 60)))))
+ (when (zerop (mod run 60))
+ (fresh-line)
+ (write-string "; "))
+ (write-char #\.)
+ (force-output)))
diff --git a/tests/threads-slow.pure.lisp b/tests/threads-slow.pure.lisp
new file mode 100644
index 000000000..96ed4b8ed
--- /dev/null
+++ b/tests/threads-slow.pure.lisp
@@ -0,0 +1,76 @@
+(use-package "SB-THREAD")
+
+;;; Terminating a thread that's waiting for the terminal.
+
+(with-test (:name (:terminate-thread :get-foreground)
+ :skipped-on (not :sb-thread))
+ (let ((thread (make-thread (lambda ()
+ (sb-thread:get-foreground)))))
+ (sleep 1)
+ (assert (thread-alive-p thread))
+ (terminate-thread thread)
+ (sleep 1)
+ (assert (not (thread-alive-p thread)))))
+
+;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
+;;; BUT: Such a claim is without much merit. Even if a wait is not "interrupted",
+;;; the very definition of spurious wakeup is that return from the wait happens
+;;; for ANY reason - users of condition variables must ALWAYS anticipate needing
+;;; to loop over a condition-wait.
+
+(with-test (:name :without-interrupts+condition-wait
+ :skipped-on (not :sb-thread))
+ (let* ((lock (make-mutex))
+ (queue (make-waitqueue))
+ (actually-wakeup nil)
+ (thread (make-thread (lambda ()
+ (sb-sys:without-interrupts
+ (with-mutex (lock)
+ (loop
+ (condition-wait queue lock)
+ (if actually-wakeup (return)))))))))
+ (sleep .25)
+ (assert (thread-alive-p thread))
+ ;; this is the supposed "interrupt that doesn't interrupt",
+ ;; but it _is_ permitted to wake the condition variable.
+ (terminate-thread thread)
+ (sleep .5)
+ (assert (thread-alive-p thread))
+ (setq actually-wakeup t)
+ (sb-thread:barrier (:write))
+ (condition-notify queue)
+ (sleep .25)
+ (assert (not (thread-alive-p thread)))))
+
+;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
+
+(with-test (:name :without-interrupts+grab-mutex
+ :skipped-on (not :sb-thread))
+ (let* ((lock (make-mutex))
+ (bar (progn (grab-mutex lock) nil))
+ (thread (make-thread (lambda ()
+ (sb-sys:without-interrupts
+ (with-mutex (lock)
+ (setf bar t)))))))
+ (sleep 1)
+ (assert (thread-alive-p thread))
+ (terminate-thread thread)
+ (sleep 1)
+ (assert (thread-alive-p thread))
+ (release-mutex lock)
+ (sleep 1)
+ (assert (not (thread-alive-p thread)))
+ (assert (eq :aborted (join-thread thread :default :aborted)))
+ (assert bar)))
+
+(with-test (:name (:wait-for :deadline))
+ (assert (eq :ok
+ (sb-sys:with-deadline (:seconds 10)
+ (assert (not (sb-ext:wait-for nil :timeout 0.1)))
+ :ok)))
+ (assert (eq :deadline
+ (handler-case
+ (sb-sys:with-deadline (:seconds 0.1)
+ (sb-ext:wait-for nil :timeout 10)
+ (error "oops"))
+ (sb-sys:deadline-timeout () :deadline)))))
diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index 71d6b04a1..d06aab37e 100644
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -39,69 +39,6 @@
(release-mutex mutex))
(assert (not (mutex-owner mutex)))))
-;;; Terminating a thread that's waiting for the terminal.
-
-(with-test (:name (:terminate-thread :get-foreground)
- :skipped-on (not :sb-thread))
- (let ((thread (make-thread (lambda ()
- (sb-thread:get-foreground)))))
- (sleep 1)
- (assert (thread-alive-p thread))
- (terminate-thread thread)
- (sleep 1)
- (assert (not (thread-alive-p thread)))))
-
-;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
-;;; BUT: Such a claim is without much merit. Even if a wait is not "interrupted",
-;;; the very definition of spurious wakeup is that return from the wait happens
-;;; for ANY reason - users of condition variables must ALWAYS anticipate needing
-;;; to loop over a condition-wait.
-
-(with-test (:name :without-interrupts+condition-wait
- :skipped-on (not :sb-thread))
- (let* ((lock (make-mutex))
- (queue (make-waitqueue))
- (actually-wakeup nil)
- (thread (make-thread (lambda ()
- (sb-sys:without-interrupts
- (with-mutex (lock)
- (loop
- (condition-wait queue lock)
- (if actually-wakeup (return)))))))))
- (sleep .25)
- (assert (thread-alive-p thread))
- ;; this is the supposed "interrupt that doesn't interrupt",
- ;; but it _is_ permitted to wake the condition variable.
- (terminate-thread thread)
- (sleep .5)
- (assert (thread-alive-p thread))
- (setq actually-wakeup t)
- (sb-thread:barrier (:write))
- (condition-notify queue)
- (sleep .25)
- (assert (not (thread-alive-p thread)))))
-
-;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
-
-(with-test (:name :without-interrupts+grab-mutex
- :skipped-on (not :sb-thread))
- (let* ((lock (make-mutex))
- (bar (progn (grab-mutex lock) nil))
- (thread (make-thread (lambda ()
- (sb-sys:without-interrupts
- (with-mutex (lock)
- (setf bar t)))))))
- (sleep 1)
- (assert (thread-alive-p thread))
- (terminate-thread thread)
- (sleep 1)
- (assert (thread-alive-p thread))
- (release-mutex lock)
- (sleep 1)
- (assert (not (thread-alive-p thread)))
- (assert (eq :aborted (join-thread thread :default :aborted)))
- (assert bar)))
-
(with-test (:name :parallel-find-class :skipped-on (not :sb-thread))
(let* ((oops nil)
(threads (loop repeat 10
@@ -114,58 +51,6 @@
(mapc #'join-thread threads)
(assert (not oops))))
-(with-test (:name :semaphore-multiple-waiters :skipped-on (or (not :sb-thread) :gc-stress))
- (let ((semaphore (make-semaphore :name "test sem")))
- (labels ((make-readers (n i)
- (values
- (loop for r from 0 below n
- collect
- (make-thread
- (lambda ()
- (sb-ext:with-timeout 10
- (let ((sem semaphore))
- (dotimes (s i)
- (wait-on-semaphore sem)))))
- :name "reader"))
- (* n i)))
- (make-writers (n readers i)
- (let ((j (* readers i)))
- (multiple-value-bind (k rem) (truncate j n)
- (values
- (let ((writers
- (loop for w from 0 below n
- collect
- (make-thread
- (lambda ()
- (sb-ext:with-timeout 10
- (let ((sem semaphore))
- (dotimes (s k)
- (signal-semaphore sem)))))
- :name "writer"))))
- (assert (zerop rem))
- writers)
- (+ rem (* n k))))))
- (test (r w n)
- (multiple-value-bind (readers x) (make-readers r n)
- (assert (= (length readers) r))
- (multiple-value-bind (writers y) (make-writers w r n)
- (assert (= (length writers) w))
- (assert (= x y))
- (mapc #'join-thread writers)
- (mapc #'join-thread readers)
- (assert (zerop (semaphore-count semaphore)))
- (values)))))
- (assert
- (eq :ok
- (sb-ext:with-timeout 20
- (test 1 1 100)
- (test 2 2 10000)
- (test 4 2 10000)
- (test 4 2 10000)
- (test 10 10 10000)
- (test 10 1 10000)
- :ok))))))
-
;;;; Printing waitqueues
(with-test (:name :waitqueue-circle-print :skipped-on (not :sb-thread))
@@ -325,18 +210,6 @@
(assert (and (null value)
error))))
-(with-test (:name (:wait-for :deadline))
- (assert (eq :ok
- (sb-sys:with-deadline (:seconds 10)
- (assert (not (sb-ext:wait-for nil :timeout 0.1)))
- :ok)))
- (assert (eq :deadline
- (handler-case
- (sb-sys:with-deadline (:seconds 0.1)
- (sb-ext:wait-for nil :timeout 10)
- (error "oops"))
- (sb-sys:deadline-timeout () :deadline)))))
-
(with-test (:name (:condition-wait :timeout :one-thread)
:skipped-on :gc-stress)
(let ((mutex (make-mutex))
@@ -380,87 +253,6 @@
(expected (loop for i from 9 downto 0 collect i)))
(assert (equal (remove nil values) expected)))))
-(with-test (:name (wait-on-semaphore :timeout :many-threads)
- :skipped-on (not :sb-thread))
- (let* ((count 10)
- (semaphore (make-semaphore)))
- ;; Add 10 tokens right away.
- (signal-semaphore semaphore count)
- ;; 100 threads try to decrement the semaphore by 1.
- (let ((threads
- (loop repeat 100
- collect (make-thread
- (lambda ()
- (sleep (random 0.02))
- (wait-on-semaphore semaphore :timeout 0.5))))))
- ;; Add 10 more tokens while threads may already be waiting and
- ;; decrementing.
- (loop repeat (floor count 2) do (signal-semaphore semaphore 2))
- ;; 20 threads should have been able to decrement the semaphore
- ;; and obtain an updated count.
- (let ((values (mapcar #'join-thread threads)))
- ;; 20 threads should succeed waiting for the semaphore.
- (assert (= (* 2 count) (count-if-not #'null values)))
- ;; The updated semaphore count should be in [0,19] at all
- ;; times.
- (assert (every (lambda (value) (<= 0 value (1- (* 2 count))))
- (remove nil values)))
- ;; (At least) one thread should decrease the count to 0.
- (assert (find 0 values))))))
-
-(with-test (:name (wait-on-semaphore semaphore-notification :lp-1038034)
- :skipped-on (not :sb-thread))
- ;; Test robustness of semaphore acquisition and notification with
- ;; asynchronous thread termination... Which we know is currently
- ;; fragile.
- (dotimes (run 180)
- (let ((sem (make-semaphore)))
- ;; In CRITICAL, WAIT-ON-SEMAPHORE and SLEEP can be interrupted
- ;; by TERMINATE-THREAD below. But the SIGNAL-SEMAPHORE cleanup
- ;; cannot be interrupted.
- (flet ((critical (sleep)
- (let ((note (make-semaphore-notification)))
- (sb-sys:without-interrupts
- (unwind-protect
- (sb-sys:with-local-interrupts
- (wait-on-semaphore sem :notification note)
- (sleep sleep))
- ;; Re-increment on exit if we decremented it.
- (when (semaphore-notification-status note)
- (signal-semaphore sem)))))))
- ;; Create /parallel/ threads trying to acquire and then signal
- ;; the semaphore. Try to asynchronously abort T2 just as T1 is
- ;; exiting.
- (destructuring-bind (t1 t2 t3)
- (loop for i from 1
- for sleep in '(0.01 0.02 0.02)
- collect (make-thread #'critical :arguments sleep
- :name (format nil "T~A" i)))
- (signal-semaphore sem)
- (sleep 0.01)
- (ignore-errors
- (terminate-thread t2))
- (flet ((safe-join-thread (thread &key timeout
- abort)
- (assert timeout)
- (multiple-value-bind (value problem)
- (join-thread thread
- :timeout timeout
- :default :timeout)
- (unless (and abort
- (eq problem :abort))
- (when (eq value :timeout)
- (assert (eq problem :timeout))
- (error "Hang in (join-thread ~A) ?" thread))))))
- (safe-join-thread t1 :timeout 60)
- (safe-join-thread t2 :timeout 60 :abort t)
- (safe-join-thread t3 :timeout 60)))))
- (when (zerop (mod run 60))
- (fresh-line)
- (write-string "; "))
- (write-char #\.)
- (force-output)))
-
(with-test (:name (wait-on-semaphore :n))
(let ((semaphore (make-semaphore :count 3)))
(assert (= 1 (wait-on-semaphore semaphore :n 2)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL