Clean up listify-rest-args VOP on x86-64.
[sbcl.git] / tests / threads.pure.lisp
1 ;;;; miscellaneous tests of thread stuff
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;
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.
13
14 (in-package :cl-user)
15
16 (defpackage :thread-test
17   (:use :cl :sb-thread :sb-ext))
18
19 (in-package :thread-test)
20
21 (use-package :test-util)
22
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
28           (loop repeat nthreads
29                 collect (sb-thread:make-thread
30                          (lambda ()
31                            (loop repeat 1000
32                                  do (atomic-update (cdr x) #'1+)
33                                     (sleep 0.00001))))))
34     (assert (equal x `(:count ,@(* 1000 nthreads))))))
35
36 (with-test (:name mutex-owner)
37   ;; Make sure basics are sane on unithreaded ports as well
38   (let ((mutex (make-mutex)))
39     (grab-mutex mutex)
40     (assert (eq *current-thread* (mutex-value mutex)))
41     (handler-bind ((warning #'error))
42       (release-mutex mutex))
43     (assert (not (mutex-value mutex)))))
44
45 ;;; Terminating a thread that's waiting for the terminal.
46
47 #+sb-thread
48 (let ((thread (make-thread (lambda ()
49                              (sb-thread::get-foreground)))))
50   (sleep 1)
51   (assert (thread-alive-p thread))
52   (terminate-thread thread)
53   (sleep 1)
54   (assert (not (thread-alive-p thread))))
55
56 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
57
58 (with-test (:name without-interrupts+condition-wait
59             :skipped-on '(not :sb-thread)
60             :fails-on '(and :win32 :sb-futex))
61   (let* ((lock (make-mutex))
62          (queue (make-waitqueue))
63          (thread (make-thread (lambda ()
64                                 (sb-sys:without-interrupts
65                                   (with-mutex (lock)
66                                     (condition-wait queue lock)))))))
67     (sleep 1)
68     (assert (thread-alive-p thread))
69     (terminate-thread thread)
70     (sleep 1)
71     (assert (thread-alive-p thread))
72     (condition-notify queue)
73     (sleep 1)
74     (assert (not (thread-alive-p thread)))))
75
76 ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
77
78 (with-test (:name without-interrupts+grab-mutex :skipped-on '(not :sb-thread))
79   (let* ((lock (make-mutex))
80          (bar (progn (grab-mutex lock) nil))
81          (thread (make-thread (lambda ()
82                                 (sb-sys:without-interrupts
83                                     (with-mutex (lock)
84                                       (setf bar t)))))))
85     (sleep 1)
86     (assert (thread-alive-p thread))
87     (terminate-thread thread)
88     (sleep 1)
89     (assert (thread-alive-p thread))
90     (release-mutex lock)
91     (sleep 1)
92     (assert (not (thread-alive-p thread)))
93     (assert (eq :aborted (join-thread thread :default :aborted)))
94     (assert bar)))
95
96 (with-test (:name parallel-find-class :skipped-on '(not :sb-thread))
97   (let* ((oops nil)
98          (threads (loop repeat 10
99                         collect (make-thread (lambda ()
100                                                (handler-case
101                                                    (loop repeat 10000
102                                                          do (find-class (gensym) nil))
103                                                  (serious-condition ()
104                                                    (setf oops t))))))))
105     (mapcar #'sb-thread:join-thread threads)
106     (assert (not oops))))
107
108 (with-test (:name :semaphore-multiple-waiters :skipped-on '(not :sb-thread))
109   (let ((semaphore (make-semaphore :name "test sem")))
110     (labels ((make-readers (n i)
111                (values
112                 (loop for r from 0 below n
113                       collect
114                       (sb-thread:make-thread
115                        (lambda ()
116                          (let ((sem semaphore))
117                            (dotimes (s i)
118                              (sb-thread:wait-on-semaphore sem))))
119                        :name "reader"))
120                 (* n i)))
121              (make-writers (n readers i)
122                (let ((j (* readers i)))
123                  (multiple-value-bind (k rem) (truncate j n)
124                    (values
125                     (let ((writers
126                            (loop for w from 0 below n
127                                  collect
128                                  (sb-thread:make-thread
129                                   (lambda ()
130                                     (let ((sem semaphore))
131                                       (dotimes (s k)
132                                         (sb-thread:signal-semaphore sem))))
133                                   :name "writer"))))
134                       (assert (zerop rem))
135                       writers)
136                     (+ rem (* n k))))))
137              (test (r w n)
138                (multiple-value-bind (readers x) (make-readers r n)
139                  (assert (= (length readers) r))
140                  (multiple-value-bind (writers y) (make-writers w r n)
141                    (assert (= (length writers) w))
142                    (assert (= x y))
143                    (mapc #'sb-thread:join-thread writers)
144                    (mapc #'sb-thread:join-thread readers)
145                    (assert (zerop (sb-thread:semaphore-count semaphore)))
146                    (values)))))
147       (assert
148        (eq :ok
149            (handler-case
150                (sb-ext:with-timeout 10
151                  (test 1 1 100)
152                  (test 2 2 10000)
153                  (test 4 2 10000)
154                  (test 4 2 10000)
155                  (test 10 10 10000)
156                  (test 10 1 10000)
157                  :ok)
158              (sb-ext:timeout ()
159                :timeout)))))))
160
161 ;;;; Printing waitqueues
162
163 (with-test (:name :waitqueue-circle-print :skipped-on '(not :sb-thread))
164   (let* ((*print-circle* nil)
165          (lock (sb-thread:make-mutex))
166          (wq (sb-thread:make-waitqueue)))
167     (sb-thread:with-recursive-lock (lock)
168       (sb-thread:condition-notify wq))
169     ;; Used to blow stack due to recursive structure.
170     (assert (princ-to-string wq))))
171
172 ;;;; SYMBOL-VALUE-IN-THREAD
173
174 (with-test (:name symbol-value-in-thread.1)
175   (let ((* (cons t t)))
176     (assert (eq * (symbol-value-in-thread '* *current-thread*)))
177     (setf (symbol-value-in-thread '* *current-thread*) 123)
178     (assert (= 123 (symbol-value-in-thread '* *current-thread*)))
179     (assert (= 123 *))))
180
181 (with-test (:name symbol-value-in-thread.2 :skipped-on '(not :sb-thread))
182   (let* ((parent *current-thread*)
183          (semaphore (make-semaphore))
184          (child (make-thread (lambda ()
185                                (wait-on-semaphore semaphore)
186                                (let ((old (symbol-value-in-thread 'this-is-new parent)))
187                                  (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
188                                  old)))))
189     (progv '(this-is-new) '(42)
190       (signal-semaphore semaphore)
191       (assert (= 42 (join-thread child)))
192       (assert (eq :from-child (symbol-value 'this-is-new))))))
193
194 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
195 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
196 ;;; interrupted malloc in one thread can apparently block a free in another.
197 (with-test (:name symbol-value-in-thread.3
198             :skipped-on '(not :sb-thread))
199   (let* ((parent *current-thread*)
200          (semaphore (make-semaphore))
201          (running t)
202          (noise (make-thread (lambda ()
203                                (loop while running
204                                      do (setf * (make-array 1024))
205                                      ;; Busy-wait a bit so we don't TOTALLY flood the
206                                      ;; system with GCs: a GC occurring in the middle of
207                                      ;; S-V-I-T causes it to start over -- we want that
208                                      ;; to occur occasionally, but not _all_ the time.
209                                         (loop repeat (random 128)
210                                               do (setf ** *)))))))
211     (write-string "; ")
212     (dotimes (i #+win32 2000 #-win32 15000)
213       (when (zerop (mod i 200))
214         (write-char #\.)
215         (force-output))
216       (let* ((mom-mark (cons t t))
217              (kid-mark (cons t t))
218              (child (make-thread (lambda ()
219                                    (wait-on-semaphore semaphore)
220                                    (let ((old (symbol-value-in-thread 'this-is-new parent)))
221                                      (setf (symbol-value-in-thread 'this-is-new parent)
222                                            (make-array 24 :initial-element kid-mark))
223                                      old)))))
224         (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark))
225           (signal-semaphore semaphore)
226           (assert (eq mom-mark (aref (join-thread child) 0)))
227           (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0))))))
228     (setf running nil)
229     (join-thread noise)))
230
231 (with-test (:name symbol-value-in-thread.4 :skipped-on '(not :sb-thread))
232   (let* ((parent *current-thread*)
233          (semaphore (make-semaphore))
234          (child (make-thread (lambda ()
235                                (wait-on-semaphore semaphore)
236                                (symbol-value-in-thread 'this-is-new parent nil)))))
237     (signal-semaphore semaphore)
238     (assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
239
240 (with-test (:name symbol-value-in-thread.5 :skipped-on '(not :sb-thread))
241   (let* ((parent *current-thread*)
242          (semaphore (make-semaphore))
243          (child (make-thread (lambda ()
244                                (wait-on-semaphore semaphore)
245                                (handler-case
246                                    (symbol-value-in-thread 'this-is-new parent)
247                                  (symbol-value-in-thread-error (e)
248                                    (list (thread-error-thread e)
249                                          (cell-error-name e)
250                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
251     (signal-semaphore semaphore)
252     (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread))
253                    (join-thread child)))))
254
255 (with-test (:name symbol-value-in-thread.6 :skipped-on '(not :sb-thread))
256   (let* ((parent *current-thread*)
257          (semaphore (make-semaphore))
258          (name (gensym))
259          (child (make-thread (lambda ()
260                                (wait-on-semaphore semaphore)
261                                (handler-case
262                                    (setf (symbol-value-in-thread name parent) t)
263                                  (symbol-value-in-thread-error (e)
264                                    (list (thread-error-thread e)
265                                          (cell-error-name e)
266                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
267     (signal-semaphore semaphore)
268     (let ((res (join-thread child))
269           (want (list *current-thread* name (list :write :no-tls-value))))
270       (unless (equal res want)
271         (error "wanted ~S, got ~S" want res)))))
272
273 (with-test (:name symbol-value-in-thread.7 :skipped-on '(not :sb-thread))
274   (let ((child (make-thread (lambda ())))
275         (error-occurred nil))
276     (join-thread child)
277     (handler-case
278         (symbol-value-in-thread 'this-is-new child)
279       (symbol-value-in-thread-error (e)
280         (setf error-occurred t)
281         (assert (eq child (thread-error-thread e)))
282         (assert (eq 'this-is-new (cell-error-name e)))
283         (assert (equal (list :read :thread-dead)
284                        (sb-thread::symbol-value-in-thread-error-info e)))))
285     (assert error-occurred)))
286
287 (with-test (:name symbol-value-in-thread.8  :skipped-on '(not :sb-thread))
288   (let ((child (make-thread (lambda ())))
289         (error-occurred nil))
290     (join-thread child)
291     (handler-case
292         (setf (symbol-value-in-thread 'this-is-new child) t)
293       (symbol-value-in-thread-error (e)
294         (setf error-occurred t)
295         (assert (eq child (thread-error-thread e)))
296         (assert (eq 'this-is-new (cell-error-name e)))
297         (assert (equal (list :write :thread-dead)
298                        (sb-thread::symbol-value-in-thread-error-info e)))))
299     (assert error-occurred)))
300
301 (with-test (:name deadlock-detection.1  :skipped-on '(not :sb-thread))
302   (loop
303     repeat 1000
304     do (flet ((test (ma mb sa sb)
305                 (lambda ()
306                   (handler-case
307                       (sb-thread:with-mutex (ma)
308                         (sb-thread:signal-semaphore sa)
309                         (sb-thread:wait-on-semaphore sb)
310                         (sb-thread:with-mutex (mb)
311                           :ok))
312                     (sb-thread:thread-deadlock (e)
313                       (princ e)
314                       :deadlock)))))
315          (let* ((m1 (sb-thread:make-mutex :name "M1"))
316                 (m2 (sb-thread:make-mutex :name "M2"))
317                 (s1 (sb-thread:make-semaphore :name "S1"))
318                 (s2 (sb-thread:make-semaphore :name "S2"))
319                 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
320                 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
321            ;; One will deadlock, and the other will then complete normally.
322            (let ((res (list (sb-thread:join-thread t1)
323                             (sb-thread:join-thread t2))))
324              (assert (or (equal '(:deadlock :ok) res)
325                          (equal '(:ok :deadlock) res))))))))
326
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
333               (lambda ()
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)
338                     :ok)))
339               :name "T1")))
340     (prog (err)
341      :retry
342        (handler-bind ((sb-thread:thread-deadlock
343                        (lambda (e)
344                          (unless err
345                            ;; Make sure we can print the condition
346                            ;; while it's active
347                            (let ((*print-circle* nil))
348                              (setf err (princ-to-string e)))
349                            (go :retry)))))
350          (when err
351            (sleep 1))
352          (assert (eq :ok (sb-thread:with-mutex (m2)
353                            (unless err
354                              (sb-thread:signal-semaphore s2)
355                              (sb-thread:wait-on-semaphore s1)
356                              (sleep 1))
357                            (sb-thread:with-mutex (m1)
358                              :ok)))))
359        (assert (stringp err)))
360     (assert (eq :ok (sb-thread:join-thread t1)))))
361
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
368               (lambda ()
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)
373                     :ok)))
374               :name "T1")))
375     ;; Currently we don't consider it a deadlock
376     ;; if there is a timeout in the chain.
377     (assert (eq :deadline
378                 (handler-case
379                     (sb-thread:with-mutex (m2)
380                       (sb-thread:signal-semaphore s2)
381                       (sb-thread:wait-on-semaphore s1)
382                       (sleep 1)
383                       (sb-sys:with-deadline (:seconds 0.1)
384                         (sb-thread:with-mutex (m1)
385                           :ok)))
386                   (sb-sys:deadline-timeout ()
387                     :deadline)
388                   (sb-thread:thread-deadlock ()
389                     :deadlock))))
390     (assert (eq :ok (join-thread t1)))))
391
392 #+sb-thread
393 (with-test (:name :pass-arguments-to-thread)
394   (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
395
396 #+sb-thread
397 (with-test (:name :pass-atom-to-thread)
398   (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
399
400 #+sb-thread
401 (with-test (:name :pass-nil-to-thread)
402   (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
403
404 #+sb-thread
405 (with-test (:name :pass-nothing-to-thread)
406   (assert (= 1 (join-thread (make-thread #'*)))))
407
408 #+sb-thread
409 (with-test (:name :pass-improper-list-to-thread)
410   (multiple-value-bind (value error)
411       (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
412     (when value
413       (join-thread value))
414     (assert (and (null value)
415                  error))))
416
417 (with-test (:name (:wait-for :basics))
418   (assert (not (sb-ext:wait-for nil :timeout 0.1)))
419   (assert (eql 42 (sb-ext:wait-for 42)))
420   (let ((n 0))
421     (assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
422                                         n))))))
423
424 (with-test (:name (:wait-for :deadline))
425   (assert (eq :ok
426               (sb-sys:with-deadline (:seconds 10)
427                 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
428                 :ok)))
429   (assert (eq :deadline
430               (handler-case
431                   (sb-sys:with-deadline (:seconds 0.1)
432                     (sb-ext:wait-for nil :timeout 10)
433                     (error "oops"))
434                 (sb-sys:deadline-timeout () :deadline)))))
435
436 (with-test (:name (:condition-wait :timeout :one-thread))
437   (let ((mutex (make-mutex))
438         (waitqueue (make-waitqueue)))
439     (assert (not (with-mutex (mutex)
440                    (condition-wait waitqueue mutex :timeout 0.01))))))
441
442 (with-test (:name (:condition-wait :timeout :many-threads)
443             :skipped-on '(not :sb-thread))
444   (let* ((mutex (make-mutex))
445          (waitqueue (make-waitqueue))
446          (sem (make-semaphore))
447          (data nil)
448          (workers
449            (loop repeat 100
450                  collect (make-thread
451                           (lambda ()
452                             (wait-on-semaphore sem)
453                             (block thread
454                               (with-mutex (mutex)
455                                 (loop until data
456                                       do (or (condition-wait waitqueue mutex :timeout 0.01)
457                                              (return-from thread nil)))
458                                 (assert (eq t (pop data)))
459                                 t)))))))
460     (loop repeat 50
461           do (with-mutex (mutex)
462                (push t data)
463                (condition-notify waitqueue)))
464     (signal-semaphore sem 100)
465     (let ((ok (count-if #'join-thread workers)))
466       (unless (eql 50 ok)
467         (error "Wanted 50, got ~S" ok)))))
468
469 (with-test (:name (:wait-on-semaphore :timeout :one-thread))
470   (let ((sem (make-semaphore))
471         (n 0))
472     (signal-semaphore sem 10)
473     (loop repeat 100
474           do (when (wait-on-semaphore sem :timeout 0.001)
475                (incf n)))
476     (assert (= n 10))))
477
478 (with-test (:name (:wait-on-semaphore :timeout :many-threads)
479             :skipped-on '(not :sb-thread))
480   (let* ((sem (make-semaphore))
481          (threads
482            (progn
483              (signal-semaphore sem 10)
484              (loop repeat 100
485                    collect (make-thread
486                             (lambda ()
487                               (sleep (random 0.02))
488                               (wait-on-semaphore sem :timeout 0.5)))))))
489     (loop repeat 5
490           do (signal-semaphore sem 2))
491     (let ((ok (count-if #'join-thread threads)))
492       (unless (eql 20 ok)
493         (error "Wanted 20, got ~S" ok)))))
494
495 (with-test (:name (:join-thread :timeout)
496             :skipped-on '(not :sb-thread))
497   (assert (eq :error
498               (handler-case
499                   (join-thread (make-join-thread (lambda () (sleep 10))) :timeout 0.01)
500                 (join-thread-error ()
501                   :error))))
502   (let ((cookie (cons t t)))
503     (assert (eq cookie
504                 (join-thread (make-join-thread (lambda () (sleep 10)))
505                              :timeout 0.01
506                              :default cookie)))))
507
508 (with-test (:name (:semaphore-notification :wait-on-semaphore)
509             :skipped-on '(not :sb-thread))
510   (let ((sem (make-semaphore))
511         (ok nil)
512         (n 0))
513     (flet ((critical ()
514              (let ((note (make-semaphore-notification)))
515                (sb-sys:without-interrupts
516                  (unwind-protect
517                       (progn
518                         (sb-sys:with-local-interrupts
519                           (wait-on-semaphore sem :notification note)
520                           (sleep (random 0.1)))
521                         (incf n))
522                    ;; Re-increment on exit if we decremented it.
523                    (when (semaphore-notification-status note)
524                      (signal-semaphore sem))
525                    ;; KLUDGE: Prevent interrupts after this point from
526                    ;; unwinding us, so that we can reason about the counts.
527                    #+sb-thread
528                    (sb-thread::block-deferrable-signals))))))
529       (let* ((threads (loop for i from 1 upto 100
530                             collect (make-join-thread #'critical :name (format nil "T~A" i))))
531              (safe nil)
532              (unsafe nil)
533              (interruptor (make-thread (lambda ()
534                                          (loop until ok)
535                                          (let (x)
536                                            (dolist (thread threads)
537                                              (cond (x
538                                                     (push thread unsafe)
539                                                     (sleep (random 0.1))
540                                                     (ignore-errors
541                                                      (terminate-thread thread)))
542                                                    (t
543                                                     (push thread safe)))
544                                              (setf x (not x))))))))
545         (signal-semaphore sem)
546         (setf ok t)
547         (join-thread interruptor)
548         (mapc #'join-thread safe)
549         (let ((k (count-if (lambda (th)
550                              (join-thread th :default nil))
551                            unsafe)))
552           (assert (= n (+ k (length safe))))
553           (assert unsafe))))))
554
555 (with-test (:name (:semaphore-notification :try-sempahore)
556             :skipped-on '(not :sb-thread))
557   (let* ((sem (make-semaphore))
558          (note (make-semaphore-notification)))
559     (try-semaphore sem 1 note)
560     (assert (not (semaphore-notification-status note)))
561     (signal-semaphore sem)
562     (try-semaphore sem 1 note)
563     (assert (semaphore-notification-status note))))
564
565 (with-test (:name (:return-from-thread :normal-thread)
566             :skipped-on '(not :sb-thread))
567   (let* ((thread (make-thread (lambda ()
568                                 (return-from-thread (values 1 2 3))
569                                 :foo)))
570          (values (multiple-value-list (join-thread thread))))
571     (unless (equal (list 1 2 3) values)
572       (error "got ~S, wanted (1 2 3)" values))))
573
574 (with-test (:name (:return-from-thread :main-thread))
575   (assert (main-thread-p))
576   (assert (eq :oops
577               (handler-case
578                   (return-from-thread t)
579                 (thread-error ()
580                   :oops)))))
581
582 (with-test (:name (:abort-thread :normal-thread)
583             :skipped-on '(not :sb-thread))
584   (let ((thread (make-thread (lambda ()
585                                (abort-thread)
586                                :foo))))
587     (assert (eq :aborted! (join-thread thread :default :aborted!)))))
588
589 (with-test (:name (:abort-thread :main-thread))
590   (assert (main-thread-p))
591   (assert (eq :oops
592               (handler-case
593                   (abort-thread)
594                 (thread-error ()
595                   :oops)))))
596
597 ;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
598 ;; before entering WITHOUT-INTERRUPTS. When a thread which was
599 ;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
600 ;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
601 ;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
602 ;; interrupting code thus made a recursive lock attempt.
603 ;;
604 ;; See (:TIMER :DISPATCH-THREAD :MAKE-THREAD :BUG-1180102) in
605 ;; timer.impure.lisp.
606 (with-test (:name (make-thread :interrupt-with make-thread :bug-1180102)
607             :skipped-on '(not :sb-thread))
608   (dotimes (i 100)
609     (let ((threads '())
610           (parent *current-thread*))
611       (dotimes (i 100)
612         (push (make-thread
613                (lambda ()
614                  (interrupt-thread
615                   parent
616                   (lambda () (push (make-thread (lambda ())) threads)))))
617               threads)
618         (push (make-thread (lambda ())) threads))
619       (mapc #'join-thread threads))))