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.
16 (defpackage :thread-test
17 (:use
:cl
:sb-thread
:sb-ext
))
19 (in-package :thread-test
)
21 (use-package :test-util
)
23 (with-test (:name atomic-update
24 :skipped-on
'(not :sb-thread
))
25 (let ((x (cons :count
0))
26 (nthreads (ecase sb-vm
:n-word-bits
(32 100) (64 1000))))
27 (mapc #'sb-thread
:join-thread
29 collect
(sb-thread:make-thread
32 do
(atomic-update (cdr x
) #'1+)
34 (assert (equal x
`(:count
,@(* 1000 nthreads
))))))
36 (with-test (:name mutex-owner
)
37 ;; Make sure basics are sane on unithreaded ports as well
38 (let ((mutex (make-mutex)))
40 (assert (eq *current-thread
* (mutex-value mutex
)))
41 (handler-bind ((warning #'error
))
42 (release-mutex mutex
))
43 (assert (not (mutex-value mutex
)))))
45 ;;; Terminating a thread that's waiting for the terminal.
48 (let ((thread (make-thread (lambda ()
49 (sb-thread::get-foreground
)))))
51 (assert (thread-alive-p thread
))
52 (terminate-thread thread
)
54 (assert (not (thread-alive-p thread
))))
56 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
58 (with-test (:name without-interrupts
+condition-wait
59 :skipped-on
'(not :sb-thread
)
60 :fails-on
'(and :win32
:sb-futex
))
61 (let* ((lock (make-mutex))
62 (queue (make-waitqueue))
63 (thread (make-thread (lambda ()
64 (sb-sys:without-interrupts
66 (condition-wait queue lock
)))))))
68 (assert (thread-alive-p thread
))
69 (terminate-thread thread
)
71 (assert (thread-alive-p thread
))
72 (condition-notify queue
)
74 (assert (not (thread-alive-p thread
)))))
76 ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
78 (with-test (:name without-interrupts
+grab-mutex
:skipped-on
'(not :sb-thread
))
79 (let* ((lock (make-mutex))
80 (bar (progn (grab-mutex lock
) nil
))
81 (thread (make-thread (lambda ()
82 (sb-sys:without-interrupts
86 (assert (thread-alive-p thread
))
87 (terminate-thread thread
)
89 (assert (thread-alive-p thread
))
92 (assert (not (thread-alive-p thread
)))
93 (assert (eq :aborted
(join-thread thread
:default
:aborted
)))
96 (with-test (:name parallel-find-class
:skipped-on
'(not :sb-thread
))
98 (threads (loop repeat
10
99 collect
(make-thread (lambda ()
102 do
(find-class (gensym) nil
))
103 (serious-condition ()
105 (mapcar #'sb-thread
:join-thread threads
)
106 (assert (not oops
))))
108 (with-test (:name
:semaphore-multiple-waiters
:skipped-on
'(not :sb-thread
))
109 (let ((semaphore (make-semaphore :name
"test sem")))
110 (labels ((make-readers (n i
)
112 (loop for r from
0 below n
114 (sb-thread:make-thread
116 (let ((sem semaphore
))
118 (sb-thread:wait-on-semaphore sem
))))
121 (make-writers (n readers i
)
122 (let ((j (* readers i
)))
123 (multiple-value-bind (k rem
) (truncate j n
)
126 (loop for w from
0 below n
128 (sb-thread:make-thread
130 (let ((sem semaphore
))
132 (sb-thread:signal-semaphore sem
))))
138 (multiple-value-bind (readers x
) (make-readers r n
)
139 (assert (= (length readers
) r
))
140 (multiple-value-bind (writers y
) (make-writers w r n
)
141 (assert (= (length writers
) w
))
143 (mapc #'sb-thread
:join-thread writers
)
144 (mapc #'sb-thread
:join-thread readers
)
145 (assert (zerop (sb-thread:semaphore-count semaphore
)))
150 (sb-ext:with-timeout
10
161 ;;;; Printing waitqueues
163 (with-test (:name
:waitqueue-circle-print
:skipped-on
'(not :sb-thread
))
164 (let* ((*print-circle
* nil
)
165 (lock (sb-thread:make-mutex
))
166 (wq (sb-thread:make-waitqueue
)))
167 (sb-thread:with-recursive-lock
(lock)
168 (sb-thread:condition-notify wq
))
169 ;; Used to blow stack due to recursive structure.
170 (assert (princ-to-string wq
))))
172 ;;;; SYMBOL-VALUE-IN-THREAD
174 (with-test (:name symbol-value-in-thread
.1)
175 (let ((* (cons t t
)))
176 (assert (eq * (symbol-value-in-thread '* *current-thread
*)))
177 (setf (symbol-value-in-thread '* *current-thread
*) 123)
178 (assert (= 123 (symbol-value-in-thread '* *current-thread
*)))
181 (with-test (:name symbol-value-in-thread
.2 :skipped-on
'(not :sb-thread
))
182 (let* ((parent *current-thread
*)
183 (semaphore (make-semaphore))
184 (child (make-thread (lambda ()
185 (wait-on-semaphore semaphore
)
186 (let ((old (symbol-value-in-thread 'this-is-new parent
)))
187 (setf (symbol-value-in-thread 'this-is-new parent
) :from-child
)
189 (progv '(this-is-new) '(42)
190 (signal-semaphore semaphore
)
191 (assert (= 42 (join-thread child
)))
192 (assert (eq :from-child
(symbol-value 'this-is-new
))))))
194 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
195 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
196 ;;; interrupted malloc in one thread can apparently block a free in another.
197 (with-test (:name symbol-value-in-thread
.3
198 :skipped-on
'(not :sb-thread
))
199 (let* ((parent *current-thread
*)
200 (semaphore (make-semaphore))
202 (noise (make-thread (lambda ()
204 do
(setf * (make-array 1024))
205 ;; Busy-wait a bit so we don't TOTALLY flood the
206 ;; system with GCs: a GC occurring in the middle of
207 ;; S-V-I-T causes it to start over -- we want that
208 ;; to occur occasionally, but not _all_ the time.
209 (loop repeat
(random 128)
212 (dotimes (i #+win32
2000 #-win32
15000)
213 (when (zerop (mod i
200))
216 (let* ((mom-mark (cons t t
))
217 (kid-mark (cons t t
))
218 (child (make-thread (lambda ()
219 (wait-on-semaphore semaphore
)
220 (let ((old (symbol-value-in-thread 'this-is-new parent
)))
221 (setf (symbol-value-in-thread 'this-is-new parent
)
222 (make-array 24 :initial-element kid-mark
))
224 (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark
))
225 (signal-semaphore semaphore
)
226 (assert (eq mom-mark
(aref (join-thread child
) 0)))
227 (assert (eq kid-mark
(aref (symbol-value 'this-is-new
) 0))))))
229 (join-thread noise
)))
231 (with-test (:name symbol-value-in-thread
.4 :skipped-on
'(not :sb-thread
))
232 (let* ((parent *current-thread
*)
233 (semaphore (make-semaphore))
234 (child (make-thread (lambda ()
235 (wait-on-semaphore semaphore
)
236 (symbol-value-in-thread 'this-is-new parent nil
)))))
237 (signal-semaphore semaphore
)
238 (assert (equal '(nil nil
) (multiple-value-list (join-thread child
))))))
240 (with-test (:name symbol-value-in-thread
.5 :skipped-on
'(not :sb-thread
))
241 (let* ((parent *current-thread
*)
242 (semaphore (make-semaphore))
243 (child (make-thread (lambda ()
244 (wait-on-semaphore semaphore
)
246 (symbol-value-in-thread 'this-is-new parent
)
247 (symbol-value-in-thread-error (e)
248 (list (thread-error-thread e
)
250 (sb-thread::symbol-value-in-thread-error-info e
))))))))
251 (signal-semaphore semaphore
)
252 (assert (equal (list *current-thread
* 'this-is-new
(list :read
:unbound-in-thread
))
253 (join-thread child
)))))
255 (with-test (:name symbol-value-in-thread
.6 :skipped-on
'(not :sb-thread
))
256 (let* ((parent *current-thread
*)
257 (semaphore (make-semaphore))
259 (child (make-thread (lambda ()
260 (wait-on-semaphore semaphore
)
262 (setf (symbol-value-in-thread name parent
) t
)
263 (symbol-value-in-thread-error (e)
264 (list (thread-error-thread e
)
266 (sb-thread::symbol-value-in-thread-error-info e
))))))))
267 (signal-semaphore semaphore
)
268 (let ((res (join-thread child
))
269 (want (list *current-thread
* name
(list :write
:no-tls-value
))))
270 (unless (equal res want
)
271 (error "wanted ~S, got ~S" want res
)))))
273 (with-test (:name symbol-value-in-thread
.7 :skipped-on
'(not :sb-thread
))
274 (let ((child (make-thread (lambda ())))
275 (error-occurred nil
))
278 (symbol-value-in-thread 'this-is-new child
)
279 (symbol-value-in-thread-error (e)
280 (setf error-occurred t
)
281 (assert (eq child
(thread-error-thread e
)))
282 (assert (eq 'this-is-new
(cell-error-name e
)))
283 (assert (equal (list :read
:thread-dead
)
284 (sb-thread::symbol-value-in-thread-error-info e
)))))
285 (assert error-occurred
)))
287 (with-test (:name symbol-value-in-thread
.8 :skipped-on
'(not :sb-thread
))
288 (let ((child (make-thread (lambda ())))
289 (error-occurred nil
))
292 (setf (symbol-value-in-thread 'this-is-new child
) t
)
293 (symbol-value-in-thread-error (e)
294 (setf error-occurred t
)
295 (assert (eq child
(thread-error-thread e
)))
296 (assert (eq 'this-is-new
(cell-error-name e
)))
297 (assert (equal (list :write
:thread-dead
)
298 (sb-thread::symbol-value-in-thread-error-info e
)))))
299 (assert error-occurred
)))
301 (with-test (:name deadlock-detection
.1 :skipped-on
'(not :sb-thread
))
304 do
(flet ((test (ma mb sa sb
)
307 (sb-thread:with-mutex
(ma)
308 (sb-thread:signal-semaphore sa
)
309 (sb-thread:wait-on-semaphore sb
)
310 (sb-thread:with-mutex
(mb)
312 (sb-thread:thread-deadlock
(e)
315 (let* ((m1 (sb-thread:make-mutex
:name
"M1"))
316 (m2 (sb-thread:make-mutex
:name
"M2"))
317 (s1 (sb-thread:make-semaphore
:name
"S1"))
318 (s2 (sb-thread:make-semaphore
:name
"S2"))
319 (t1 (sb-thread:make-thread
(test m1 m2 s1 s2
) :name
"T1"))
320 (t2 (sb-thread:make-thread
(test m2 m1 s2 s1
) :name
"T2")))
321 ;; One will deadlock, and the other will then complete normally.
322 (let ((res (list (sb-thread:join-thread t1
)
323 (sb-thread:join-thread t2
))))
324 (assert (or (equal '(:deadlock
:ok
) res
)
325 (equal '(:ok
:deadlock
) res
))))))))
327 (with-test (:name deadlock-detection
.2 :skipped-on
'(not :sb-thread
))
328 (let* ((m1 (sb-thread:make-mutex
:name
"M1"))
329 (m2 (sb-thread:make-mutex
:name
"M2"))
330 (s1 (sb-thread:make-semaphore
:name
"S1"))
331 (s2 (sb-thread:make-semaphore
:name
"S2"))
332 (t1 (sb-thread:make-thread
334 (sb-thread:with-mutex
(m1)
335 (sb-thread:signal-semaphore s1
)
336 (sb-thread:wait-on-semaphore s2
)
337 (sb-thread:with-mutex
(m2)
342 (handler-bind ((sb-thread:thread-deadlock
345 ;; Make sure we can print the condition
347 (let ((*print-circle
* nil
))
348 (setf err
(princ-to-string e
)))
352 (assert (eq :ok
(sb-thread:with-mutex
(m2)
354 (sb-thread:signal-semaphore s2
)
355 (sb-thread:wait-on-semaphore s1
)
357 (sb-thread:with-mutex
(m1)
359 (assert (stringp err
)))
360 (assert (eq :ok
(sb-thread:join-thread t1
)))))
362 (with-test (:name deadlock-detection
.3 :skipped-on
'(not :sb-thread
))
363 (let* ((m1 (sb-thread:make-mutex
:name
"M1"))
364 (m2 (sb-thread:make-mutex
:name
"M2"))
365 (s1 (sb-thread:make-semaphore
:name
"S1"))
366 (s2 (sb-thread:make-semaphore
:name
"S2"))
367 (t1 (sb-thread:make-thread
369 (sb-thread:with-mutex
(m1)
370 (sb-thread:signal-semaphore s1
)
371 (sb-thread:wait-on-semaphore s2
)
372 (sb-thread:with-mutex
(m2)
375 ;; Currently we don't consider it a deadlock
376 ;; if there is a timeout in the chain.
377 (assert (eq :deadline
379 (sb-thread:with-mutex
(m2)
380 (sb-thread:signal-semaphore s2
)
381 (sb-thread:wait-on-semaphore s1
)
383 (sb-sys:with-deadline
(:seconds
0.1)
384 (sb-thread:with-mutex
(m1)
386 (sb-sys:deadline-timeout
()
388 (sb-thread:thread-deadlock
()
390 (assert (eq :ok
(join-thread t1
)))))
393 (with-test (:name
:pass-arguments-to-thread
)
394 (assert (= 3 (join-thread (make-thread #'+ :arguments
'(1 2))))))
397 (with-test (:name
:pass-atom-to-thread
)
398 (assert (= 1/2 (join-thread (make-thread #'/ :arguments
2)))))
401 (with-test (:name
:pass-nil-to-thread
)
402 (assert (= 1 (join-thread (make-thread #'* :arguments
'())))))
405 (with-test (:name
:pass-nothing-to-thread
)
406 (assert (= 1 (join-thread (make-thread #'*)))))
409 (with-test (:name
:pass-improper-list-to-thread
)
410 (multiple-value-bind (value error
)
411 (ignore-errors (make-thread #'+ :arguments
'(1 .
1)))
414 (assert (and (null value
)
417 (with-test (:name
(:wait-for
:basics
))
418 (assert (not (sb-ext:wait-for nil
:timeout
0.1)))
419 (assert (eql 42 (sb-ext:wait-for
42)))
421 (assert (eql 100 (sb-ext:wait-for
(when (= 100 (incf n
))
424 (with-test (:name
(:wait-for
:deadline
))
426 (sb-sys:with-deadline
(:seconds
10)
427 (assert (not (sb-ext:wait-for nil
:timeout
0.1)))
429 (assert (eq :deadline
431 (sb-sys:with-deadline
(:seconds
0.1)
432 (sb-ext:wait-for nil
:timeout
10)
434 (sb-sys:deadline-timeout
() :deadline
)))))
436 (with-test (:name
(:condition-wait
:timeout
:one-thread
))
437 (let ((mutex (make-mutex))
438 (waitqueue (make-waitqueue)))
439 (assert (not (with-mutex (mutex)
440 (condition-wait waitqueue mutex
:timeout
0.01))))))
442 (with-test (:name
(:condition-wait
:timeout
:many-threads
)
443 :skipped-on
'(not :sb-thread
))
444 (let* ((mutex (make-mutex))
445 (waitqueue (make-waitqueue))
446 (sem (make-semaphore))
452 (wait-on-semaphore sem
)
456 do
(or (condition-wait waitqueue mutex
:timeout
0.01)
457 (return-from thread nil
)))
458 (assert (eq t
(pop data
)))
461 do
(with-mutex (mutex)
463 (condition-notify waitqueue
)))
464 (signal-semaphore sem
100)
465 (let ((ok (count-if #'join-thread workers
)))
467 (error "Wanted 50, got ~S" ok
)))))
469 (with-test (:name
(:wait-on-semaphore
:timeout
:one-thread
))
470 (let ((sem (make-semaphore))
472 (signal-semaphore sem
10)
474 do
(when (wait-on-semaphore sem
:timeout
0.001)
478 (with-test (:name
(:wait-on-semaphore
:timeout
:many-threads
)
479 :skipped-on
'(not :sb-thread
))
480 (let* ((sem (make-semaphore))
483 (signal-semaphore sem
10)
487 (sleep (random 0.02))
488 (wait-on-semaphore sem
:timeout
0.5)))))))
490 do
(signal-semaphore sem
2))
491 (let ((ok (count-if #'join-thread threads
)))
493 (error "Wanted 20, got ~S" ok
)))))
495 (with-test (:name
(:join-thread
:timeout
)
496 :skipped-on
'(not :sb-thread
))
499 (join-thread (make-join-thread (lambda () (sleep 10))) :timeout
0.01)
500 (join-thread-error ()
502 (let ((cookie (cons t t
)))
504 (join-thread (make-join-thread (lambda () (sleep 10)))
508 (with-test (:name
(:semaphore-notification
:wait-on-semaphore
)
509 :skipped-on
'(not :sb-thread
))
510 (let ((sem (make-semaphore))
514 (let ((note (make-semaphore-notification)))
515 (sb-sys:without-interrupts
518 (sb-sys:with-local-interrupts
519 (wait-on-semaphore sem
:notification note
)
520 (sleep (random 0.1)))
522 ;; Re-increment on exit if we decremented it.
523 (when (semaphore-notification-status note
)
524 (signal-semaphore sem
))
525 ;; KLUDGE: Prevent interrupts after this point from
526 ;; unwinding us, so that we can reason about the counts.
528 (sb-thread::block-deferrable-signals
))))))
529 (let* ((threads (loop for i from
1 upto
100
530 collect
(make-join-thread #'critical
:name
(format nil
"T~A" i
))))
533 (interruptor (make-thread (lambda ()
536 (dolist (thread threads
)
541 (terminate-thread thread
)))
544 (setf x
(not x
))))))))
545 (signal-semaphore sem
)
547 (join-thread interruptor
)
548 (mapc #'join-thread safe
)
549 (let ((k (count-if (lambda (th)
550 (join-thread th
:default nil
))
552 (assert (= n
(+ k
(length safe
))))
555 (with-test (:name
(:semaphore-notification
:try-sempahore
)
556 :skipped-on
'(not :sb-thread
))
557 (let* ((sem (make-semaphore))
558 (note (make-semaphore-notification)))
559 (try-semaphore sem
1 note
)
560 (assert (not (semaphore-notification-status note
)))
561 (signal-semaphore sem
)
562 (try-semaphore sem
1 note
)
563 (assert (semaphore-notification-status note
))))
565 (with-test (:name
(:return-from-thread
:normal-thread
)
566 :skipped-on
'(not :sb-thread
))
567 (let* ((thread (make-thread (lambda ()
568 (return-from-thread (values 1 2 3))
570 (values (multiple-value-list (join-thread thread
))))
571 (unless (equal (list 1 2 3) values
)
572 (error "got ~S, wanted (1 2 3)" values
))))
574 (with-test (:name
(:return-from-thread
:main-thread
))
575 (assert (main-thread-p))
578 (return-from-thread t
)
582 (with-test (:name
(:abort-thread
:normal-thread
)
583 :skipped-on
'(not :sb-thread
))
584 (let ((thread (make-thread (lambda ()
587 (assert (eq :aborted
! (join-thread thread
:default
:aborted
!)))))
589 (with-test (:name
(:abort-thread
:main-thread
))
590 (assert (main-thread-p))
597 ;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
598 ;; before entering WITHOUT-INTERRUPTS. When a thread which was
599 ;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
600 ;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
601 ;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
602 ;; interrupting code thus made a recursive lock attempt.
604 ;; See (:TIMER :DISPATCH-THREAD :MAKE-THREAD :BUG-1180102) in
605 ;; timer.impure.lisp.
606 (with-test (:name
(make-thread :interrupt-with make-thread
:bug-1180102
)
607 :skipped-on
'(not :sb-thread
))
610 (parent *current-thread
*))
616 (lambda () (push (make-thread (lambda ())) threads
)))))
618 (push (make-thread (lambda ())) threads
))
619 (mapc #'join-thread threads
))))