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 (let ((x (cons :count
0)))
25 (mapc #'sb-thread
:join-thread
27 collect
(sb-thread:make-thread
30 do
(atomic-update (cdr x
) #'1+)
32 (assert (equal x
'(:count .
1000000)))))
34 (with-test (:name mutex-owner
)
35 ;; Make sure basics are sane on unithreaded ports as well
36 (let ((mutex (make-mutex)))
38 (assert (eq *current-thread
* (mutex-value mutex
)))
39 (handler-bind ((warning #'error
))
40 (release-mutex mutex
))
41 (assert (not (mutex-value mutex
)))))
43 ;;; Terminating a thread that's waiting for the terminal.
46 (let ((thread (make-thread (lambda ()
47 (sb-thread::get-foreground
)))))
49 (assert (thread-alive-p thread
))
50 (terminate-thread thread
)
52 (assert (not (thread-alive-p thread
))))
54 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
56 (with-test (:name without-interrupts
+condition-wait
57 :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 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
75 (with-test (:name without-interrupts
+get-mutex
:skipped-on
'(not :sb-thread
))
76 (let* ((lock (make-mutex))
77 (bar (progn (get-mutex lock
) nil
))
78 (thread (make-thread (lambda ()
79 (sb-sys:without-interrupts
83 (assert (thread-alive-p thread
))
84 (terminate-thread thread
)
86 (assert (thread-alive-p thread
))
89 (assert (not (thread-alive-p thread
)))
90 (assert (eq :aborted
(join-thread thread
:default
:aborted
)))
93 (with-test (:name parallel-find-class
:skipped-on
'(not :sb-thread
))
95 (threads (loop repeat
10
96 collect
(make-thread (lambda ()
99 do
(find-class (gensym) nil
))
100 (serious-condition ()
102 (mapcar #'sb-thread
:join-thread threads
)
103 (assert (not oops
))))
105 (with-test (:name
:semaphore-multiple-waiters
:skipped-on
'(not :sb-thread
))
106 (let ((semaphore (make-semaphore :name
"test sem")))
107 (labels ((make-readers (n i
)
109 (loop for r from
0 below n
111 (sb-thread:make-thread
113 (let ((sem semaphore
))
115 (sb-thread:wait-on-semaphore sem
))))
118 (make-writers (n readers i
)
119 (let ((j (* readers i
)))
120 (multiple-value-bind (k rem
) (truncate j n
)
123 (loop for w from
0 below n
125 (sb-thread:make-thread
127 (let ((sem semaphore
))
129 (sb-thread:signal-semaphore sem
))))
135 (multiple-value-bind (readers x
) (make-readers r n
)
136 (assert (= (length readers
) r
))
137 (multiple-value-bind (writers y
) (make-writers w r n
)
138 (assert (= (length writers
) w
))
140 (mapc #'sb-thread
:join-thread writers
)
141 (mapc #'sb-thread
:join-thread readers
)
142 (assert (zerop (sb-thread:semaphore-count semaphore
)))
147 (sb-ext:with-timeout
10
158 ;;;; Printing waitqueues
160 (with-test (:name
:waitqueue-circle-print
:skipped-on
'(not :sb-thread
))
161 (let* ((*print-circle
* nil
)
162 (lock (sb-thread:make-mutex
))
163 (wq (sb-thread:make-waitqueue
)))
164 (sb-thread:with-recursive-lock
(lock)
165 (sb-thread:condition-notify wq
))
166 ;; Used to blow stack due to recursive structure.
167 (assert (princ-to-string wq
))))
169 ;;;; SYMBOL-VALUE-IN-THREAD
171 (with-test (:name symbol-value-in-thread
.1)
172 (let ((* (cons t t
)))
173 (assert (eq * (symbol-value-in-thread '* *current-thread
*)))
174 (setf (symbol-value-in-thread '* *current-thread
*) 123)
175 (assert (= 123 (symbol-value-in-thread '* *current-thread
*)))
178 (with-test (:name symbol-value-in-thread
.2 :skipped-on
'(not :sb-thread
))
179 (let* ((parent *current-thread
*)
180 (semaphore (make-semaphore))
181 (child (make-thread (lambda ()
182 (wait-on-semaphore semaphore
)
183 (let ((old (symbol-value-in-thread 'this-is-new parent
)))
184 (setf (symbol-value-in-thread 'this-is-new parent
) :from-child
)
186 (progv '(this-is-new) '(42)
187 (signal-semaphore semaphore
)
188 (assert (= 42 (join-thread child
)))
189 (assert (eq :from-child
(symbol-value 'this-is-new
))))))
191 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
192 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
193 ;;; interrupted malloc in one thread can apparently block a free in another.
194 (with-test (:name symbol-value-in-thread
.3
195 :skipped-on
'(not :sb-thread
))
196 (let* ((parent *current-thread
*)
197 (semaphore (make-semaphore))
199 (noise (make-thread (lambda ()
201 do
(setf * (make-array 1024))
202 ;; Busy-wait a bit so we don't TOTALLY flood the
203 ;; system with GCs: a GC occurring in the middle of
204 ;; S-V-I-T causes it to start over -- we want that
205 ;; to occur occasionally, but not _all_ the time.
206 (loop repeat
(random 128)
210 (when (zerop (mod i
200))
213 (let* ((mom-mark (cons t t
))
214 (kid-mark (cons t t
))
215 (child (make-thread (lambda ()
216 (wait-on-semaphore semaphore
)
217 (let ((old (symbol-value-in-thread 'this-is-new parent
)))
218 (setf (symbol-value-in-thread 'this-is-new parent
)
219 (make-array 24 :initial-element kid-mark
))
221 (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark
))
222 (signal-semaphore semaphore
)
223 (assert (eq mom-mark
(aref (join-thread child
) 0)))
224 (assert (eq kid-mark
(aref (symbol-value 'this-is-new
) 0))))))
226 (join-thread noise
)))
228 (with-test (:name symbol-value-in-thread
.4 :skipped-on
'(not :sb-thread
))
229 (let* ((parent *current-thread
*)
230 (semaphore (make-semaphore))
231 (child (make-thread (lambda ()
232 (wait-on-semaphore semaphore
)
233 (symbol-value-in-thread 'this-is-new parent nil
)))))
234 (signal-semaphore semaphore
)
235 (assert (equal '(nil nil
) (multiple-value-list (join-thread child
))))))
237 (with-test (:name symbol-value-in-thread
.5 :skipped-on
'(not :sb-thread
))
238 (let* ((parent *current-thread
*)
239 (semaphore (make-semaphore))
240 (child (make-thread (lambda ()
241 (wait-on-semaphore semaphore
)
243 (symbol-value-in-thread 'this-is-new parent
)
244 (symbol-value-in-thread-error (e)
245 (list (thread-error-thread e
)
247 (sb-thread::symbol-value-in-thread-error-info e
))))))))
248 (signal-semaphore semaphore
)
249 (assert (equal (list *current-thread
* 'this-is-new
(list :read
:unbound-in-thread
))
250 (join-thread child
)))))
252 (with-test (:name symbol-value-in-thread
.6 :skipped-on
'(not :sb-thread
))
253 (let* ((parent *current-thread
*)
254 (semaphore (make-semaphore))
256 (child (make-thread (lambda ()
257 (wait-on-semaphore semaphore
)
259 (setf (symbol-value-in-thread name parent
) t
)
260 (symbol-value-in-thread-error (e)
261 (list (thread-error-thread e
)
263 (sb-thread::symbol-value-in-thread-error-info e
))))))))
264 (signal-semaphore semaphore
)
265 (let ((res (join-thread child
))
266 (want (list *current-thread
* name
(list :write
:no-tls-value
))))
267 (unless (equal res want
)
268 (error "wanted ~S, got ~S" want res
)))))
270 (with-test (:name symbol-value-in-thread
.7 :skipped-on
'(not :sb-thread
))
271 (let ((child (make-thread (lambda ())))
272 (error-occurred nil
))
275 (symbol-value-in-thread 'this-is-new child
)
276 (symbol-value-in-thread-error (e)
277 (setf error-occurred t
)
278 (assert (eq child
(thread-error-thread e
)))
279 (assert (eq 'this-is-new
(cell-error-name e
)))
280 (assert (equal (list :read
:thread-dead
)
281 (sb-thread::symbol-value-in-thread-error-info e
)))))
282 (assert error-occurred
)))
284 (with-test (:name symbol-value-in-thread
.8 :skipped-on
'(not :sb-thread
))
285 (let ((child (make-thread (lambda ())))
286 (error-occurred nil
))
289 (setf (symbol-value-in-thread 'this-is-new child
) t
)
290 (symbol-value-in-thread-error (e)
291 (setf error-occurred t
)
292 (assert (eq child
(thread-error-thread e
)))
293 (assert (eq 'this-is-new
(cell-error-name e
)))
294 (assert (equal (list :write
:thread-dead
)
295 (sb-thread::symbol-value-in-thread-error-info e
)))))
296 (assert error-occurred
)))
298 (with-test (:name deadlock-detection
.1 :skipped-on
'(not :sb-thread
))
301 do
(flet ((test (ma mb sa sb
)
304 (sb-thread:with-mutex
(ma)
305 (sb-thread:signal-semaphore sa
)
306 (sb-thread:wait-on-semaphore sb
)
307 (sb-thread:with-mutex
(mb)
309 (sb-thread:thread-deadlock
(e)
312 (let* ((m1 (sb-thread:make-mutex
:name
"M1"))
313 (m2 (sb-thread:make-mutex
:name
"M2"))
314 (s1 (sb-thread:make-semaphore
:name
"S1"))
315 (s2 (sb-thread:make-semaphore
:name
"S2"))
316 (t1 (sb-thread:make-thread
(test m1 m2 s1 s2
) :name
"T1"))
317 (t2 (sb-thread:make-thread
(test m2 m1 s2 s1
) :name
"T2")))
318 ;; One will deadlock, and the other will then complete normally.
319 (let ((res (list (sb-thread:join-thread t1
)
320 (sb-thread:join-thread t2
))))
321 (assert (or (equal '(:deadlock
:ok
) res
)
322 (equal '(:ok
:deadlock
) res
))))))))
324 (with-test (:name deadlock-detection
.2 :skipped-on
'(not :sb-thread
))
325 (let* ((m1 (sb-thread:make-mutex
:name
"M1"))
326 (m2 (sb-thread:make-mutex
:name
"M2"))
327 (s1 (sb-thread:make-semaphore
:name
"S1"))
328 (s2 (sb-thread:make-semaphore
:name
"S2"))
329 (t1 (sb-thread:make-thread
331 (sb-thread:with-mutex
(m1)
332 (sb-thread:signal-semaphore s1
)
333 (sb-thread:wait-on-semaphore s2
)
334 (sb-thread:with-mutex
(m2)
339 (handler-bind ((sb-thread:thread-deadlock
342 ;; Make sure we can print the condition
344 (let ((*print-circle
* nil
))
345 (setf err
(princ-to-string e
)))
349 (assert (eq :ok
(sb-thread:with-mutex
(m2)
351 (sb-thread:signal-semaphore s2
)
352 (sb-thread:wait-on-semaphore s1
)
354 (sb-thread:with-mutex
(m1)
356 (assert (stringp err
)))
357 (assert (eq :ok
(sb-thread:join-thread t1
)))))
359 (with-test (:name deadlock-detection
.3 :skipped-on
'(not :sb-thread
))
360 (let* ((m1 (sb-thread:make-mutex
:name
"M1"))
361 (m2 (sb-thread:make-mutex
:name
"M2"))
362 (s1 (sb-thread:make-semaphore
:name
"S1"))
363 (s2 (sb-thread:make-semaphore
:name
"S2"))
364 (t1 (sb-thread:make-thread
366 (sb-thread:with-mutex
(m1)
367 (sb-thread:signal-semaphore s1
)
368 (sb-thread:wait-on-semaphore s2
)
369 (sb-thread:with-mutex
(m2)
372 ;; Currently we don't consider it a deadlock
373 ;; if there is a timeout in the chain.
374 (assert (eq :deadline
376 (sb-thread:with-mutex
(m2)
377 (sb-thread:signal-semaphore s2
)
378 (sb-thread:wait-on-semaphore s1
)
380 (sb-sys:with-deadline
(:seconds
0.1)
381 (sb-thread:with-mutex
(m1)
383 (sb-sys:deadline-timeout
()
385 (sb-thread:thread-deadlock
()
387 (assert (eq :ok
(join-thread t1
)))))
390 (with-test (:name
:pass-arguments-to-thread
)
391 (assert (= 3 (join-thread (make-thread #'+ :arguments
'(1 2))))))
394 (with-test (:name
:pass-atom-to-thread
)
395 (assert (= 1/2 (join-thread (make-thread #'/ :arguments
2)))))
398 (with-test (:name
:pass-nil-to-thread
)
399 (assert (= 1 (join-thread (make-thread #'* :arguments
'())))))
402 (with-test (:name
:pass-nothing-to-thread
)
403 (assert (= 1 (join-thread (make-thread #'*)))))
406 (with-test (:name
:pass-improper-list-to-thread
)
407 (multiple-value-bind (value error
)
408 (ignore-errors (make-thread #'+ :arguments
'(1 .
1)))
411 (assert (and (null value
)
414 (with-test (:name
(:wait-for
:basics
))
415 (assert (not (sb-ext:wait-for nil
:timeout
0.1)))
416 (assert (eql 42 (sb-ext:wait-for
42)))
418 (assert (eql 100 (sb-ext:wait-for
(when (= 100 (incf n
))
421 (with-test (:name
(:wait-for
:deadline
))
423 (sb-sys:with-deadline
(:seconds
10)
424 (assert (not (sb-ext:wait-for nil
:timeout
0.1)))
426 (assert (eq :deadline
428 (sb-sys:with-deadline
(:seconds
0.1)
429 (sb-ext:wait-for nil
:timeout
10)
431 (sb-sys:deadline-timeout
() :deadline
)))))
433 (with-test (:name
(:condition-wait
:timeout
:one-thread
))
434 (let ((mutex (make-mutex))
435 (waitqueue (make-waitqueue)))
436 (assert (not (with-mutex (mutex)
437 (condition-wait waitqueue mutex
:timeout
0.01))))))
439 (with-test (:name
(:condition-wait
:timeout
:many-threads
)
440 :skipped-on
'(not :sb-thread
))
441 (let* ((mutex (make-mutex))
442 (waitqueue (make-waitqueue))
443 (sem (make-semaphore))
449 (wait-on-semaphore sem
)
453 do
(or (condition-wait waitqueue mutex
:timeout
0.01)
454 (return-from thread nil
)))
455 (assert (eq t
(pop data
)))
458 do
(with-mutex (mutex)
460 (condition-notify waitqueue
)))
461 (signal-semaphore sem
100)
462 (let ((ok (count-if #'join-thread workers
)))
464 (error "Wanted 50, got ~S" ok
)))))
466 (with-test (:name
(:wait-on-semaphore
:timeout
:one-thread
))
467 (let ((sem (make-semaphore))
469 (signal-semaphore sem
10)
471 do
(when (wait-on-semaphore sem
:timeout
0.001)
475 (with-test (:name
(:wait-on-semaphore
:timeout
:many-threads
)
476 :skipped-on
'(not :sb-thread
))
477 (let* ((sem (make-semaphore))
480 (signal-semaphore sem
10)
484 (sleep (random 0.02))
485 (wait-on-semaphore sem
:timeout
0.5)))))))
487 do
(signal-semaphore sem
2))
488 (let ((ok (count-if #'join-thread threads
)))
490 (error "Wanted 20, got ~S" ok
)))))
492 (with-test (:name
(:join-thread
:timeout
)
493 :skipped-on
'(not :sb-thread
))
496 (join-thread (make-thread (lambda () (sleep 10))) :timeout
0.01)
497 (join-thread-error ()
499 (let ((cookie (cons t t
)))
501 (join-thread (make-thread (lambda () (sleep 10)))
505 (with-test (:name
(:semaphore-notification
:wait-on-semaphore
)
506 :skipped-on
'(not :sb-thread
))
507 (let ((sem (make-semaphore))
511 (let ((note (make-semaphore-notification)))
512 (sb-sys:without-interrupts
515 (sb-sys:with-local-interrupts
516 (wait-on-semaphore sem
:notification note
)
517 (sleep (random 0.1)))
519 ;; Re-increment on exit if we decremented it.
520 (when (semaphore-notification-status note
)
521 (signal-semaphore sem
))
522 ;; KLUDGE: Prevent interrupts after this point from
523 ;; unwinding us, so that we can reason about the counts.
525 (sb-thread::block-deferrable-signals
))))))
526 (let* ((threads (loop for i from
1 upto
100
527 collect
(make-thread #'critical
:name
(format nil
"T~A" i
))))
530 (interruptor (make-thread (lambda ()
533 (dolist (thread threads
)
538 (terminate-thread thread
)))
541 (setf x
(not x
))))))))
542 (signal-semaphore sem
)
544 (join-thread interruptor
)
545 (mapc #'join-thread safe
)
546 (let ((k (count-if (lambda (th)
547 (join-thread th
:default nil
))
549 (assert (= n
(+ k
(length safe
))))
552 (with-test (:name
(:semaphore-notification
:try-sempahore
)
553 :skipped-on
'(not :sb-thread
))
554 (let* ((sem (make-semaphore))
555 (note (make-semaphore-notification)))
556 (try-semaphore sem
1 note
)
557 (assert (not (semaphore-notification-status note
)))
558 (signal-semaphore sem
)
559 (try-semaphore sem
1 note
)
560 (assert (semaphore-notification-status note
))))
562 (with-test (:name
(:return-from-thread
:normal-thread
))
563 (let* ((thread (make-thread (lambda ()
564 (return-from-thread (values 1 2 3))
566 (values (multiple-value-list (join-thread thread
))))
567 (unless (equal (list 1 2 3) values
)
568 (error "got ~S, wanted (1 2 3)" values
))))
570 (with-test (:name
(:return-from-thread
:main-thread
))
571 (assert (main-thread-p))
574 (return-from-thread t
)
578 (with-test (:name
(:abort-thread
:normal-thread
))
579 (let ((thread (make-thread (lambda ()
582 (assert (eq :aborted
! (join-thread thread
:default
:aborted
!)))))
584 (with-test (:name
(:abort-thread
:main-thread
))
585 (assert (main-thread-p))