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))
19 (in-package :thread-test)
21 (use-package :test-util)
23 (with-test (:name mutex-owner)
24 ;; Make sure basics are sane on unithreaded ports as well
25 (let ((mutex (make-mutex)))
27 (assert (eq *current-thread* (mutex-value mutex)))
28 (handler-bind ((warning #'error))
29 (release-mutex mutex))
30 (assert (not (mutex-value mutex)))))
32 (with-test (:name spinlock-owner)
33 ;; Make sure basics are sane on unithreaded ports as well
34 (let ((spinlock (sb-thread::make-spinlock)))
35 (sb-thread::get-spinlock spinlock)
36 (assert (eq *current-thread* (sb-thread::spinlock-value spinlock)))
37 (handler-bind ((warning #'error))
38 (sb-thread::release-spinlock spinlock))
39 (assert (not (sb-thread::spinlock-value spinlock)))))
41 ;;; Terminating a thread that's waiting for the terminal.
44 (let ((thread (make-thread (lambda ()
45 (sb-thread::get-foreground)))))
47 (assert (thread-alive-p thread))
48 (terminate-thread thread)
50 (assert (not (thread-alive-p thread))))
52 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
54 (with-test (:name without-interrupts+condition-wait
55 :skipped-on '(not :sb-thread))
56 (let* ((lock (make-mutex))
57 (queue (make-waitqueue))
58 (thread (make-thread (lambda ()
59 (sb-sys:without-interrupts
61 (condition-wait queue lock)))))))
63 (assert (thread-alive-p thread))
64 (terminate-thread thread)
66 (assert (thread-alive-p thread))
67 (condition-notify queue)
69 (assert (not (thread-alive-p thread)))))
71 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
73 (with-test (:name without-interrupts+get-mutex :skipped-on '(not :sb-thread))
74 (let* ((lock (make-mutex))
75 (bar (progn (get-mutex lock) nil))
76 (thread (make-thread (lambda ()
77 (sb-sys:without-interrupts
81 (assert (thread-alive-p thread))
82 (terminate-thread thread)
84 (assert (thread-alive-p thread))
87 (assert (not (thread-alive-p thread)))
88 (assert (eq :aborted (join-thread thread :default :aborted)))
91 (with-test (:name parallel-find-class :skipped-on '(not :sb-thread))
93 (threads (loop repeat 10
94 collect (make-thread (lambda ()
97 do (find-class (gensym) nil))
100 (mapcar #'sb-thread:join-thread threads)
101 (assert (not oops))))
103 (with-test (:name :semaphore-multiple-waiters :skipped-on '(not :sb-thread))
104 (let ((semaphore (make-semaphore :name "test sem")))
105 (labels ((make-readers (n i)
107 (loop for r from 0 below n
109 (sb-thread:make-thread
111 (let ((sem semaphore))
113 (sb-thread:wait-on-semaphore sem))))
116 (make-writers (n readers i)
117 (let ((j (* readers i)))
118 (multiple-value-bind (k rem) (truncate j n)
121 (loop for w from 0 below n
123 (sb-thread:make-thread
125 (let ((sem semaphore))
127 (sb-thread:signal-semaphore sem))))
133 (multiple-value-bind (readers x) (make-readers r n)
134 (assert (= (length readers) r))
135 (multiple-value-bind (writers y) (make-writers w r n)
136 (assert (= (length writers) w))
138 (mapc #'sb-thread:join-thread writers)
139 (mapc #'sb-thread:join-thread readers)
140 (assert (zerop (sb-thread:semaphore-count semaphore)))
145 (sb-ext:with-timeout 10
156 ;;;; Printing waitqueues
158 (with-test (:name :waitqueue-circle-print :skipped-on '(not :sb-thread))
159 (let* ((*print-circle* nil)
160 (lock (sb-thread:make-mutex))
161 (wq (sb-thread:make-waitqueue)))
162 (sb-thread:with-recursive-lock (lock)
163 (sb-thread:condition-notify wq))
164 ;; Used to blow stack due to recursive structure.
165 (assert (princ-to-string wq))))
167 ;;;; SYMBOL-VALUE-IN-THREAD
169 (with-test (:name symbol-value-in-thread.1)
170 (let ((* (cons t t)))
171 (assert (eq * (symbol-value-in-thread '* *current-thread*)))
172 (setf (symbol-value-in-thread '* *current-thread*) 123)
173 (assert (= 123 (symbol-value-in-thread '* *current-thread*)))
176 (with-test (:name symbol-value-in-thread.2 :skipped-on '(not :sb-thread))
177 (let* ((parent *current-thread*)
178 (semaphore (make-semaphore))
179 (child (make-thread (lambda ()
180 (wait-on-semaphore semaphore)
181 (let ((old (symbol-value-in-thread 'this-is-new parent)))
182 (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
184 (progv '(this-is-new) '(42)
185 (signal-semaphore semaphore)
186 (assert (= 42 (join-thread child)))
187 (assert (eq :from-child (symbol-value 'this-is-new))))))
189 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
190 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
191 ;;; interrupted malloc in one thread can apparently block a free in another. There
192 ;;; are also some indications that pthread_mutex_lock is not re-entrant.
193 (with-test (:name symbol-value-in-thread.3
194 :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 ;; ...except sometimes, when we get unlucky, and both will do
320 ;; the deadlock detection in parallel and both signal.
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)
325 (equal '(:deadlock :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)))))
392 (with-test (:name deadlock-detection.4 :skipped-on '(not :sb-thread))
395 do (flet ((test (ma mb sa sb)
398 (sb-thread::with-spinlock (ma)
399 (sb-thread:signal-semaphore sa)
400 (sb-thread:wait-on-semaphore sb)
401 (sb-thread::with-spinlock (mb)
403 (sb-thread:thread-deadlock (e)
406 (let* ((m1 (sb-thread::make-spinlock :name "M1"))
407 (m2 (sb-thread::make-spinlock :name "M2"))
408 (s1 (sb-thread:make-semaphore :name "S1"))
409 (s2 (sb-thread:make-semaphore :name "S2"))
410 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
411 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
412 ;; One will deadlock, and the other will then complete normally
413 ;; ...except sometimes, when we get unlucky, and both will do
414 ;; the deadlock detection in parallel and both signal.
415 (let ((res (list (sb-thread:join-thread t1)
416 (sb-thread:join-thread t2))))
417 (assert (or (equal '(:deadlock :ok) res)
418 (equal '(:ok :deadlock) res)
419 (equal '(:deadlock :deadlock) res))))))))
421 (with-test (:name deadlock-detection.5 :skipped-on '(not :sb-thread))
422 (let* ((m1 (sb-thread::make-spinlock :name "M1"))
423 (m2 (sb-thread::make-spinlock :name "M2"))
424 (s1 (sb-thread:make-semaphore :name "S1"))
425 (s2 (sb-thread:make-semaphore :name "S2"))
426 (t1 (sb-thread:make-thread
428 (sb-thread::with-spinlock (m1)
429 (sb-thread:signal-semaphore s1)
430 (sb-thread:wait-on-semaphore s2)
431 (sb-thread::with-spinlock (m2)
436 (handler-bind ((sb-thread:thread-deadlock
439 ;; Make sure we can print the condition
441 (let ((*print-circle* nil))
442 (setf err (princ-to-string e)))
446 (assert (eq :ok (sb-thread::with-spinlock (m2)
448 (sb-thread:signal-semaphore s2)
449 (sb-thread:wait-on-semaphore s1)
451 (sb-thread::with-spinlock (m1)
453 (assert (stringp err)))
454 (assert (eq :ok (sb-thread:join-thread t1)))))
456 (with-test (:name deadlock-detection.7 :skipped-on '(not :sb-thread))
457 (let* ((m1 (sb-thread::make-spinlock :name "M1"))
458 (m2 (sb-thread::make-spinlock :name "M2"))
459 (s1 (sb-thread:make-semaphore :name "S1"))
460 (s2 (sb-thread:make-semaphore :name "S2"))
461 (t1 (sb-thread:make-thread
463 (sb-thread::with-spinlock (m1)
464 (sb-thread:signal-semaphore s1)
465 (sb-thread:wait-on-semaphore s2)
466 (sb-thread::with-spinlock (m2)
469 (assert (eq :deadlock
471 (sb-thread::with-spinlock (m2)
472 (sb-thread:signal-semaphore s2)
473 (sb-thread:wait-on-semaphore s1)
475 (sb-sys:with-deadline (:seconds 0.1)
476 (sb-thread::with-spinlock (m1)
478 (sb-sys:deadline-timeout ()
480 (sb-thread:thread-deadlock ()
482 (assert (eq :ok (join-thread t1)))))
485 (with-test (:name :pass-arguments-to-thread)
486 (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
489 (with-test (:name :pass-atom-to-thread)
490 (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
493 (with-test (:name :pass-nil-to-thread)
494 (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
497 (with-test (:name :pass-nothing-to-thread)
498 (assert (= 1 (join-thread (make-thread #'*)))))
501 (with-test (:name :pass-improper-list-to-thread)
502 (multiple-value-bind (value error)
503 (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
506 (assert (and (null value)
509 (with-test (:name (:wait-for :basics))
510 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
511 (assert (eql 42 (sb-ext:wait-for 42)))
513 (assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
516 (with-test (:name (:wait-for :deadline))
518 (sb-sys:with-deadline (:seconds 10)
519 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
521 (assert (eq :deadline
523 (sb-sys:with-deadline (:seconds 0.1)
524 (sb-ext:wait-for nil :timeout 10)
526 (sb-sys:deadline-timeout () :deadline)))))