1 ;;;; miscellaneous tests of thread stuff
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (cl:defpackage
#:thread-test
15 (:use
#:cl
#:sb-thread
#:sb-ext
#:test-util
#:assertoid
))
17 (cl:in-package
#:thread-test
)
19 (with-test (:name atomic-update
20 :skipped-on
(not :sb-thread
))
21 (let ((x (cons :count
0))
22 (nthreads (ecase sb-vm
:n-word-bits
(32 100) (64 1000))))
25 collect
(make-thread (lambda ()
27 do
(atomic-update (cdr x
) #'1+)
29 (assert (equal x
`(:count
,@(* 1000 nthreads
))))))
31 (with-test (:name mutex-owner
)
32 ;; Make sure basics are sane on unithreaded ports as well
33 (let ((mutex (make-mutex)))
35 (assert (eq *current-thread
* (mutex-value mutex
)))
36 (handler-bind ((warning #'error
))
37 (release-mutex mutex
))
38 (assert (not (mutex-value mutex
)))))
40 ;;; Terminating a thread that's waiting for the terminal.
42 (with-test (:name
(:terminate-thread
:get-foreground
)
43 :skipped-on
(not :sb-thread
)
45 (let ((thread (make-thread (lambda ()
46 (sb-thread::get-foreground
)))))
48 (assert (thread-alive-p thread
))
49 (terminate-thread thread
)
51 (assert (not (thread-alive-p thread
)))))
53 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
55 (with-test (:name
:without-interrupts
+condition-wait
56 :skipped-on
(not :sb-thread
)
58 (let* ((lock (make-mutex))
59 (queue (make-waitqueue))
60 (thread (make-thread (lambda ()
61 (sb-sys:without-interrupts
63 (condition-wait queue lock
)))))))
65 (assert (thread-alive-p thread
))
66 (terminate-thread thread
)
68 (assert (thread-alive-p thread
))
69 (condition-notify queue
)
71 (assert (not (thread-alive-p thread
)))))
73 ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
75 (with-test (:name
:without-interrupts
+grab-mutex
76 :skipped-on
(not :sb-thread
)
78 (let* ((lock (make-mutex))
79 (bar (progn (grab-mutex lock
) nil
))
80 (thread (make-thread (lambda ()
81 (sb-sys:without-interrupts
85 (assert (thread-alive-p thread
))
86 (terminate-thread thread
)
88 (assert (thread-alive-p thread
))
91 (assert (not (thread-alive-p thread
)))
92 (assert (eq :aborted
(join-thread thread
:default
:aborted
)))
95 (with-test (:name
:parallel-find-class
:skipped-on
(not :sb-thread
))
97 (threads (loop repeat
10
98 collect
(make-thread (lambda ()
101 do
(find-class (gensym) nil
))
102 (serious-condition ()
104 (mapc #'join-thread threads
)
105 (assert (not oops
))))
107 (with-test (:name
:semaphore-multiple-waiters
:skipped-on
(not :sb-thread
))
108 (let ((semaphore (make-semaphore :name
"test sem")))
109 (labels ((make-readers (n i
)
111 (loop for r from
0 below n
115 (let ((sem semaphore
))
117 (wait-on-semaphore sem
))))
120 (make-writers (n readers i
)
121 (let ((j (* readers i
)))
122 (multiple-value-bind (k rem
) (truncate j n
)
125 (loop for w from
0 below n
129 (let ((sem semaphore
))
131 (signal-semaphore sem
))))
137 (multiple-value-bind (readers x
) (make-readers r n
)
138 (assert (= (length readers
) r
))
139 (multiple-value-bind (writers y
) (make-writers w r n
)
140 (assert (= (length writers
) w
))
142 (mapc #'join-thread writers
)
143 (mapc #'join-thread readers
)
144 (assert (zerop (semaphore-count semaphore
)))
149 (sb-ext:with-timeout
10
160 ;;;; Printing waitqueues
162 (with-test (:name
:waitqueue-circle-print
:skipped-on
(not :sb-thread
))
163 (let* ((*print-circle
* nil
)
165 (wq (make-waitqueue)))
166 (with-recursive-lock (lock)
167 (condition-notify wq
))
168 ;; Used to blow stack due to recursive structure.
169 (assert (princ-to-string wq
))))
171 ;;;; SYMBOL-VALUE-IN-THREAD
173 (with-test (:name
:symbol-value-in-thread
.1)
174 (let ((* (cons t t
)))
175 (assert (eq * (symbol-value-in-thread '* *current-thread
*)))
176 (setf (symbol-value-in-thread '* *current-thread
*) 123)
177 (assert (= 123 (symbol-value-in-thread '* *current-thread
*)))
180 (with-test (:name
:symbol-value-in-thread
.2 :skipped-on
(not :sb-thread
))
181 (let* ((parent *current-thread
*)
182 (semaphore (make-semaphore))
183 (child (make-thread (lambda ()
184 (wait-on-semaphore semaphore
)
185 (let ((old (symbol-value-in-thread 'this-is-new parent
)))
186 (setf (symbol-value-in-thread 'this-is-new parent
) :from-child
)
188 (progv '(this-is-new) '(42)
189 (signal-semaphore semaphore
)
190 (assert (= 42 (join-thread child
)))
191 (assert (eq :from-child
(symbol-value 'this-is-new
))))))
193 (with-test (:name
:symbol-value-in-thread
.3
194 :skipped-on
(not :sb-thread
))
195 (let* ((parent *current-thread
*)
196 (semaphore (make-semaphore))
198 (noise (make-thread (lambda ()
200 do
(setf * (make-array 1024))
201 ;; Busy-wait a bit so we don't TOTALLY flood the
202 ;; system with GCs: a GC occurring in the middle of
203 ;; S-V-I-T causes it to start over -- we want that
204 ;; to occur occasionally, but not _all_ the time.
205 (loop repeat
(random 128)
208 (dotimes (i #+(or win32 openbsd
) 2000
209 #-
(or win32 openbsd
) 15000)
210 (when (zerop (mod i
200))
213 (let* ((mom-mark (cons t t
))
214 (kid-mark (cons t t
))
217 (if (wait-on-semaphore semaphore
:timeout
10)
218 (let ((old (symbol-value-in-thread 'this-is-new parent
)))
219 (setf (symbol-value-in-thread 'this-is-new parent
)
220 (make-array 24 :initial-element kid-mark
))
223 (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark
))
224 (signal-semaphore semaphore
)
225 (assert (eq mom-mark
(aref (join-thread child
:timeout
10) 0)))
226 (assert (eq kid-mark
(aref (symbol-value 'this-is-new
) 0))))))
228 (join-thread noise
)))
230 (with-test (:name
:symbol-value-in-thread
.4 :skipped-on
(not :sb-thread
))
231 (let* ((parent *current-thread
*)
232 (semaphore (make-semaphore))
233 (child (make-thread (lambda ()
234 (wait-on-semaphore semaphore
)
235 (symbol-value-in-thread 'this-is-new parent nil
)))))
236 (signal-semaphore semaphore
)
237 (assert (equal '(nil nil
) (multiple-value-list (join-thread child
))))))
239 (with-test (:name
:symbol-value-in-thread
.5 :skipped-on
(not :sb-thread
))
240 (let* ((parent *current-thread
*)
241 (semaphore (make-semaphore))
242 (child (make-thread (lambda ()
243 (wait-on-semaphore semaphore
)
245 (symbol-value-in-thread 'this-is-new parent
)
246 (symbol-value-in-thread-error (e)
247 (list (thread-error-thread e
)
249 (sb-thread::symbol-value-in-thread-error-info e
))))))))
250 (signal-semaphore semaphore
)
251 (assert (equal (list *current-thread
* 'this-is-new
(list :read
:unbound-in-thread
))
252 (join-thread child
)))))
254 (with-test (:name
:symbol-value-in-thread
.6 :skipped-on
(not :sb-thread
))
255 (let* ((parent *current-thread
*)
256 (semaphore (make-semaphore))
258 (child (make-thread (lambda ()
259 (wait-on-semaphore semaphore
)
261 (setf (symbol-value-in-thread name parent
) t
)
262 (symbol-value-in-thread-error (e)
263 (list (thread-error-thread e
)
265 (sb-thread::symbol-value-in-thread-error-info e
))))))))
266 (signal-semaphore semaphore
)
267 (let ((res (join-thread child
))
268 (want (list *current-thread
* name
(list :write
:no-tls-value
))))
269 (unless (equal res want
)
270 (error "wanted ~S, got ~S" want res
)))))
272 (with-test (:name
:symbol-value-in-thread
.7 :skipped-on
(not :sb-thread
))
273 (let ((child (make-thread (lambda ())))
274 (error-occurred nil
))
277 (symbol-value-in-thread 'this-is-new child
)
278 (symbol-value-in-thread-error (e)
279 (setf error-occurred t
)
280 (assert (eq child
(thread-error-thread e
)))
281 (assert (eq 'this-is-new
(cell-error-name e
)))
282 (assert (equal (list :read
:thread-dead
)
283 (sb-thread::symbol-value-in-thread-error-info e
)))))
284 (assert error-occurred
)))
286 (with-test (:name
:symbol-value-in-thread
.8 :skipped-on
(not :sb-thread
))
287 (let ((child (make-thread (lambda ())))
288 (error-occurred nil
))
291 (setf (symbol-value-in-thread 'this-is-new child
) t
)
292 (symbol-value-in-thread-error (e)
293 (setf error-occurred t
)
294 (assert (eq child
(thread-error-thread e
)))
295 (assert (eq 'this-is-new
(cell-error-name e
)))
296 (assert (equal (list :write
:thread-dead
)
297 (sb-thread::symbol-value-in-thread-error-info e
)))))
298 (assert error-occurred
)))
300 (with-test (:name
:deadlock-detection
.1 :skipped-on
(not :sb-thread
))
303 do
(flet ((test (ma mb sa sb
)
307 (signal-semaphore sa
)
308 (wait-on-semaphore sb
)
312 ;; (assert (plusp (length ...))) prevents
314 (assert (plusp (length (princ-to-string e
))))
316 (let* ((m1 (make-mutex :name
"M1"))
317 (m2 (make-mutex :name
"M2"))
318 (s1 (make-semaphore :name
"S1"))
319 (s2 (make-semaphore :name
"S2"))
320 (t1 (make-thread (test m1 m2 s1 s2
) :name
"T1"))
321 (t2 (make-thread (test m2 m1 s2 s1
) :name
"T2")))
322 ;; One will deadlock, and the other will then complete normally.
323 (let ((res (list (join-thread t1
)
325 (assert (or (equal '(:deadlock
:ok
) res
)
326 (equal '(:ok
:deadlock
) res
))))))))
328 (with-test (:name
:deadlock-detection
.2 :skipped-on
(not :sb-thread
))
329 (let* ((m1 (make-mutex :name
"M1"))
330 (m2 (make-mutex :name
"M2"))
331 (s1 (make-semaphore :name
"S1"))
332 (s2 (make-semaphore :name
"S2"))
336 (signal-semaphore s1
)
337 (wait-on-semaphore s2
)
343 (handler-bind ((thread-deadlock
346 ;; Make sure we can print the condition
348 (let ((*print-circle
* nil
))
349 (setf err
(princ-to-string e
)))
353 (assert (eq :ok
(with-mutex (m2)
355 (signal-semaphore s2
)
356 (wait-on-semaphore s1
)
360 (assert (stringp err
)))
361 (assert (eq :ok
(join-thread t1
)))))
363 (with-test (:name
:deadlock-detection
.3 :skipped-on
(not :sb-thread
))
364 (let* ((m1 (make-mutex :name
"M1"))
365 (m2 (make-mutex :name
"M2"))
366 (s1 (make-semaphore :name
"S1"))
367 (s2 (make-semaphore :name
"S2"))
371 (signal-semaphore s1
)
372 (wait-on-semaphore s2
)
376 ;; Currently we don't consider it a deadlock
377 ;; if there is a timeout in the chain.
378 (assert (eq :deadline
381 (signal-semaphore s2
)
382 (wait-on-semaphore s1
)
384 (sb-sys:with-deadline
(:seconds
0.1)
387 (sb-sys:deadline-timeout
()
391 (assert (eq :ok
(join-thread t1
)))))
394 (with-test (:name
:pass-arguments-to-thread
)
395 (assert (= 3 (join-thread (make-thread #'+ :arguments
'(1 2))))))
398 (with-test (:name
:pass-atom-to-thread
)
399 (assert (= 1/2 (join-thread (make-thread #'/ :arguments
2)))))
402 (with-test (:name
:pass-nil-to-thread
)
403 (assert (= 1 (join-thread (make-thread #'* :arguments
'())))))
406 (with-test (:name
:pass-nothing-to-thread
)
407 (assert (= 1 (join-thread (make-thread #'*)))))
410 (with-test (:name
:pass-improper-list-to-thread
)
411 (multiple-value-bind (value error
)
412 (ignore-errors (make-thread #'+ :arguments
'(1 .
1)))
415 (assert (and (null value
)
418 (with-test (:name
(:wait-for
:basics
))
419 (assert (not (sb-ext:wait-for nil
:timeout
0.1)))
420 (assert (eql 42 (sb-ext:wait-for
42)))
422 (assert (eql 100 (sb-ext:wait-for
(when (= 100 (incf n
))
425 (with-test (:name
(:wait-for
:deadline
))
427 (sb-sys:with-deadline
(:seconds
10)
428 (assert (not (sb-ext:wait-for nil
:timeout
0.1)))
430 (assert (eq :deadline
432 (sb-sys:with-deadline
(:seconds
0.1)
433 (sb-ext:wait-for nil
:timeout
10)
435 (sb-sys:deadline-timeout
() :deadline
)))))
437 (with-test (:name
(:condition-wait
:timeout
:one-thread
))
438 (let ((mutex (make-mutex))
439 (waitqueue (make-waitqueue)))
440 (assert (not (with-mutex (mutex)
441 (condition-wait waitqueue mutex
:timeout
0.01))))))
443 (with-test (:name
(:condition-wait
:timeout
:many-threads
)
444 :skipped-on
(not :sb-thread
))
445 (let* ((mutex (make-mutex))
446 (waitqueue (make-waitqueue))
447 (sem (make-semaphore))
453 (wait-on-semaphore sem
)
457 do
(or (condition-wait waitqueue mutex
:timeout
0.01)
458 (return-from thread nil
)))
459 (assert (eq t
(pop data
)))
462 do
(with-mutex (mutex)
464 (condition-notify waitqueue
)))
465 (signal-semaphore sem
100)
466 (let ((ok (count-if #'join-thread workers
)))
468 (error "Wanted 50, got ~S" ok
)))))
470 (with-test (:name
(wait-on-semaphore :timeout
:one-thread
))
472 (semaphore (make-semaphore)))
473 (signal-semaphore semaphore count
)
474 (let ((values (loop repeat
100
475 collect
(wait-on-semaphore semaphore
:timeout
0.001)))
476 (expected (loop for i from
9 downto
0 collect i
)))
477 (assert (equal (remove nil values
) expected
)))))
479 (with-test (:name
(wait-on-semaphore :timeout
:many-threads
)
480 :skipped-on
(not :sb-thread
))
482 (semaphore (make-semaphore)))
483 ;; Add 10 tokens right away.
484 (signal-semaphore semaphore count
)
485 ;; 100 threads try to decrement the semaphore by 1.
490 (sleep (random 0.02))
491 (wait-on-semaphore semaphore
:timeout
0.5))))))
492 ;; Add 10 more tokens while threads may already be waiting and
494 (loop repeat
(floor count
2) do
(signal-semaphore semaphore
2))
495 ;; 20 threads should have been able to decrement the semaphore
496 ;; and obtain an updated count.
497 (let ((values (mapcar #'join-thread threads
)))
498 ;; 20 threads should succeed waiting for the semaphore.
499 (assert (= (* 2 count
) (count-if-not #'null values
)))
500 ;; The updated semaphore count should be in [0,19] at all
502 (assert (every (lambda (value) (<= 0 value
(1- (* 2 count
))))
503 (remove nil values
)))
504 ;; (At least) one thread should decrease the count to 0.
505 (assert (find 0 values
))))))
507 (with-test (:name
(:join-thread
:timeout
)
508 :skipped-on
(not :sb-thread
))
510 (join-thread (make-join-thread (lambda () (sleep 10))) :timeout
0.01)
512 (let ((cookie (cons t t
)))
514 (join-thread (make-join-thread (lambda () (sleep 10)))
518 (with-test (:name
(wait-on-semaphore semaphore-notification
:lp-1038034
)
519 :skipped-on
(not :sb-thread
)
520 :fails-on
(and :sb-thread
521 (not :darwin
)) ;; Maybe because it doesn't use futexes?
523 ;; Test robustness of semaphore acquisition and notification with
524 ;; asynchronous thread termination... Which we know is currently
527 (let ((sem (make-semaphore)))
528 ;; In CRITICAL, WAIT-ON-SEMAPHORE and SLEEP can be interrupted
529 ;; by TERMINATE-THREAD below. But the SIGNAL-SEMAPHORE cleanup
530 ;; cannot be interrupted.
531 (flet ((critical (sleep)
532 (let ((note (make-semaphore-notification)))
533 (sb-sys:without-interrupts
535 (sb-sys:with-local-interrupts
536 (wait-on-semaphore sem
:notification note
)
538 ;; Re-increment on exit if we decremented it.
539 (when (semaphore-notification-status note
)
540 (signal-semaphore sem
)))))))
541 ;; Create /parallel/ threads trying to acquire and then signal
542 ;; the semaphore. Try to asynchronously abort T2 just as T1 is
544 (destructuring-bind (t1 t2 t3
)
546 for sleep in
'(0.01
0.02 0.02)
547 collect
(make-thread #'critical
:arguments sleep
548 :name
(format nil
"T~A" i
)))
549 (signal-semaphore sem
)
552 (terminate-thread t2
))
553 (flet ((safe-join-thread (thread &key timeout
)
559 (error "Hang in (join-thread ~A) ?" thread
))))
560 (safe-join-thread t1
:timeout
10)
561 (safe-join-thread t3
:timeout
10)))))
562 (when (zerop (mod run
60))
568 (with-test (:name
(wait-on-semaphore :n
))
569 (let ((semaphore (make-semaphore :count
3)))
570 (assert (= 1 (wait-on-semaphore semaphore
:n
2)))
571 (assert (= 1 (semaphore-count semaphore
)))))
573 (with-test (:name
(try-semaphore semaphore-notification
)
574 :skipped-on
(not :sb-thread
))
575 (let* ((sem (make-semaphore))
576 (note (make-semaphore-notification)))
577 (assert (eql nil
(try-semaphore sem
1 note
)))
578 (assert (not (semaphore-notification-status note
)))
579 (signal-semaphore sem
)
580 (assert (eql 0 (try-semaphore sem
1 note
)))
581 (assert (semaphore-notification-status note
))))
583 (with-test (:name
(return-from-thread :normal-thread
)
584 :skipped-on
(not :sb-thread
))
585 (let ((thread (make-thread (lambda ()
586 (return-from-thread (values 1 2 3))
588 (assert (equal '(1 2 3) (multiple-value-list (join-thread thread
))))))
590 (with-test (:name
(return-from-thread :main-thread
))
591 (assert (main-thread-p))
592 (assert-error (return-from-thread t
) thread-error
))
594 (with-test (:name
(abort-thread :normal-thread
)
595 :skipped-on
(not :sb-thread
))
596 (let ((thread (make-thread (lambda ()
599 (assert (equal '(:aborted
! :abort
)
601 (join-thread thread
:default
:aborted
!))))))
603 (with-test (:name
(abort-thread :main-thread
))
604 (assert (main-thread-p))
605 (assert-error (abort-thread) thread-error
))
607 ;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
608 ;; before entering WITHOUT-INTERRUPTS. When a thread which was
609 ;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
610 ;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
611 ;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
612 ;; interrupting code thus made a recursive lock attempt.
614 ;; See (:TIMER :DISPATCH-THREAD :MAKE-THREAD :BUG-1180102) in
615 ;; timer.impure.lisp.
616 (with-test (:name
(make-thread :interrupt-with make-thread
:bug-1180102
)
617 :skipped-on
(not :sb-thread
)
624 (inner-threads (list nil
))
625 (parent *current-thread
*))
631 (lambda () (atomic-push (make-thread (lambda ()))
632 (car inner-threads
))))))
634 (push (make-thread (lambda ())) outer-threads
))
635 (mapc #'join-thread outer-threads
)
636 (mapc #'join-thread
(car inner-threads
)))