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 (use-package '("SB-EXT" "SB-THREAD"))
16 (with-test (:name
:dont-print-array
17 :skipped-on
(not :sb-thread
))
18 (let ((thr (sb-thread:make-thread
(lambda () (make-array 100)))))
19 (sb-thread:join-thread thr
)
20 (assert (search "#<(SIMPLE-VECTOR" (write-to-string thr
)))))
22 (with-test (:name atomic-update
23 :skipped-on
(not :sb-thread
))
24 (let ((x (cons :count
0))
25 (nthreads (ecase sb-vm
:n-word-bits
(32 100) (64 1000))))
28 collect
(make-thread (lambda ()
30 do
(atomic-update (cdr x
) #'1+)
32 (assert (equal x
`(:count
,@(* 1000 nthreads
))))))
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-owner mutex
)))
39 (handler-bind ((warning #'error
))
40 (release-mutex mutex
))
41 (assert (not (mutex-owner mutex
)))))
43 ;;; Terminating a thread that's waiting for the terminal.
45 (with-test (:name
(:terminate-thread
:get-foreground
)
46 :skipped-on
(not :sb-thread
)
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
57 ;;; BUT: Such a claim is without much merit. Even if a wait is not "interrupted",
58 ;;; the very definition of spurious wakeup is that return from the wait happens
59 ;;; for ANY reason - users of condition variables must ALWAYS anticipate needing
60 ;;; to loop over a condition-wait.
62 (with-test (:name
:without-interrupts
+condition-wait
63 :skipped-on
(not :sb-thread
)
65 (let* ((lock (make-mutex))
66 (queue (make-waitqueue))
68 (thread (make-thread (lambda ()
69 (sb-sys:without-interrupts
72 (condition-wait queue lock
)
73 (if actually-wakeup
(return)))))))))
75 (assert (thread-alive-p thread
))
76 ;; this is the supposed "interrupt that doesn't interrupt",
77 ;; but it _is_ permitted to wake the condition variable.
78 (terminate-thread thread
)
80 (assert (thread-alive-p thread
))
81 (setq actually-wakeup t
)
82 (sb-thread:barrier
(:write
))
83 (condition-notify queue
)
85 (assert (not (thread-alive-p thread
)))))
87 ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
89 (with-test (:name
:without-interrupts
+grab-mutex
90 :skipped-on
(not :sb-thread
)
92 (let* ((lock (make-mutex))
93 (bar (progn (grab-mutex lock
) nil
))
94 (thread (make-thread (lambda ()
95 (sb-sys:without-interrupts
99 (assert (thread-alive-p thread
))
100 (terminate-thread thread
)
102 (assert (thread-alive-p thread
))
105 (assert (not (thread-alive-p thread
)))
106 (assert (eq :aborted
(join-thread thread
:default
:aborted
)))
109 (with-test (:name
:parallel-find-class
:skipped-on
(not :sb-thread
))
111 (threads (loop repeat
10
112 collect
(make-thread (lambda ()
115 do
(find-class (gensym) nil
))
116 (serious-condition ()
118 (mapc #'join-thread threads
)
119 (assert (not oops
))))
121 (with-test (:name
:semaphore-multiple-waiters
:skipped-on
(or (not :sb-thread
) :gc-stress
))
122 (let ((semaphore (make-semaphore :name
"test sem")))
123 (labels ((make-readers (n i
)
125 (loop for r from
0 below n
129 (sb-ext:with-timeout
10
130 (let ((sem semaphore
))
132 (wait-on-semaphore sem
)))))
135 (make-writers (n readers i
)
136 (let ((j (* readers i
)))
137 (multiple-value-bind (k rem
) (truncate j n
)
140 (loop for w from
0 below n
144 (sb-ext:with-timeout
10
145 (let ((sem semaphore
))
147 (signal-semaphore sem
)))))
153 (multiple-value-bind (readers x
) (make-readers r n
)
154 (assert (= (length readers
) r
))
155 (multiple-value-bind (writers y
) (make-writers w r n
)
156 (assert (= (length writers
) w
))
158 (mapc #'join-thread writers
)
159 (mapc #'join-thread readers
)
160 (assert (zerop (semaphore-count semaphore
)))
164 (sb-ext:with-timeout
20
173 ;;;; Printing waitqueues
175 (with-test (:name
:waitqueue-circle-print
:skipped-on
(not :sb-thread
))
176 (let* ((*print-circle
* nil
)
178 (wq (make-waitqueue)))
179 (with-recursive-lock (lock)
180 (condition-notify wq
))
181 ;; Used to blow stack due to recursive structure.
182 (assert (princ-to-string wq
))))
184 ;;;; SYMBOL-VALUE-IN-THREAD
186 (with-test (:name
:symbol-value-in-thread
.1)
187 (let ((* (cons t t
)))
188 (assert (eq * (symbol-value-in-thread '* *current-thread
*)))
189 (setf (symbol-value-in-thread '* *current-thread
*) 123)
190 (assert (= 123 (symbol-value-in-thread '* *current-thread
*)))
193 (with-test (:name
:symbol-value-in-thread
.2 :skipped-on
(not :sb-thread
))
194 (let* ((parent *current-thread
*)
195 (semaphore (make-semaphore))
196 (child (make-thread (lambda ()
197 (wait-on-semaphore semaphore
)
198 (let ((old (symbol-value-in-thread 'this-is-new parent
)))
199 (setf (symbol-value-in-thread 'this-is-new parent
) :from-child
)
201 (progv '(this-is-new) '(42)
202 (signal-semaphore semaphore
)
203 (assert (= 42 (join-thread child
)))
204 (assert (eq :from-child
(symbol-value 'this-is-new
))))))
206 (with-test (:name
:symbol-value-in-thread
.3
207 :skipped-on
(not :sb-thread
)
208 :broken-on
:sb-safepoint
)
209 (let* ((parent *current-thread
*)
210 (semaphore (make-semaphore))
212 (noise (make-thread (lambda ()
214 do
(setf * (make-array 1024))
215 ;; Busy-wait a bit so we don't TOTALLY flood the
217 (loop repeat
(random 128)
220 (let* ((mom-mark (cons t t
))
221 (kid-mark (cons t t
))
224 (if (wait-on-semaphore semaphore
:timeout
10)
225 (let ((old (symbol-value-in-thread 'this-is-new parent
)))
226 (setf (symbol-value-in-thread 'this-is-new parent
)
227 (make-array 24 :initial-element kid-mark
))
230 (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark
))
231 (signal-semaphore semaphore
)
232 (assert (eq mom-mark
(aref (join-thread child
:timeout
10) 0)))
233 (assert (eq kid-mark
(aref (symbol-value 'this-is-new
) 0))))))
235 (join-thread noise
)))
237 (with-test (:name
:symbol-value-in-thread
.4 :skipped-on
(not :sb-thread
))
238 (let* ((parent *current-thread
*)
239 (semaphore (make-semaphore))
240 (child (make-thread (lambda ()
241 (wait-on-semaphore semaphore
)
242 (symbol-value-in-thread 'this-is-new parent nil
)))))
243 (signal-semaphore semaphore
)
244 (assert (equal '(nil nil
) (multiple-value-list (join-thread child
))))))
246 (with-test (:name
:symbol-value-in-thread
.5 :skipped-on
(not :sb-thread
))
247 (let* ((parent *current-thread
*)
248 (semaphore (make-semaphore))
249 (child (make-thread (lambda ()
250 (wait-on-semaphore semaphore
)
252 (symbol-value-in-thread 'this-is-new parent
)
253 (symbol-value-in-thread-error (e)
254 (list (thread-error-thread e
)
256 (sb-thread::symbol-value-in-thread-error-info e
))))))))
257 (signal-semaphore semaphore
)
258 (assert (equal (list *current-thread
* 'this-is-new
(list :read
:no-tls-value
))
259 (join-thread child
)))))
261 (with-test (:name
:symbol-value-in-thread
.6 :skipped-on
(not :sb-thread
))
262 (let* ((parent *current-thread
*)
263 (semaphore (make-semaphore))
265 (child (make-thread (lambda ()
266 (wait-on-semaphore semaphore
)
268 (setf (symbol-value-in-thread name parent
) t
)
269 (symbol-value-in-thread-error (e)
270 (list (thread-error-thread e
)
272 (sb-thread::symbol-value-in-thread-error-info e
))))))))
273 (signal-semaphore semaphore
)
274 (let ((res (join-thread child
))
275 (want (list *current-thread
* name
(list :write
:no-tls-value
))))
276 (unless (equal res want
)
277 (error "wanted ~S, got ~S" want res
)))))
279 (with-test (:name
:symbol-value-in-thread
.7 :skipped-on
(not :sb-thread
))
280 (let ((child (make-thread (lambda ())))
281 (error-occurred nil
))
284 (symbol-value-in-thread 'this-is-new child
)
285 (symbol-value-in-thread-error (e)
286 (setf error-occurred t
)
287 (assert (eq child
(thread-error-thread e
)))
288 (assert (eq 'this-is-new
(cell-error-name e
)))
289 (assert (equal (list :read
:thread-dead
)
290 (sb-thread::symbol-value-in-thread-error-info e
)))))
291 (assert error-occurred
)))
293 (with-test (:name
:symbol-value-in-thread
.8 :skipped-on
(not :sb-thread
))
294 (let ((child (make-thread (lambda ())))
295 (error-occurred nil
))
298 (setf (symbol-value-in-thread 'this-is-new child
) t
)
299 (symbol-value-in-thread-error (e)
300 (setf error-occurred t
)
301 (assert (eq child
(thread-error-thread e
)))
302 (assert (eq 'this-is-new
(cell-error-name e
)))
303 (assert (equal (list :write
:thread-dead
)
304 (sb-thread::symbol-value-in-thread-error-info e
)))))
305 (assert error-occurred
)))
308 (with-test (:name
:pass-arguments-to-thread
)
309 (assert (= 3 (join-thread (make-thread #'+ :arguments
'(1 2))))))
312 (with-test (:name
:pass-atom-to-thread
)
313 (assert (= 1/2 (join-thread (make-thread #'/ :arguments
2)))))
316 (with-test (:name
:pass-nil-to-thread
)
317 (assert (= 1 (join-thread (make-thread #'* :arguments
'())))))
320 (with-test (:name
:pass-nothing-to-thread
)
321 (assert (= 1 (join-thread (make-thread #'*)))))
324 (with-test (:name
:pass-improper-list-to-thread
)
325 (multiple-value-bind (value error
)
326 (ignore-errors (make-thread #'+ :arguments
'(1 .
1)))
329 (assert (and (null value
)
332 (with-test (:name
(:wait-for
:deadline
))
334 (sb-sys:with-deadline
(:seconds
10)
335 (assert (not (sb-ext:wait-for nil
:timeout
0.1)))
337 (assert (eq :deadline
339 (sb-sys:with-deadline
(:seconds
0.1)
340 (sb-ext:wait-for nil
:timeout
10)
342 (sb-sys:deadline-timeout
() :deadline
)))))
344 (with-test (:name
(:condition-wait
:timeout
:one-thread
)
345 :skipped-on
:gc-stress
)
346 (let ((mutex (make-mutex))
347 (waitqueue (make-waitqueue)))
348 (assert (not (with-mutex (mutex)
349 (condition-wait waitqueue mutex
:timeout
0.01))))))
351 (with-test (:name
(:condition-wait
:timeout
:many-threads
)
352 :skipped-on
(or (not :sb-thread
) :gc-stress
))
353 (let* ((mutex (make-mutex))
354 (waitqueue (make-waitqueue))
355 (sem (make-semaphore))
361 (wait-on-semaphore sem
)
365 do
(or (condition-wait waitqueue mutex
:timeout
0.01)
366 (return-from thread nil
)))
367 (assert (eq t
(pop data
)))
370 do
(with-mutex (mutex)
372 (condition-notify waitqueue
)))
373 (signal-semaphore sem
100)
374 (let ((ok (count-if #'join-thread workers
)))
376 (error "Wanted 50, got ~S" ok
)))))
378 (with-test (:name
(wait-on-semaphore :timeout
:one-thread
))
380 (semaphore (make-semaphore)))
381 (signal-semaphore semaphore count
)
382 (let ((values (loop repeat
100
383 collect
(wait-on-semaphore semaphore
:timeout
0.001)))
384 (expected (loop for i from
9 downto
0 collect i
)))
385 (assert (equal (remove nil values
) expected
)))))
387 (with-test (:name
(wait-on-semaphore :timeout
:many-threads
)
388 :skipped-on
(not :sb-thread
))
390 (semaphore (make-semaphore)))
391 ;; Add 10 tokens right away.
392 (signal-semaphore semaphore count
)
393 ;; 100 threads try to decrement the semaphore by 1.
398 (sleep (random 0.02))
399 (wait-on-semaphore semaphore
:timeout
0.5))))))
400 ;; Add 10 more tokens while threads may already be waiting and
402 (loop repeat
(floor count
2) do
(signal-semaphore semaphore
2))
403 ;; 20 threads should have been able to decrement the semaphore
404 ;; and obtain an updated count.
405 (let ((values (mapcar #'join-thread threads
)))
406 ;; 20 threads should succeed waiting for the semaphore.
407 (assert (= (* 2 count
) (count-if-not #'null values
)))
408 ;; The updated semaphore count should be in [0,19] at all
410 (assert (every (lambda (value) (<= 0 value
(1- (* 2 count
))))
411 (remove nil values
)))
412 ;; (At least) one thread should decrease the count to 0.
413 (assert (find 0 values
))))))
415 (with-test (:name
(wait-on-semaphore semaphore-notification
:lp-1038034
)
416 :skipped-on
(not :sb-thread
)
417 :broken-on
:sb-safepoint
)
418 ;; Test robustness of semaphore acquisition and notification with
419 ;; asynchronous thread termination... Which we know is currently
422 (let ((sem (make-semaphore)))
423 ;; In CRITICAL, WAIT-ON-SEMAPHORE and SLEEP can be interrupted
424 ;; by TERMINATE-THREAD below. But the SIGNAL-SEMAPHORE cleanup
425 ;; cannot be interrupted.
426 (flet ((critical (sleep)
427 (let ((note (make-semaphore-notification)))
428 (sb-sys:without-interrupts
430 (sb-sys:with-local-interrupts
431 (wait-on-semaphore sem
:notification note
)
433 ;; Re-increment on exit if we decremented it.
434 (when (semaphore-notification-status note
)
435 (signal-semaphore sem
)))))))
436 ;; Create /parallel/ threads trying to acquire and then signal
437 ;; the semaphore. Try to asynchronously abort T2 just as T1 is
439 (destructuring-bind (t1 t2 t3
)
441 for sleep in
'(0.01
0.02 0.02)
442 collect
(make-thread #'critical
:arguments sleep
443 :name
(format nil
"T~A" i
)))
444 (signal-semaphore sem
)
447 (terminate-thread t2
))
448 (flet ((safe-join-thread (thread &key timeout
)
454 (error "Hang in (join-thread ~A) ?" thread
))))
455 (safe-join-thread t1
:timeout
60)
456 (safe-join-thread t3
:timeout
60)))))
457 (when (zerop (mod run
60))
463 (with-test (:name
(wait-on-semaphore :n
))
464 (let ((semaphore (make-semaphore :count
3)))
465 (assert (= 1 (wait-on-semaphore semaphore
:n
2)))
466 (assert (= 1 (semaphore-count semaphore
)))))
468 (with-test (:name
(try-semaphore semaphore-notification
)
469 :skipped-on
(not :sb-thread
))
470 (let* ((sem (make-semaphore))
471 (note (make-semaphore-notification)))
472 (assert (eql nil
(try-semaphore sem
1 note
)))
473 (assert (not (semaphore-notification-status note
)))
474 (signal-semaphore sem
)
475 (assert (eql 0 (try-semaphore sem
1 note
)))
476 (assert (semaphore-notification-status note
))))
478 (with-test (:name
(return-from-thread :normal-thread
)
479 :skipped-on
(not :sb-thread
))
480 (let ((thread (make-thread (lambda ()
481 (return-from-thread (values 1 2 3))
483 (assert (equal '(1 2 3) (multiple-value-list (join-thread thread
))))))
485 (with-test (:name
(return-from-thread :main-thread
))
486 (assert (main-thread-p))
487 (assert-error (return-from-thread t
) thread-error
))
489 (with-test (:name
(abort-thread :normal-thread
)
490 :skipped-on
(not :sb-thread
))
491 (let ((thread (make-thread (lambda ()
494 (assert (equal '(:aborted
! :abort
)
496 (join-thread thread
:default
:aborted
!))))))
498 (with-test (:name
(abort-thread :main-thread
))
499 (assert (main-thread-p))
500 (assert-error (abort-thread) thread-error
))
502 ;;; The OSes vary in how pthread_setname works.
503 ;;; According to https://stackoverflow.com/questions/2369738/how-to-set-the-name-of-a-thread-in-linux-pthreads
504 ;;; // NetBSD: name + arg work like printf(name, arg)
505 ;;; int pthread_setname_np(pthread_t thread, const char *name, void *arg);
506 ;;; // FreeBSD & OpenBSD: function name is slightly different, and has no return value
507 ;;; void pthread_set_name_np(pthread_t tid, const char *name);
508 ;;; // Mac OS X: must be set from within the thread (can't specify thread ID)
509 ;;; int pthread_setname_np(const char*);
510 ;;; Only Linux is implemented for now.
511 (with-test (:name
:os-thread-name
:skipped-on
(:not
(and :linux
:sb-thread
)))
516 (loop for filename in
(directory "/proc/self/task/*/comm")
517 collect
(with-open-file (stream filename
) (read-line stream
)))))
518 (setf (thread-name *current-thread
*) "newname")
519 (with-open-file (stream (format nil
"/proc/self/task/~d/comm"
520 (thread-os-tid *current-thread
*)))
521 (list (read-line stream
) all-names
))))
523 (let ((results (join-thread thr
)))
524 (assert (string= (first results
) "newname"))
525 (assert (find "finalizer" (second results
) :test
'string
=))
526 (assert (find "testme" (second results
) :test
'string
=)))))