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 (let* ((lock (make-mutex))
61 (queue (make-waitqueue))
62 (thread (make-thread (lambda ()
63 (sb-sys:without-interrupts
65 (condition-wait queue lock)))))))
67 (assert (thread-alive-p thread))
68 (terminate-thread thread)
70 (assert (thread-alive-p thread))
71 (condition-notify queue)
73 (assert (not (thread-alive-p thread)))))
75 ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
77 (with-test (:name without-interrupts+grab-mutex :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 (mapcar #'sb-thread: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
113 (sb-thread:make-thread
115 (let ((sem semaphore))
117 (sb-thread: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
127 (sb-thread:make-thread
129 (let ((sem semaphore))
131 (sb-thread: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 #'sb-thread:join-thread writers)
143 (mapc #'sb-thread:join-thread readers)
144 (assert (zerop (sb-thread: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)
164 (lock (sb-thread:make-mutex))
165 (wq (sb-thread:make-waitqueue)))
166 (sb-thread:with-recursive-lock (lock)
167 (sb-thread: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 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
194 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
195 ;;; interrupted malloc in one thread can apparently block a free in another.
196 (with-test (:name symbol-value-in-thread.3
197 :skipped-on '(not :sb-thread))
198 (let* ((parent *current-thread*)
199 (semaphore (make-semaphore))
201 (noise (make-thread (lambda ()
203 do (setf * (make-array 1024))
204 ;; Busy-wait a bit so we don't TOTALLY flood the
205 ;; system with GCs: a GC occurring in the middle of
206 ;; S-V-I-T causes it to start over -- we want that
207 ;; to occur occasionally, but not _all_ the time.
208 (loop repeat (random 128)
212 (when (zerop (mod i 200))
215 (let* ((mom-mark (cons t t))
216 (kid-mark (cons t t))
217 (child (make-thread (lambda ()
218 (wait-on-semaphore semaphore)
219 (let ((old (symbol-value-in-thread 'this-is-new parent)))
220 (setf (symbol-value-in-thread 'this-is-new parent)
221 (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) 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)
306 (sb-thread:with-mutex (ma)
307 (sb-thread:signal-semaphore sa)
308 (sb-thread:wait-on-semaphore sb)
309 (sb-thread:with-mutex (mb)
311 (sb-thread:thread-deadlock (e)
314 (let* ((m1 (sb-thread:make-mutex :name "M1"))
315 (m2 (sb-thread:make-mutex :name "M2"))
316 (s1 (sb-thread:make-semaphore :name "S1"))
317 (s2 (sb-thread:make-semaphore :name "S2"))
318 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
319 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
320 ;; One will deadlock, and the other will then complete normally.
321 (let ((res (list (sb-thread:join-thread t1)
322 (sb-thread:join-thread t2))))
323 (assert (or (equal '(:deadlock :ok) res)
324 (equal '(:ok :deadlock) res))))))))
326 (with-test (:name deadlock-detection.2 :skipped-on '(not :sb-thread))
327 (let* ((m1 (sb-thread:make-mutex :name "M1"))
328 (m2 (sb-thread:make-mutex :name "M2"))
329 (s1 (sb-thread:make-semaphore :name "S1"))
330 (s2 (sb-thread:make-semaphore :name "S2"))
331 (t1 (sb-thread:make-thread
333 (sb-thread:with-mutex (m1)
334 (sb-thread:signal-semaphore s1)
335 (sb-thread:wait-on-semaphore s2)
336 (sb-thread:with-mutex (m2)
341 (handler-bind ((sb-thread:thread-deadlock
344 ;; Make sure we can print the condition
346 (let ((*print-circle* nil))
347 (setf err (princ-to-string e)))
351 (assert (eq :ok (sb-thread:with-mutex (m2)
353 (sb-thread:signal-semaphore s2)
354 (sb-thread:wait-on-semaphore s1)
356 (sb-thread:with-mutex (m1)
358 (assert (stringp err)))
359 (assert (eq :ok (sb-thread:join-thread t1)))))
361 (with-test (:name deadlock-detection.3 :skipped-on '(not :sb-thread))
362 (let* ((m1 (sb-thread:make-mutex :name "M1"))
363 (m2 (sb-thread:make-mutex :name "M2"))
364 (s1 (sb-thread:make-semaphore :name "S1"))
365 (s2 (sb-thread:make-semaphore :name "S2"))
366 (t1 (sb-thread:make-thread
368 (sb-thread:with-mutex (m1)
369 (sb-thread:signal-semaphore s1)
370 (sb-thread:wait-on-semaphore s2)
371 (sb-thread:with-mutex (m2)
374 ;; Currently we don't consider it a deadlock
375 ;; if there is a timeout in the chain.
376 (assert (eq :deadline
378 (sb-thread:with-mutex (m2)
379 (sb-thread:signal-semaphore s2)
380 (sb-thread:wait-on-semaphore s1)
382 (sb-sys:with-deadline (:seconds 0.1)
383 (sb-thread:with-mutex (m1)
385 (sb-sys:deadline-timeout ()
387 (sb-thread:thread-deadlock ()
389 (assert (eq :ok (join-thread t1)))))
392 (with-test (:name :pass-arguments-to-thread)
393 (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
396 (with-test (:name :pass-atom-to-thread)
397 (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
400 (with-test (:name :pass-nil-to-thread)
401 (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
404 (with-test (:name :pass-nothing-to-thread)
405 (assert (= 1 (join-thread (make-thread #'*)))))
408 (with-test (:name :pass-improper-list-to-thread)
409 (multiple-value-bind (value error)
410 (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
413 (assert (and (null value)
416 (with-test (:name (:wait-for :basics) :fails-on :win32)
417 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
418 (assert (eql 42 (sb-ext:wait-for 42)))
420 (assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
423 (with-test (:name (:wait-for :deadline) :fails-on :win32)
425 (sb-sys:with-deadline (:seconds 10)
426 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
428 (assert (eq :deadline
430 (sb-sys:with-deadline (:seconds 0.1)
431 (sb-ext:wait-for nil :timeout 10)
433 (sb-sys:deadline-timeout () :deadline)))))
435 (with-test (:name (:condition-wait :timeout :one-thread) :fails-on :win32)
436 (let ((mutex (make-mutex))
437 (waitqueue (make-waitqueue)))
438 (assert (not (with-mutex (mutex)
439 (condition-wait waitqueue mutex :timeout 0.01))))))
441 (with-test (:name (:condition-wait :timeout :many-threads)
442 :skipped-on '(not :sb-thread))
443 (let* ((mutex (make-mutex))
444 (waitqueue (make-waitqueue))
445 (sem (make-semaphore))
451 (wait-on-semaphore sem)
455 do (or (condition-wait waitqueue mutex :timeout 0.01)
456 (return-from thread nil)))
457 (assert (eq t (pop data)))
460 do (with-mutex (mutex)
462 (condition-notify waitqueue)))
463 (signal-semaphore sem 100)
464 (let ((ok (count-if #'join-thread workers)))
466 (error "Wanted 50, got ~S" ok)))))
468 (with-test (:name (:wait-on-semaphore :timeout :one-thread) :fails-on :win32)
469 (let ((sem (make-semaphore))
471 (signal-semaphore sem 10)
473 do (when (wait-on-semaphore sem :timeout 0.001)
477 (with-test (:name (:wait-on-semaphore :timeout :many-threads)
478 :skipped-on '(not :sb-thread))
479 (let* ((sem (make-semaphore))
482 (signal-semaphore sem 10)
486 (sleep (random 0.02))
487 (wait-on-semaphore sem :timeout 0.5)))))))
489 do (signal-semaphore sem 2))
490 (let ((ok (count-if #'join-thread threads)))
492 (error "Wanted 20, got ~S" ok)))))
494 (with-test (:name (:join-thread :timeout)
495 :skipped-on '(not :sb-thread))
498 (join-thread (make-join-thread (lambda () (sleep 10))) :timeout 0.01)
499 (join-thread-error ()
501 (let ((cookie (cons t t)))
503 (join-thread (make-join-thread (lambda () (sleep 10)))
507 (with-test (:name (:semaphore-notification :wait-on-semaphore)
508 :skipped-on '(not :sb-thread))
509 (let ((sem (make-semaphore))
513 (let ((note (make-semaphore-notification)))
514 (sb-sys:without-interrupts
517 (sb-sys:with-local-interrupts
518 (wait-on-semaphore sem :notification note)
519 (sleep (random 0.1)))
521 ;; Re-increment on exit if we decremented it.
522 (when (semaphore-notification-status note)
523 (signal-semaphore sem))
524 ;; KLUDGE: Prevent interrupts after this point from
525 ;; unwinding us, so that we can reason about the counts.
527 (sb-thread::block-deferrable-signals))))))
528 (let* ((threads (loop for i from 1 upto 100
529 collect (make-join-thread #'critical :name (format nil "T~A" i))))
532 (interruptor (make-thread (lambda ()
535 (dolist (thread threads)
540 (terminate-thread thread)))
543 (setf x (not x))))))))
544 (signal-semaphore sem)
546 (join-thread interruptor)
547 (mapc #'join-thread safe)
548 (let ((k (count-if (lambda (th)
549 (join-thread th :default nil))
551 (assert (= n (+ k (length safe))))
554 (with-test (:name (:semaphore-notification :try-sempahore)
555 :skipped-on '(not :sb-thread))
556 (let* ((sem (make-semaphore))
557 (note (make-semaphore-notification)))
558 (try-semaphore sem 1 note)
559 (assert (not (semaphore-notification-status note)))
560 (signal-semaphore sem)
561 (try-semaphore sem 1 note)
562 (assert (semaphore-notification-status note))))
564 (with-test (:name (:return-from-thread :normal-thread)
565 :skipped-on '(not :sb-thread))
566 (let* ((thread (make-thread (lambda ()
567 (return-from-thread (values 1 2 3))
569 (values (multiple-value-list (join-thread thread))))
570 (unless (equal (list 1 2 3) values)
571 (error "got ~S, wanted (1 2 3)" values))))
573 (with-test (:name (:return-from-thread :main-thread))
574 (assert (main-thread-p))
577 (return-from-thread t)
581 (with-test (:name (:abort-thread :normal-thread)
582 :skipped-on '(not :sb-thread))
583 (let ((thread (make-thread (lambda ()
586 (assert (eq :aborted! (join-thread thread :default :aborted!)))))
588 (with-test (:name (:abort-thread :main-thread))
589 (assert (main-thread-p))