mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
374 lines
14 KiB
Common Lisp
374 lines
14 KiB
Common Lisp
;;;; miscellaneous tests of thread stuff
|
||
|
||
;;;; This software is part of the SBCL system. See the README file for
|
||
;;;; more information.
|
||
;;;;
|
||
;;;; While most of SBCL is derived from the CMU CL system, the test
|
||
;;;; files (like this one) were written from scratch after the fork
|
||
;;;; from CMU CL.
|
||
;;;
|
||
;;;; This software is in the public domain and is provided with
|
||
;;;; absoluely no warranty. See the COPYING and CREDITS files for
|
||
;;;; more information.
|
||
|
||
|
||
;;;; STRUCTURAL TESTS
|
||
|
||
(shadowing-import 'assertoid:assert-error)
|
||
(use-package "SB-THREAD")
|
||
(use-package "SB-SYS")
|
||
|
||
(setf sb-unix::*on-dangerous-wait* :error)
|
||
|
||
(with-test (:name (:threads :trivia))
|
||
(assert (eq *current-thread*
|
||
(find (thread-name *current-thread*) (list-all-threads)
|
||
:key #'thread-name :test #'equal)))
|
||
|
||
(assert (thread-alive-p *current-thread*)))
|
||
|
||
(with-test (:name (with-mutex :basics))
|
||
(let ((mutex (make-mutex)))
|
||
(with-mutex (mutex)
|
||
mutex)))
|
||
|
||
(sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
|
||
void
|
||
(where sb-alien:unsigned-long))
|
||
(sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
|
||
void
|
||
(where sb-alien:unsigned-long))
|
||
|
||
(with-test (:name (interrupt-thread :basics :no-unwinding))
|
||
(let ((a 0))
|
||
(interrupt-thread *current-thread* (lambda () (setq a 1)))
|
||
(process-all-interrupts)
|
||
(assert (eql a 1))))
|
||
|
||
(with-test (:name (interrupt-thread :deferrables-blocked))
|
||
(interrupt-thread *current-thread*
|
||
(lambda ()
|
||
;; Make sure sb-ext:gc doesn't leave the
|
||
;; deferrables unblocked
|
||
(sb-ext:gc)
|
||
(check-deferrables-blocked-or-lose 0)))
|
||
(process-all-interrupts))
|
||
|
||
(with-test (:name (interrupt-thread :deferrables-unblocked))
|
||
(interrupt-thread *current-thread*
|
||
(lambda ()
|
||
(with-interrupts
|
||
(check-deferrables-unblocked-or-lose 0))))
|
||
(process-all-interrupts))
|
||
|
||
(with-test (:name (interrupt-thread :nlx))
|
||
(catch 'xxx
|
||
(interrupt-thread *current-thread*
|
||
(lambda ()
|
||
(check-deferrables-blocked-or-lose 0)
|
||
(throw 'xxx nil)))
|
||
(process-all-interrupts))
|
||
(check-deferrables-unblocked-or-lose 0))
|
||
|
||
#-sb-thread (invoke-restart 'run-tests::skip-file)
|
||
|
||
;;;; Now the real tests...
|
||
|
||
(with-test (:name (with-mutex :timeout)
|
||
:broken-on :gc-stress)
|
||
(let ((m (make-mutex)))
|
||
(with-mutex (m)
|
||
(assert (null (join-thread (make-thread
|
||
(lambda ()
|
||
(with-mutex (m :timeout 0.1)
|
||
t)))))))
|
||
(assert (join-thread (make-thread
|
||
(lambda ()
|
||
(with-mutex (m :timeout 0.1)
|
||
t)))))))
|
||
|
||
;;; compare-and-swap
|
||
|
||
(defmacro defincf (name accessor &rest args)
|
||
`(defun ,name (x)
|
||
(let* ((old (,accessor x ,@args))
|
||
(new (1+ old)))
|
||
(loop until (eq old (sb-ext:compare-and-swap (,accessor x ,@args) old new))
|
||
do (setf old (,accessor x ,@args)
|
||
new (1+ old)))
|
||
new)))
|
||
|
||
(defstruct cas-struct (slot 0))
|
||
|
||
(defincf incf-car car)
|
||
(defincf incf-cdr cdr)
|
||
(defincf incf-slot cas-struct-slot)
|
||
(defincf incf-symbol-value symbol-value)
|
||
(defincf incf-svref/1 svref 1)
|
||
(defincf incf-svref/0 svref 0)
|
||
|
||
(macrolet
|
||
((def (name init incf op)
|
||
`(with-test (:name ,name)
|
||
(let* ((n 200000)
|
||
(x ,init)
|
||
(run (sb-thread:make-semaphore))
|
||
(threadcount 10)
|
||
(threads
|
||
(loop repeat threadcount
|
||
collect (make-thread
|
||
(lambda ()
|
||
(sb-thread:wait-on-semaphore run)
|
||
(loop repeat n do (,incf x)))))))
|
||
(sb-thread:signal-semaphore run threadcount)
|
||
(map nil #'join-thread threads)
|
||
(assert (= (,op x) (* threadcount n)))))))
|
||
|
||
(def (cas car) (cons 0 nil) incf-car car)
|
||
(def (cas cdr) (cons nil 0) incf-cdr cdr)
|
||
(def (cas :slot) (make-cas-struct) incf-slot cas-struct-slot)
|
||
(def (cas :value)
|
||
(let ((x '.x.))
|
||
(set x 0)
|
||
x)
|
||
incf-symbol-value
|
||
symbol-value)
|
||
(def (cas :svref/0) (vector 0 nil) incf-svref/0 (lambda (x) (svref x 0)))
|
||
(def (cas :svref/1) (vector nil 0) incf-svref/1 (lambda (x) (svref x 1))))
|
||
|
||
(with-test (:name (:threads :more-trivia))
|
||
(let ((old-threads (list-all-threads))
|
||
(thread (make-thread
|
||
(lambda ()
|
||
;; I honestly have no idea what this is testing.
|
||
;; It seems to be nothing more than an implementation change detector test.
|
||
(assert (sb-thread::avl-find
|
||
(sb-thread::thread-primitive-thread sb-thread:*current-thread*)
|
||
sb-thread::*all-threads*))
|
||
(sleep 2))))
|
||
(new-threads (list-all-threads)))
|
||
(assert (thread-alive-p thread))
|
||
;; there is no order guarantee
|
||
;;(assert (eq thread (first new-threads)))
|
||
(assert (= (1+ (length old-threads)) (length new-threads)))
|
||
(sleep 3)
|
||
(assert (not (thread-alive-p thread)))))
|
||
|
||
(with-test (:name (join-thread :abort :default))
|
||
(let* ((sym (gensym))
|
||
(thread (make-thread (lambda () (abort-thread)))))
|
||
(assert (equal (multiple-value-list
|
||
(join-thread thread :default sym))
|
||
(list sym :abort)))))
|
||
|
||
(with-test (:name (join-thread :abort :error))
|
||
(assert-error (join-thread (make-thread (lambda () (abort-thread))))
|
||
join-thread-error))
|
||
|
||
(with-test (:name (join-thread :timeout :default))
|
||
(let* ((sym (gensym))
|
||
(sem (make-semaphore))
|
||
(thread (make-thread (lambda () (wait-on-semaphore sem)))))
|
||
(assert (equal (multiple-value-list
|
||
(join-thread thread :timeout .001 :default sym))
|
||
(list sym :timeout)))
|
||
(signal-semaphore sem)
|
||
(assert (join-thread thread))))
|
||
|
||
(with-test (:name (join-thread :timeout :error))
|
||
(let* ((sem (make-semaphore))
|
||
(thread (make-thread (lambda () (wait-on-semaphore sem)))))
|
||
(assert-error (join-thread thread :timeout .001) join-thread-error)
|
||
(signal-semaphore sem)
|
||
(assert (join-thread thread))))
|
||
|
||
(with-test (:name (join-thread :multiple-values))
|
||
(assert (equal '(1 2 3)
|
||
(multiple-value-list
|
||
(join-thread (make-thread (lambda () (values 1 2 3))))))))
|
||
|
||
;; Used to signal a SIMPLE-ERROR about a recursive lock attempt.
|
||
(with-test (:name (join-thread :self-join))
|
||
(assert-error (join-thread *current-thread*) join-thread-error))
|
||
|
||
;;; elementary "can we get a lock and release it again"
|
||
(with-test (:name (:mutex :basics))
|
||
(let ((l (make-mutex :name "foo"))
|
||
(p *current-thread*))
|
||
(assert (eql (mutex-owner l) nil) nil "1")
|
||
(grab-mutex l)
|
||
(assert (eql (mutex-owner l) p) nil "3")
|
||
(release-mutex l)
|
||
(assert (eql (mutex-owner l) nil) nil "5")))
|
||
|
||
(with-test (:name (with-recursive-lock :basics))
|
||
(labels ((ours-p (value)
|
||
(eq *current-thread* value)))
|
||
(let ((l (make-mutex :name "rec")))
|
||
(assert (eql (mutex-owner l) nil) nil "1")
|
||
(with-recursive-lock (l)
|
||
(assert (ours-p (mutex-owner l)) nil "3")
|
||
(with-recursive-lock (l)
|
||
(assert (ours-p (mutex-owner l)) nil "4"))
|
||
(assert (ours-p (mutex-owner l)) nil "5"))
|
||
(assert (eql (mutex-owner l) nil) nil "6"))))
|
||
|
||
(with-test (:name (with-recursive-lock :wait-p))
|
||
(let ((m (make-mutex)))
|
||
(with-mutex (m)
|
||
(assert (null (join-thread (make-thread
|
||
(lambda ()
|
||
(with-recursive-lock (m :wait-p nil)
|
||
t)))))))
|
||
(assert (join-thread (make-thread
|
||
(lambda ()
|
||
(with-recursive-lock (m :wait-p nil)
|
||
t)))))))
|
||
|
||
(with-test (:name (with-recursive-lock :wait-p :recursive))
|
||
(let ((m (make-mutex)))
|
||
(assert (join-thread (make-thread
|
||
(lambda ()
|
||
(with-recursive-lock (m :wait-p nil)
|
||
(with-recursive-lock (m :wait-p nil)
|
||
t))))))))
|
||
|
||
(with-test (:name (with-recursive-lock :timeout)
|
||
:broken-on :gc-stress)
|
||
(let ((m (make-mutex)))
|
||
(with-mutex (m)
|
||
(assert (null (join-thread (make-thread
|
||
(lambda ()
|
||
(with-recursive-lock (m :timeout 0.1)
|
||
t)))))))
|
||
(assert (join-thread (make-thread
|
||
(lambda ()
|
||
(with-recursive-lock (m :timeout 0.1)
|
||
t)))))))
|
||
|
||
(with-test (:name (with-recursive-lock :timeout :recursive))
|
||
(let ((m (make-mutex)))
|
||
(assert (join-thread (make-thread
|
||
(lambda ()
|
||
(with-recursive-lock (m :timeout 0.1)
|
||
(with-recursive-lock (m :timeout 0.1)
|
||
t))))))))
|
||
|
||
(with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
|
||
(let ((l (make-mutex :name "a mutex")))
|
||
(with-mutex (l)
|
||
(with-recursive-lock (l)))))
|
||
|
||
(with-test (:name (condition-wait :basics-1)
|
||
:skipped-on :gc-stress)
|
||
(let ((queue (make-waitqueue :name "queue"))
|
||
(lock (make-mutex :name "lock"))
|
||
(n 0))
|
||
(labels ((in-new-thread ()
|
||
(with-mutex (lock)
|
||
(assert (eql (mutex-owner lock) *current-thread*))
|
||
(format t "~A got mutex~%" *current-thread*)
|
||
;; now drop it and sleep
|
||
;; FIXME: condition-wait returning doesn't mean there was condition-notify
|
||
(condition-wait queue lock)
|
||
;; after waking we should have the lock again
|
||
(assert (eql (mutex-owner lock) *current-thread*))
|
||
(assert (eql n 1))
|
||
(decf n))))
|
||
(make-join-thread #'in-new-thread)
|
||
(sleep 2) ; give it a chance to start
|
||
;; check the lock is free while it's asleep
|
||
(format t "parent thread ~A~%" *current-thread*)
|
||
(assert (eql (mutex-owner lock) nil))
|
||
(with-mutex (lock)
|
||
(incf n)
|
||
(condition-notify queue))
|
||
(sleep 1))))
|
||
|
||
(with-test (:name (condition-wait :basics-2)
|
||
:skipped-on :gc-stress)
|
||
(let ((queue (make-waitqueue :name "queue"))
|
||
(lock (make-mutex :name "lock")))
|
||
(labels ((ours-p (value)
|
||
(eq *current-thread* value))
|
||
(in-new-thread ()
|
||
(with-recursive-lock (lock)
|
||
(assert (ours-p (mutex-owner lock)))
|
||
(format t "~A got mutex~%" (mutex-owner lock))
|
||
;; now drop it and sleep
|
||
;; FIXME: condition-wait returning doesn't mean there was condition-notify
|
||
(condition-wait queue lock)
|
||
;; after waking we should have the lock again
|
||
(format t "woken, ~A got mutex~%" (mutex-owner lock))
|
||
(assert (ours-p (mutex-owner lock))))))
|
||
(make-join-thread #'in-new-thread)
|
||
(sleep 2) ; give it a chance to start
|
||
;; check the lock is free while it's asleep
|
||
(format t "parent thread ~A~%" *current-thread*)
|
||
(assert (eql (mutex-owner lock) nil))
|
||
(with-recursive-lock (lock)
|
||
(condition-notify queue))
|
||
(sleep 1))))
|
||
|
||
;;; GRAB-MUTEX
|
||
|
||
(with-test (:name (grab-mutex :waitp nil))
|
||
(let ((m (make-mutex)))
|
||
(with-mutex (m)
|
||
(assert (null (join-thread (make-thread
|
||
#'(lambda ()
|
||
(grab-mutex m :waitp nil)))))))))
|
||
|
||
(with-test (:name (grab-mutex :timeout :acquisition-fail))
|
||
(let ((m (make-mutex))
|
||
(w (make-semaphore)))
|
||
(with-mutex (m)
|
||
(let ((th (make-thread
|
||
#'(lambda ()
|
||
(prog1
|
||
(grab-mutex m :timeout 0.1)
|
||
(signal-semaphore w))))))
|
||
;; Wait for it to -- otherwise the detect the deadlock chain
|
||
;; from JOIN-THREAD.
|
||
(wait-on-semaphore w)
|
||
(assert (null (join-thread th)))))))
|
||
|
||
(with-test (:name (grab-mutex :timeout :acquisition-success)
|
||
:skipped-on :gc-stress)
|
||
(let ((m (make-mutex))
|
||
(child))
|
||
(with-mutex (m)
|
||
(setq child (make-thread #'(lambda () (grab-mutex m :timeout 1.0))))
|
||
(sleep 0.2))
|
||
(assert (eq (join-thread child) 't))))
|
||
|
||
(with-test (:name (grab-mutex :timeout+deadline :lp-1727789))
|
||
(flet ((test (deadline)
|
||
(let ((m (make-mutex))
|
||
(w (make-semaphore)))
|
||
(with-mutex (m)
|
||
(let ((th (make-thread #'(lambda ()
|
||
(sb-sys:with-deadline (:seconds 0.0)
|
||
(handler-case
|
||
(grab-mutex m :timeout deadline)
|
||
(sb-sys:deadline-timeout ()
|
||
(signal-semaphore w)
|
||
:deadline)))))))
|
||
(wait-on-semaphore w)
|
||
(assert (eq (join-thread th) :deadline)))))))
|
||
(test 0.0)
|
||
(test 10000000000000000000000)))
|
||
|
||
(with-test (:name (grab-mutex :waitp+deadline))
|
||
(let ((m (make-mutex)))
|
||
(with-mutex (m)
|
||
(assert (eq (join-thread
|
||
(make-thread #'(lambda ()
|
||
(sb-sys:with-deadline (:seconds 0.0)
|
||
(handler-case
|
||
(grab-mutex m :waitp nil)
|
||
(sb-sys:deadline-timeout ()
|
||
:deadline))))))
|
||
'nil)))))
|
||
|