mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
325 lines
14 KiB
Common Lisp
325 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.
|
|
|
|
(use-package '("SB-EXT" "SB-THREAD"))
|
|
|
|
(with-test (:name :dont-print-array
|
|
:skipped-on (not :sb-thread))
|
|
(let ((thr (sb-thread:make-thread (lambda () (make-array 100)))))
|
|
(sb-thread:join-thread thr)
|
|
(assert (search "#<(SIMPLE-VECTOR" (write-to-string thr)))))
|
|
|
|
(with-test (:name atomic-update
|
|
:skipped-on (not :sb-thread))
|
|
(let ((x (cons :count 0))
|
|
(nthreads (ecase sb-vm:n-word-bits (32 100) (64 1000))))
|
|
(mapc #'join-thread
|
|
(loop repeat nthreads
|
|
collect (make-thread (lambda ()
|
|
(loop repeat 1000
|
|
do (atomic-update (cdr x) #'1+))))))
|
|
(assert (equal x `(:count ,@(* 1000 nthreads))))))
|
|
|
|
(with-test (:name mutex-owner)
|
|
;; Make sure basics are sane on unithreaded ports as well
|
|
(let ((mutex (make-mutex)))
|
|
(grab-mutex mutex)
|
|
(assert (eq *current-thread* (mutex-owner mutex)))
|
|
(handler-bind ((warning #'error))
|
|
(release-mutex mutex))
|
|
(assert (not (mutex-owner mutex)))))
|
|
|
|
(with-test (:name :parallel-find-class :skipped-on (not :sb-thread))
|
|
(let* ((oops nil)
|
|
(threads (loop repeat 10
|
|
collect (make-thread (lambda ()
|
|
(handler-case
|
|
(loop repeat 10000
|
|
do (find-class (gensym) nil))
|
|
(serious-condition ()
|
|
(setf oops t))))))))
|
|
(mapc #'join-thread threads)
|
|
(assert (not oops))))
|
|
|
|
;;;; Printing waitqueues
|
|
|
|
(with-test (:name :waitqueue-circle-print :skipped-on (not :sb-thread))
|
|
(let* ((*print-circle* nil)
|
|
(lock (make-mutex))
|
|
(wq (make-waitqueue)))
|
|
(with-recursive-lock (lock)
|
|
(condition-notify wq))
|
|
;; Used to blow stack due to recursive structure.
|
|
(assert (princ-to-string wq))))
|
|
|
|
;;;; SYMBOL-VALUE-IN-THREAD
|
|
|
|
(with-test (:name :symbol-value-in-thread.1)
|
|
(let ((* (cons t t)))
|
|
(assert (eq * (symbol-value-in-thread '* *current-thread*)))
|
|
(setf (symbol-value-in-thread '* *current-thread*) 123)
|
|
(assert (= 123 (symbol-value-in-thread '* *current-thread*)))
|
|
(assert (= 123 *))))
|
|
|
|
(with-test (:name :symbol-value-in-thread.2 :skipped-on (not :sb-thread))
|
|
(let* ((parent *current-thread*)
|
|
(semaphore (make-semaphore))
|
|
(child (make-thread (lambda ()
|
|
(wait-on-semaphore semaphore)
|
|
(let ((old (symbol-value-in-thread 'this-is-new parent)))
|
|
(setf (symbol-value-in-thread 'this-is-new parent) :from-child)
|
|
old)))))
|
|
(progv '(this-is-new) '(42)
|
|
(signal-semaphore semaphore)
|
|
(assert (= 42 (join-thread child)))
|
|
(assert (eq :from-child (symbol-value 'this-is-new))))))
|
|
|
|
(with-test (:name :symbol-value-in-thread.3
|
|
:skipped-on (not :sb-thread)
|
|
)
|
|
(let* ((parent *current-thread*)
|
|
(semaphore (make-semaphore))
|
|
(running t)
|
|
(noise (make-thread (lambda ()
|
|
(loop while running
|
|
do (setf * (make-array 1024))
|
|
;; Busy-wait a bit so we don't TOTALLY flood the
|
|
;; system with GCs.
|
|
(loop repeat (random 128)
|
|
do (setf ** *)))))))
|
|
(dotimes (i 500)
|
|
(let* ((mom-mark (cons t t))
|
|
(kid-mark (cons t t))
|
|
(child (make-thread
|
|
(lambda ()
|
|
(if (wait-on-semaphore semaphore :timeout 10)
|
|
(let ((old (symbol-value-in-thread 'this-is-new parent)))
|
|
(setf (symbol-value-in-thread 'this-is-new parent)
|
|
(make-array 24 :initial-element kid-mark))
|
|
old)
|
|
:timeout)))))
|
|
(progv '(this-is-new) (list (make-array 24 :initial-element mom-mark))
|
|
(signal-semaphore semaphore)
|
|
(assert (eq mom-mark (aref (join-thread child :timeout 10) 0)))
|
|
(assert (eq kid-mark (aref (symbol-value 'this-is-new) 0))))))
|
|
(setf running nil)
|
|
(join-thread noise)))
|
|
|
|
(with-test (:name :symbol-value-in-thread.4 :skipped-on (not :sb-thread))
|
|
(let* ((parent *current-thread*)
|
|
(semaphore (make-semaphore))
|
|
(child (make-thread (lambda ()
|
|
(wait-on-semaphore semaphore)
|
|
(symbol-value-in-thread 'this-is-new parent nil)))))
|
|
(signal-semaphore semaphore)
|
|
(assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
|
|
|
|
(with-test (:name :symbol-value-in-thread.5 :skipped-on (not :sb-thread))
|
|
(let* ((parent *current-thread*)
|
|
(semaphore (make-semaphore))
|
|
(child (make-thread (lambda ()
|
|
(wait-on-semaphore semaphore)
|
|
(handler-case
|
|
(symbol-value-in-thread 'this-is-new parent)
|
|
(symbol-value-in-thread-error (e)
|
|
(list (thread-error-thread e)
|
|
(cell-error-name e)
|
|
(sb-thread::symbol-value-in-thread-error-info e))))))))
|
|
(signal-semaphore semaphore)
|
|
(assert (equal (list *current-thread* 'this-is-new (list :read :no-tls-value))
|
|
(join-thread child)))))
|
|
|
|
(with-test (:name :symbol-value-in-thread.6 :skipped-on (not :sb-thread))
|
|
(let* ((parent *current-thread*)
|
|
(semaphore (make-semaphore))
|
|
(name (gensym))
|
|
(child (make-thread (lambda ()
|
|
(wait-on-semaphore semaphore)
|
|
(handler-case
|
|
(setf (symbol-value-in-thread name parent) t)
|
|
(symbol-value-in-thread-error (e)
|
|
(list (thread-error-thread e)
|
|
(cell-error-name e)
|
|
(sb-thread::symbol-value-in-thread-error-info e))))))))
|
|
(signal-semaphore semaphore)
|
|
(let ((res (join-thread child))
|
|
(want (list *current-thread* name (list :write :no-tls-value))))
|
|
(unless (equal res want)
|
|
(error "wanted ~S, got ~S" want res)))))
|
|
|
|
(with-test (:name :symbol-value-in-thread.7 :skipped-on (not :sb-thread))
|
|
(let ((child (make-thread (lambda ())))
|
|
(error-occurred nil))
|
|
(join-thread child)
|
|
(handler-case
|
|
(symbol-value-in-thread 'this-is-new child)
|
|
(symbol-value-in-thread-error (e)
|
|
(setf error-occurred t)
|
|
(assert (eq child (thread-error-thread e)))
|
|
(assert (eq 'this-is-new (cell-error-name e)))
|
|
(assert (equal (list :read :thread-dead)
|
|
(sb-thread::symbol-value-in-thread-error-info e)))))
|
|
(assert error-occurred)))
|
|
|
|
(with-test (:name :symbol-value-in-thread.8 :skipped-on (not :sb-thread))
|
|
(let ((child (make-thread (lambda ())))
|
|
(error-occurred nil))
|
|
(join-thread child)
|
|
(handler-case
|
|
(setf (symbol-value-in-thread 'this-is-new child) t)
|
|
(symbol-value-in-thread-error (e)
|
|
(setf error-occurred t)
|
|
(assert (eq child (thread-error-thread e)))
|
|
(assert (eq 'this-is-new (cell-error-name e)))
|
|
(assert (equal (list :write :thread-dead)
|
|
(sb-thread::symbol-value-in-thread-error-info e)))))
|
|
(assert error-occurred)))
|
|
|
|
#+sb-thread
|
|
(with-test (:name :pass-arguments-to-thread)
|
|
(assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
|
|
|
|
#+sb-thread
|
|
(with-test (:name :pass-atom-to-thread)
|
|
(assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
|
|
|
|
#+sb-thread
|
|
(with-test (:name :pass-nil-to-thread)
|
|
(assert (= 1 (join-thread (make-thread #'* :arguments '())))))
|
|
|
|
#+sb-thread
|
|
(with-test (:name :pass-nothing-to-thread)
|
|
(assert (= 1 (join-thread (make-thread #'*)))))
|
|
|
|
#+sb-thread
|
|
(with-test (:name :pass-improper-list-to-thread)
|
|
(multiple-value-bind (value error)
|
|
(ignore-errors (make-thread #'+ :arguments '(1 . 1)))
|
|
(when value
|
|
(join-thread value))
|
|
(assert (and (null value)
|
|
error))))
|
|
|
|
(with-test (:name (:condition-wait :timeout :one-thread)
|
|
:skipped-on :gc-stress)
|
|
(let ((mutex (make-mutex))
|
|
(waitqueue (make-waitqueue)))
|
|
(assert (not (with-mutex (mutex)
|
|
(condition-wait waitqueue mutex :timeout 0.01))))))
|
|
|
|
(with-test (:name (:condition-wait :timeout :many-threads)
|
|
:skipped-on (or (not :sb-thread) :gc-stress))
|
|
(let* ((mutex (make-mutex))
|
|
(waitqueue (make-waitqueue))
|
|
(sem (make-semaphore))
|
|
(data nil)
|
|
(workers
|
|
(loop repeat 100
|
|
collect (make-thread
|
|
(lambda ()
|
|
(wait-on-semaphore sem)
|
|
(block thread
|
|
(with-mutex (mutex)
|
|
(loop until data
|
|
do (or (condition-wait waitqueue mutex :timeout 0.01)
|
|
(return-from thread nil)))
|
|
(assert (eq t (pop data)))
|
|
t)))))))
|
|
(loop repeat 50
|
|
do (with-mutex (mutex)
|
|
(push t data)
|
|
(condition-notify waitqueue)))
|
|
(signal-semaphore sem 100)
|
|
(let ((ok (count-if #'join-thread workers)))
|
|
(unless (eql 50 ok)
|
|
(error "Wanted 50, got ~S" ok)))))
|
|
|
|
(with-test (:name (wait-on-semaphore :timeout :one-thread))
|
|
(let ((count 10)
|
|
(semaphore (make-semaphore)))
|
|
(signal-semaphore semaphore count)
|
|
(let ((values (loop repeat 100
|
|
collect (wait-on-semaphore semaphore :timeout 0.001)))
|
|
(expected (loop for i from 9 downto 0 collect i)))
|
|
(assert (equal (remove nil values) expected)))))
|
|
|
|
(with-test (:name (wait-on-semaphore :n))
|
|
(let ((semaphore (make-semaphore :count 3)))
|
|
(assert (= 1 (wait-on-semaphore semaphore :n 2)))
|
|
(assert (= 1 (semaphore-count semaphore)))))
|
|
|
|
(with-test (:name (try-semaphore semaphore-notification)
|
|
:skipped-on (not :sb-thread))
|
|
(let* ((sem (make-semaphore))
|
|
(note (make-semaphore-notification)))
|
|
(assert (eql nil (try-semaphore sem 1 note)))
|
|
(assert (not (semaphore-notification-status note)))
|
|
(signal-semaphore sem)
|
|
(assert (eql 0 (try-semaphore sem 1 note)))
|
|
(assert (semaphore-notification-status note))))
|
|
|
|
(with-test (:name (return-from-thread :normal-thread)
|
|
:skipped-on (not :sb-thread))
|
|
(let ((thread (make-thread (lambda ()
|
|
(return-from-thread (values 1 2 3))
|
|
:foo))))
|
|
(assert (equal '(1 2 3) (multiple-value-list (join-thread thread))))))
|
|
|
|
(with-test (:name (return-from-thread :main-thread))
|
|
(assert (main-thread-p))
|
|
(assert-error (return-from-thread t) thread-error))
|
|
|
|
(with-test (:name (abort-thread :normal-thread)
|
|
:skipped-on (not :sb-thread))
|
|
(let ((thread (make-thread (lambda ()
|
|
(abort-thread)
|
|
:foo))))
|
|
(assert (equal '(:aborted! :abort)
|
|
(multiple-value-list
|
|
(join-thread thread :default :aborted!))))))
|
|
|
|
(with-test (:name (abort-thread :main-thread))
|
|
(assert (main-thread-p))
|
|
(assert-error (abort-thread) thread-error))
|
|
|
|
;;; The OSes vary in how pthread_setname works.
|
|
;;; According to https://stackoverflow.com/questions/2369738/how-to-set-the-name-of-a-thread-in-linux-pthreads
|
|
;;; // NetBSD: name + arg work like printf(name, arg)
|
|
;;; int pthread_setname_np(pthread_t thread, const char *name, void *arg);
|
|
;;; // FreeBSD & OpenBSD: function name is slightly different, and has no return value
|
|
;;; void pthread_set_name_np(pthread_t tid, const char *name);
|
|
;;; // Mac OS X: must be set from within the thread (can't specify thread ID)
|
|
;;; int pthread_setname_np(const char*);
|
|
;;; Only Linux is implemented for now.
|
|
(with-test (:name :os-thread-name :skipped-on (:not (and :linux :sb-thread)))
|
|
(let ((thr
|
|
(make-thread
|
|
(lambda ()
|
|
(let ((all-names
|
|
(loop for filename in (directory "/proc/self/task/*/comm")
|
|
collect (with-open-file (stream filename) (read-line stream)))))
|
|
(setf (thread-name *current-thread*) "newname")
|
|
(with-open-file (stream (format nil "/proc/self/task/~d/comm"
|
|
(thread-os-tid *current-thread*)))
|
|
(list (read-line stream) all-names))))
|
|
:name "testme")))
|
|
(let ((results (join-thread thr)))
|
|
(assert (string= (first results) "newname"))
|
|
(assert (find "finalizer" (second results) :test 'string=))
|
|
(assert (find "testme" (second results) :test 'string=)))))
|
|
|
|
(with-test (:name :thread-from-tid)
|
|
(let ((tid (sb-thread:thread-os-tid *current-thread*)))
|
|
(when (plusp tid) ; SunOS returns 0
|
|
(assert (eq (sb-thread:%thread-from-tid tid) *current-thread*)))))
|