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 ;;; Terminating a thread that's waiting for the terminal.
35 (let ((thread (make-thread (lambda ()
36 (sb-thread::get-foreground)))))
38 (assert (thread-alive-p thread))
39 (terminate-thread thread)
41 (assert (not (thread-alive-p thread))))
43 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
45 (with-test (:name without-interrupts+condition-wait
46 :skipped-on '(not :sb-thread))
47 (let* ((lock (make-mutex))
48 (queue (make-waitqueue))
49 (thread (make-thread (lambda ()
50 (sb-sys:without-interrupts
52 (condition-wait queue lock)))))))
54 (assert (thread-alive-p thread))
55 (terminate-thread thread)
57 (assert (thread-alive-p thread))
58 (condition-notify queue)
60 (assert (not (thread-alive-p thread)))))
62 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
64 (with-test (:name without-interrupts+get-mutex :skipped-on '(not :sb-thread))
65 (let* ((lock (make-mutex))
66 (bar (progn (get-mutex lock) nil))
67 (thread (make-thread (lambda ()
68 (sb-sys:without-interrupts
72 (assert (thread-alive-p thread))
73 (terminate-thread thread)
75 (assert (thread-alive-p thread))
78 (assert (not (thread-alive-p thread)))
79 (assert (eq :aborted (join-thread thread :default :aborted)))
82 (with-test (:name parallel-find-class :skipped-on '(not :sb-thread))
84 (threads (loop repeat 10
85 collect (make-thread (lambda ()
88 do (find-class (gensym) nil))
91 (mapcar #'sb-thread:join-thread threads)
94 (with-test (:name :semaphore-multiple-waiters :skipped-on '(not :sb-thread))
95 (let ((semaphore (make-semaphore :name "test sem")))
96 (labels ((make-readers (n i)
98 (loop for r from 0 below n
100 (sb-thread:make-thread
102 (let ((sem semaphore))
104 (sb-thread:wait-on-semaphore sem))))
107 (make-writers (n readers i)
108 (let ((j (* readers i)))
109 (multiple-value-bind (k rem) (truncate j n)
112 (loop for w from 0 below n
114 (sb-thread:make-thread
116 (let ((sem semaphore))
118 (sb-thread:signal-semaphore sem))))
124 (multiple-value-bind (readers x) (make-readers r n)
125 (assert (= (length readers) r))
126 (multiple-value-bind (writers y) (make-writers w r n)
127 (assert (= (length writers) w))
129 (mapc #'sb-thread:join-thread writers)
130 (mapc #'sb-thread:join-thread readers)
131 (assert (zerop (sb-thread:semaphore-count semaphore)))
136 (sb-ext:with-timeout 10
147 ;;;; Printing waitqueues
149 (with-test (:name :waitqueue-circle-print :skipped-on '(not :sb-thread))
150 (let* ((*print-circle* nil)
151 (lock (sb-thread:make-mutex))
152 (wq (sb-thread:make-waitqueue)))
153 (sb-thread:with-recursive-lock (lock)
154 (sb-thread:condition-notify wq))
155 ;; Used to blow stack due to recursive structure.
156 (assert (princ-to-string wq))))
158 ;;;; SYMBOL-VALUE-IN-THREAD
160 (with-test (:name symbol-value-in-thread.1)
161 (let ((* (cons t t)))
162 (assert (eq * (symbol-value-in-thread '* *current-thread*)))
163 (setf (symbol-value-in-thread '* *current-thread*) 123)
164 (assert (= 123 (symbol-value-in-thread '* *current-thread*)))
167 (with-test (:name symbol-value-in-thread.2 :skipped-on '(not :sb-thread))
168 (let* ((parent *current-thread*)
169 (semaphore (make-semaphore))
170 (child (make-thread (lambda ()
171 (wait-on-semaphore semaphore)
172 (let ((old (symbol-value-in-thread 'this-is-new parent)))
173 (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
175 (progv '(this-is-new) '(42)
176 (signal-semaphore semaphore)
177 (assert (= 42 (join-thread child)))
178 (assert (eq :from-child (symbol-value 'this-is-new))))))
180 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
181 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
182 ;;; interrupted malloc in one thread can apparently block a free in another. There
183 ;;; are also some indications that pthread_mutex_lock is not re-entrant.
184 (with-test (:name symbol-value-in-thread.3
185 :skipped-on '(not :sb-thread)
187 (let* ((parent *current-thread*)
188 (semaphore (make-semaphore))
190 (noise (make-thread (lambda ()
192 do (setf * (make-array 1024))
193 ;; Busy-wait a bit so we don't TOTALLY flood the
194 ;; system with GCs: a GC occurring in the middle of
195 ;; S-V-I-T causes it to start over -- we want that
196 ;; to occur occasionally, but not _all_ the time.
197 (loop repeat (random 128)
201 (when (zerop (mod i 200))
204 (let* ((mom-mark (cons t t))
205 (kid-mark (cons t t))
206 (child (make-thread (lambda ()
207 (wait-on-semaphore semaphore)
208 (let ((old (symbol-value-in-thread 'this-is-new parent)))
209 (setf (symbol-value-in-thread 'this-is-new parent)
210 (make-array 24 :initial-element kid-mark))
212 (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark))
213 (signal-semaphore semaphore)
214 (assert (eq mom-mark (aref (join-thread child) 0)))
215 (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0))))))
217 (join-thread noise)))
219 (with-test (:name symbol-value-in-thread.4 :skipped-on '(not :sb-thread))
220 (let* ((parent *current-thread*)
221 (semaphore (make-semaphore))
222 (child (make-thread (lambda ()
223 (wait-on-semaphore semaphore)
224 (symbol-value-in-thread 'this-is-new parent nil)))))
225 (signal-semaphore semaphore)
226 (assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
228 (with-test (:name symbol-value-in-thread.5 :skipped-on '(not :sb-thread))
229 (let* ((parent *current-thread*)
230 (semaphore (make-semaphore))
231 (child (make-thread (lambda ()
232 (wait-on-semaphore semaphore)
234 (symbol-value-in-thread 'this-is-new parent)
235 (symbol-value-in-thread-error (e)
236 (list (thread-error-thread e)
238 (sb-thread::symbol-value-in-thread-error-info e))))))))
239 (signal-semaphore semaphore)
240 (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread))
241 (join-thread child)))))
243 (with-test (:name symbol-value-in-thread.6 :skipped-on '(not :sb-thread))
244 (let* ((parent *current-thread*)
245 (semaphore (make-semaphore))
247 (child (make-thread (lambda ()
248 (wait-on-semaphore semaphore)
250 (setf (symbol-value-in-thread name parent) t)
251 (symbol-value-in-thread-error (e)
252 (list (thread-error-thread e)
254 (sb-thread::symbol-value-in-thread-error-info e))))))))
255 (signal-semaphore semaphore)
256 (let ((res (join-thread child))
257 (want (list *current-thread* name (list :write :no-tls-value))))
258 (unless (equal res want)
259 (error "wanted ~S, got ~S" want res)))))
261 (with-test (:name symbol-value-in-thread.7 :skipped-on '(not :sb-thread))
262 (let ((child (make-thread (lambda ())))
263 (error-occurred nil))
266 (symbol-value-in-thread 'this-is-new child)
267 (symbol-value-in-thread-error (e)
268 (setf error-occurred t)
269 (assert (eq child (thread-error-thread e)))
270 (assert (eq 'this-is-new (cell-error-name e)))
271 (assert (equal (list :read :thread-dead)
272 (sb-thread::symbol-value-in-thread-error-info e)))))
273 (assert error-occurred)))
275 (with-test (:name symbol-value-in-thread.8 :skipped-on '(not :sb-thread))
276 (let ((child (make-thread (lambda ())))
277 (error-occurred nil))
280 (setf (symbol-value-in-thread 'this-is-new child) t)
281 (symbol-value-in-thread-error (e)
282 (setf error-occurred t)
283 (assert (eq child (thread-error-thread e)))
284 (assert (eq 'this-is-new (cell-error-name e)))
285 (assert (equal (list :write :thread-dead)
286 (sb-thread::symbol-value-in-thread-error-info e)))))
287 (assert error-occurred)))
289 (with-test (:name deadlock-detection.1 :skipped-on '(not :sb-thread))
292 do (flet ((test (ma mb sa sb)
295 (sb-thread:with-mutex (ma)
296 (sb-thread:signal-semaphore sa)
297 (sb-thread:wait-on-semaphore sb)
298 (sb-thread:with-mutex (mb)
300 (sb-thread:thread-deadlock (e)
303 (let* ((m1 (sb-thread:make-mutex :name "M1"))
304 (m2 (sb-thread:make-mutex :name "M2"))
305 (s1 (sb-thread:make-semaphore :name "S1"))
306 (s2 (sb-thread:make-semaphore :name "S2"))
307 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
308 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
309 ;; One will deadlock, and the other will then complete normally.
310 (let ((res (list (sb-thread:join-thread t1)
311 (sb-thread:join-thread t2))))
312 (assert (or (equal '(:deadlock :ok) res)
313 (equal '(:ok :deadlock) res))))))))
315 (with-test (:name deadlock-detection.2 :skipped-on '(not :sb-thread))
316 (let* ((m1 (sb-thread:make-mutex :name "M1"))
317 (m2 (sb-thread:make-mutex :name "M2"))
318 (s1 (sb-thread:make-semaphore :name "S1"))
319 (s2 (sb-thread:make-semaphore :name "S2"))
320 (t1 (sb-thread:make-thread
322 (sb-thread:with-mutex (m1)
323 (sb-thread:signal-semaphore s1)
324 (sb-thread:wait-on-semaphore s2)
325 (sb-thread:with-mutex (m2)
330 (handler-bind ((sb-thread:thread-deadlock
333 ;; Make sure we can print the condition
335 (let ((*print-circle* nil))
336 (setf err (princ-to-string e)))
340 (assert (eq :ok (sb-thread:with-mutex (m2)
342 (sb-thread:signal-semaphore s2)
343 (sb-thread:wait-on-semaphore s1)
345 (sb-thread:with-mutex (m1)
347 (assert (stringp err)))
348 (assert (eq :ok (sb-thread:join-thread t1)))))
350 (with-test (:name deadlock-detection.3 :skipped-on '(not :sb-thread))
351 (let* ((m1 (sb-thread:make-mutex :name "M1"))
352 (m2 (sb-thread:make-mutex :name "M2"))
353 (s1 (sb-thread:make-semaphore :name "S1"))
354 (s2 (sb-thread:make-semaphore :name "S2"))
355 (t1 (sb-thread:make-thread
357 (sb-thread:with-mutex (m1)
358 (sb-thread:signal-semaphore s1)
359 (sb-thread:wait-on-semaphore s2)
360 (sb-thread:with-mutex (m2)
363 ;; Currently we don't consider it a deadlock
364 ;; if there is a timeout in the chain.
365 (assert (eq :deadline
367 (sb-thread:with-mutex (m2)
368 (sb-thread:signal-semaphore s2)
369 (sb-thread:wait-on-semaphore s1)
371 (sb-sys:with-deadline (:seconds 0.1)
372 (sb-thread:with-mutex (m1)
374 (sb-sys:deadline-timeout ()
376 (sb-thread:thread-deadlock ()
378 (assert (eq :ok (join-thread t1)))))
381 (with-test (:name :pass-arguments-to-thread)
382 (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
385 (with-test (:name :pass-atom-to-thread)
386 (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
389 (with-test (:name :pass-nil-to-thread)
390 (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
393 (with-test (:name :pass-nothing-to-thread)
394 (assert (= 1 (join-thread (make-thread #'*)))))
397 (with-test (:name :pass-improper-list-to-thread)
398 (multiple-value-bind (value error)
399 (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
402 (assert (and (null value)
405 (with-test (:name (:wait-for :basics))
406 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
407 (assert (eql 42 (sb-ext:wait-for 42)))
409 (assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
412 (with-test (:name (:wait-for :deadline))
414 (sb-sys:with-deadline (:seconds 10)
415 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
417 (assert (eq :deadline
419 (sb-sys:with-deadline (:seconds 0.1)
420 (sb-ext:wait-for nil :timeout 10)
422 (sb-sys:deadline-timeout () :deadline)))))
424 (with-test (:name (:condition-wait :timeout :one-thread))
425 (let ((mutex (make-mutex))
426 (waitqueue (make-waitqueue)))
427 (assert (not (with-mutex (mutex)
428 (condition-wait waitqueue mutex :timeout 0.01))))))
430 (with-test (:name (:condition-wait :timeout :many-threads)
431 :skipped-on '(not :sb-thread))
432 (let* ((mutex (make-mutex))
433 (waitqueue (make-waitqueue))
434 (sem (make-semaphore))
440 (wait-on-semaphore sem)
444 do (or (condition-wait waitqueue mutex :timeout 0.01)
445 (return-from thread nil)))
446 (assert (eq t (pop data)))
449 do (with-mutex (mutex)
451 (condition-notify waitqueue)))
452 (signal-semaphore sem 100)
453 (let ((ok (count-if #'join-thread workers)))
455 (error "Wanted 50, got ~S" ok)))))
457 (with-test (:name (:wait-on-semaphore :timeout :one-thread))
458 (let ((sem (make-semaphore))
460 (signal-semaphore sem 10)
462 do (when (wait-on-semaphore sem :timeout 0.001)
466 (with-test (:name (:wait-on-semaphore :timeout :many-threads)
467 :skipped-on '(not :sb-thread))
468 (let* ((sem (make-semaphore))
471 (signal-semaphore sem 10)
475 (sleep (random 0.02))
476 (wait-on-semaphore sem :timeout 0.01)))))))
478 do (signal-semaphore sem 2))
479 (let ((ok (count-if #'join-thread threads)))
481 (error "Wanted 20, got ~S" ok)))))
483 (with-test (:name (:join-thread :timeout)
484 :skipped-on '(not :sb-thread))
487 (join-thread (make-thread (lambda () (sleep 10))) :timeout 0.01)
488 (join-thread-error ()
490 (let ((cookie (cons t t)))
492 (join-thread (make-thread (lambda () (sleep 10)))
496 (with-test (:name (:semaphore-notification :wait-on-semaphore)
497 :skipped-on '(not :sb-thread))
498 (let ((sem (make-semaphore))
502 (let ((note (make-semaphore-notification)))
503 (sb-sys:without-interrupts
506 (sb-sys:with-local-interrupts
507 (wait-on-semaphore sem :notification note)
508 (sleep (random 0.1)))
510 ;; Re-increment on exit if we decremented it.
511 (when (semaphore-notification-status note)
512 (signal-semaphore sem))
513 ;; KLUDGE: Prevent interrupts after this point from
514 ;; unwinding us, so that we can reason about the counts.
516 (sb-thread::block-deferrable-signals))))))
517 (let* ((threads (loop for i from 1 upto 100
518 collect (make-thread #'critical :name (format nil "T~A" i))))
521 (interruptor (make-thread (lambda ()
524 (dolist (thread threads)
529 (terminate-thread thread)))
532 (setf x (not x))))))))
533 (signal-semaphore sem)
535 (join-thread interruptor)
536 (mapc #'join-thread safe)
537 (let ((k (count-if (lambda (th)
538 (join-thread th :default nil))
540 (assert (= n (+ k (length safe))))
543 (with-test (:name (:semaphore-notification :try-sempahore)
544 :skipped-on '(not :sb-thread))
545 (let* ((sem (make-semaphore))
546 (note (make-semaphore-notification)))
547 (try-semaphore sem 1 note)
548 (assert (not (semaphore-notification-status note)))
549 (signal-semaphore sem)
550 (try-semaphore sem 1 note)
551 (assert (semaphore-notification-status note))))