mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
81 lines
4.8 KiB
Common Lisp
81 lines
4.8 KiB
Common Lisp
#-sb-thread (invoke-restart 'run-tests::skip-file)
|
|
(use-package "SB-THREAD")
|
|
|
|
;;; A few remarks about this:
|
|
;;; 1) this test is quite strange/bad because it relies on luck and timing.
|
|
;;; The linux FUTEX_WAIT manual entry says "wakes at most val of the waiters"
|
|
;;; meaning 'val' is an upper bound on the count of awakened threads.
|
|
;;; The kernel might decide to cap 'val' to the number of hardware threads,
|
|
;;; as more threads can't be scheduled concurrently.
|
|
;;; The lower bound on awakened threads is 1, without which there would literally
|
|
;;; be no reason to call FUTEX_WAKE. So why does this test expect that all threads
|
|
;;; are awakened? Because I think in practice the only cases the Linux kernel
|
|
;;; actually implements are 1 and all. I would guess that other OSes behave similarly.
|
|
;;; Absence of any criterion guarded by the mutex makes this usage of a condition
|
|
;;; var highly dubious in the first place, as normally any consumer of the event
|
|
;;; signaled would be allowed to consume more than one event. Hence the validity
|
|
;;; of waking fewer threads than 'val'.
|
|
;;;
|
|
;;; 2) win32 didn't always have #+sb-futex but now it does, so maybe this test should
|
|
;;; pass there. However I tried it once (and only once) and got
|
|
;;; "LEFTOVER-THREAD" from the test runner, which is a different problem.
|
|
;;; TERMINATE-THREAD is horrible. Some win32 contributor will have to fix this
|
|
;;; by making the test have a better termination criterion.
|
|
;;;
|
|
;;; When executed on macOS, each waiter tends to (or does) print its output message
|
|
;;; exactly once, but on Linux I've seen threads print more than once, which
|
|
;;; unquestionably indicates spurious wakeup.
|
|
(defparameter nthreads 10)
|
|
(with-test (:name (:condition-variable :notify-multiple))
|
|
(flet ((tester (name notify-fun)
|
|
(format t "~&Exercising ~A~%" name)
|
|
(let ((queue (make-waitqueue :name "queue"))
|
|
(lock (make-mutex :name "lock"))
|
|
(start-sem (make-semaphore))
|
|
(waiting (1- (ash 1 nthreads))))
|
|
(labels ((test (x &aux signaled-start-sem)
|
|
;; This is an extremely atypical (dare I say "bogus") use of cv-wait
|
|
;; in that there is no concrete test that it is waiting to satisfy.
|
|
;; So it can't distinguish spurious wakeup from being signaled
|
|
;; which sort of negates the very purpose of the test.
|
|
(loop
|
|
(let ((initial-waiting 0))
|
|
(with-mutex (lock)
|
|
(setq initial-waiting waiting)
|
|
;; (format t "condition-wait ~a~%" x) (force-output)
|
|
(unless signaled-start-sem
|
|
(signal-semaphore start-sem)
|
|
(setq signaled-start-sem t))
|
|
(condition-wait queue lock)
|
|
;; clear my bit. mutext is held, so this is safe
|
|
(setf waiting (logandc2 waiting (ash 1 x))))
|
|
;; for any given thread, say that its bit was cleared once only
|
|
;; (to try to see any problems)
|
|
;; This can be outside the lock, but try to issue a single write()
|
|
;; to avoid interleaved output.
|
|
(let ((str (format nil "worker ~a got cv notification (repeated=~D)~%" x
|
|
(not (logbitp x initial-waiting)))))
|
|
(sb-sys:with-pinned-objects (str)
|
|
(sb-unix:unix-write 2 str 0 (length str))))))))
|
|
(let ((threads (loop for x from 0 below (integer-length waiting)
|
|
collect (make-kill-thread
|
|
#'test :arguments (list x)
|
|
:name (format nil "worker~D" x)))))
|
|
(wait-on-semaphore start-sem :n nthreads)
|
|
(format t "~&All threads indicate ready~%")
|
|
(with-mutex (lock)
|
|
(funcall notify-fun queue))
|
|
;; give a few seconds for every thread to decide that it was woken,
|
|
;; and stop as soon as they all are
|
|
(loop repeat 30
|
|
do (when (zerop waiting) (return))
|
|
(sleep .1))
|
|
(mapcar #'terminate-thread threads)
|
|
;; Check that all threads woke up at least once
|
|
(assert (zerop waiting)))))))
|
|
;; the BROADCAST test is reasonable, the NOTIFY test is not.
|
|
(tester "condition-broadcast"
|
|
(lambda (queue) (condition-broadcast queue)))
|
|
(tester "condition-notify"
|
|
(lambda (queue) (condition-notify queue nthreads)))))
|