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 (in-package "SB-THREAD") ; this is white-box testing, really
16 (use-package :test-util
)
18 (defun wait-for-threads (threads)
19 (loop while
(some #'sb-thread
:thread-alive-p threads
) do
(sleep 0.01)))
21 (assert (eql 1 (length (list-all-threads))))
23 (assert (eq *current-thread
*
24 (find (thread-name *current-thread
*) (list-all-threads)
25 :key
#'thread-name
:test
#'equal
)))
27 (assert (thread-alive-p *current-thread
*))
30 (interrupt-thread *current-thread
* (lambda () (setq a
1)))
33 (let ((spinlock (make-spinlock)))
34 (with-spinlock (spinlock)))
36 (let ((mutex (make-mutex)))
40 #-sb-thread
(sb-ext:quit
:unix-status
104)
42 (let ((old-threads (list-all-threads))
43 (thread (make-thread (lambda ()
44 (assert (find *current-thread
* *all-threads
*))
46 (new-threads (list-all-threads)))
47 (assert (thread-alive-p thread
))
48 (assert (eq thread
(first new-threads
)))
49 (assert (= (1+ (length old-threads
)) (length new-threads
)))
51 (assert (not (thread-alive-p thread
))))
53 ;;; We had appalling scaling properties for a while. Make sure they
55 (defun scaling-test (function &optional
(nthreads 5))
56 "Execute FUNCTION with NTHREADS lurking to slow it down."
57 (let ((queue (sb-thread:make-waitqueue
))
58 (mutex (sb-thread:make-mutex
)))
59 ;; Start NTHREADS idle threads.
61 (sb-thread:make-thread
(lambda ()
63 (sb-thread:condition-wait queue mutex
))
65 (let ((start-time (get-internal-run-time)))
67 (prog1 (- (get-internal-run-time) start-time
)
68 (sb-thread:condition-broadcast queue
)))))
70 "A function that does work with the CPU."
71 (if (zerop n
) 1 (* n
(fact (1- n
)))))
72 (let ((work (lambda () (fact 15000))))
73 (let ((zero (scaling-test work
0))
74 (four (scaling-test work
4)))
75 ;; a slightly weak assertion, but good enough for starters.
76 (assert (< four
(* 1.5 zero
)))))
78 ;;; For one of the interupt-thread tests, we want a foreign function
79 ;;; that does not make syscalls
81 (with-open-file (o "threads-foreign.c" :direction
:output
:if-exists
:supersede
)
82 (format o
"void loop_forever() { while(1) ; }~%"))
85 (or #+linux
'("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
86 (error "Missing shared library compilation options for this platform"))
88 (sb-alien:load-shared-object
"threads-foreign.so")
89 (sb-alien:define-alien-routine loop-forever sb-alien
:void
)
92 ;;; elementary "can we get a lock and release it again"
93 (let ((l (make-mutex :name
"foo"))
95 (assert (eql (mutex-value l
) nil
) nil
"1")
96 (sb-thread:get-mutex l
)
97 (assert (eql (mutex-value l
) p
) nil
"3")
98 (sb-thread:release-mutex l
)
99 (assert (eql (mutex-value l
) nil
) nil
"5"))
101 (labels ((ours-p (value)
102 (eq *current-thread
* value
)))
103 (let ((l (make-mutex :name
"rec")))
104 (assert (eql (mutex-value l
) nil
) nil
"1")
105 (sb-thread:with-recursive-lock
(l)
106 (assert (ours-p (mutex-value l
)) nil
"3")
107 (sb-thread:with-recursive-lock
(l)
108 (assert (ours-p (mutex-value l
)) nil
"4"))
109 (assert (ours-p (mutex-value l
)) nil
"5"))
110 (assert (eql (mutex-value l
) nil
) nil
"6")))
112 (with-test (:name
(:mutex
:nesting-mutex-and-recursive-lock
))
113 (let ((l (make-mutex :name
"a mutex")))
115 (with-recursive-lock (l)))))
117 (let ((l (make-spinlock :name
"spinlock"))
118 (p *current-thread
*))
119 (assert (eql (spinlock-value l
) 0) nil
"1")
121 (assert (eql (spinlock-value l
) p
) nil
"2"))
122 (assert (eql (spinlock-value l
) 0) nil
"3"))
124 ;; test that SLEEP actually sleeps for at least the given time, even
125 ;; if interrupted by another thread exiting/a gc/anything
126 (let ((start-time (get-universal-time)))
127 (make-thread (lambda () (sleep 1) (sb-ext:gc
:full t
)))
129 (assert (>= (get-universal-time) (+ 5 start-time
))))
132 (let ((queue (make-waitqueue :name
"queue"))
133 (lock (make-mutex :name
"lock"))
135 (labels ((in-new-thread ()
137 (assert (eql (mutex-value lock
) *current-thread
*))
138 (format t
"~A got mutex~%" *current-thread
*)
139 ;; now drop it and sleep
140 (condition-wait queue lock
)
141 ;; after waking we should have the lock again
142 (assert (eql (mutex-value lock
) *current-thread
*))
145 (make-thread #'in-new-thread
)
146 (sleep 2) ; give it a chance to start
147 ;; check the lock is free while it's asleep
148 (format t
"parent thread ~A~%" *current-thread
*)
149 (assert (eql (mutex-value lock
) nil
))
152 (condition-notify queue
))
155 (let ((queue (make-waitqueue :name
"queue"))
156 (lock (make-mutex :name
"lock")))
157 (labels ((ours-p (value)
158 (eq *current-thread
* value
))
160 (with-recursive-lock (lock)
161 (assert (ours-p (mutex-value lock
)))
162 (format t
"~A got mutex~%" (mutex-value lock
))
163 ;; now drop it and sleep
164 (condition-wait queue lock
)
165 ;; after waking we should have the lock again
166 (format t
"woken, ~A got mutex~%" (mutex-value lock
))
167 (assert (ours-p (mutex-value lock
))))))
168 (make-thread #'in-new-thread
)
169 (sleep 2) ; give it a chance to start
170 ;; check the lock is free while it's asleep
171 (format t
"parent thread ~A~%" *current-thread
*)
172 (assert (eql (mutex-value lock
) nil
))
173 (with-recursive-lock (lock)
174 (condition-notify queue
))
177 (let ((mutex (make-mutex :name
"contended")))
179 (let ((me *current-thread
*))
183 (assert (eql (mutex-value mutex
) me
)))
184 (assert (not (eql (mutex-value mutex
) me
))))
185 (format t
"done ~A~%" *current-thread
*))))
186 (let ((kid1 (make-thread #'run
))
187 (kid2 (make-thread #'run
)))
188 (format t
"contention ~A ~A~%" kid1 kid2
)
189 (wait-for-threads (list kid1 kid2
)))))
193 (defmacro raises-timeout-p
(&body body
)
194 `(handler-case (progn (progn ,@body
) nil
)
195 (sb-ext:timeout
() t
)))
197 (with-test (:name
(:semaphore
:wait-forever
))
198 (let ((sem (make-semaphore :count
0)))
199 (assert (raises-timeout-p
200 (sb-ext:with-timeout
0.1
201 (wait-on-semaphore sem
))))))
203 (with-test (:name
(:semaphore
:initial-count
))
204 (let ((sem (make-semaphore :count
1)))
205 (sb-ext:with-timeout
0.1
206 (wait-on-semaphore sem
))))
208 (with-test (:name
(:semaphore
:wait-then-signal
))
209 (let ((sem (make-semaphore))
211 (make-thread (lambda ()
214 (signal-semaphore sem
)))
215 (wait-on-semaphore sem
)
216 (assert signalled-p
)))
218 (with-test (:name
(:semaphore
:signal-then-wait
))
219 (let ((sem (make-semaphore))
221 (make-thread (lambda ()
222 (signal-semaphore sem
)
223 (setq signalled-p t
)))
224 (loop until signalled-p
)
225 (wait-on-semaphore sem
)
226 (assert signalled-p
)))
228 (with-test (:name
(:semaphore
:multiple-signals
))
229 (let* ((sem (make-semaphore :count
5))
230 (threads (loop repeat
20
231 collect
(make-thread (lambda ()
232 (wait-on-semaphore sem
))))))
233 (flet ((count-live-threads ()
234 (count-if #'thread-alive-p threads
)))
236 (assert (= 15 (count-live-threads)))
237 (signal-semaphore sem
10)
239 (assert (= 5 (count-live-threads)))
240 (signal-semaphore sem
3)
242 (assert (= 2 (count-live-threads)))
243 (signal-semaphore sem
4)
245 (assert (= 0 (count-live-threads))))))
247 (format t
"~&semaphore tests done~%")
249 (defun test-interrupt (function-to-interrupt &optional quit-p
)
250 (let ((child (make-thread function-to-interrupt
)))
251 ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
253 (format t
"interrupting child ~A~%" child
)
254 (interrupt-thread child
256 (format t
"child pid ~A~%" *current-thread
*)
257 (when quit-p
(sb-ext:quit
))))
261 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
262 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
265 (let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child
))
267 (test-interrupt #'loop-forever
:quit
)
269 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
270 (terminate-thread child
)
271 (wait-for-threads (list child
)))
273 (let ((lock (make-mutex :name
"loctite"))
276 (setf child
(test-interrupt
279 (assert (eql (mutex-value lock
) *current-thread
*)))
280 (assert (not (eql (mutex-value lock
) *current-thread
*)))
282 ;;hold onto lock for long enough that child can't get it immediately
284 (interrupt-thread child
(lambda () (format t
"l ~A~%" (mutex-value lock
))))
285 (format t
"parent releasing lock~%"))
286 (terminate-thread child
)
287 (wait-for-threads (list child
)))
289 (format t
"~&locking test done~%")
291 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
294 (let ((thread (sb-thread:make-thread
(lambda () (loop (alloc-stuff))))))
296 (loop repeat
4 collect
297 (sb-thread:make-thread
300 (sleep (random 0.1d0
))
303 (sb-thread:interrupt-thread thread
(lambda ()))))))))
304 (wait-for-threads killers
)
305 (sb-thread:terminate-thread thread
)
306 (wait-for-threads (list thread
))))
309 (format t
"~&multi interrupt test done~%")
311 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
312 ;; NB this only works on x86: other ports don't have a symbol for
313 ;; pseudo-atomic atomicity
315 (sleep (random 0.1d0
))
318 (princ ".") (force-output)
319 (assert (thread-alive-p *current-thread
*))
320 (assert (zerop SB-KERNEL
:*PSEUDO-ATOMIC-ATOMIC
*)))))
322 (wait-for-threads (list c
)))
324 (format t
"~&interrupt test done~%")
326 (defparameter *interrupt-count
* 0)
328 (declaim (notinline check-interrupt-count
))
329 (defun check-interrupt-count (i)
330 (declare (optimize (debug 1) (speed 1)))
331 ;; This used to lose if eflags were not restored after an interrupt.
332 (unless (typep i
'fixnum
)
333 (error "!!!!!!!!!!!")))
335 (let ((c (make-thread
337 (handler-bind ((error #'(lambda (cond)
340 most-positive-fixnum
))))
341 (loop (check-interrupt-count *interrupt-count
*)))))))
342 (let ((func (lambda ()
345 (sb-impl::atomic-incf
/symbol
*interrupt-count
*))))
346 (setq *interrupt-count
* 0)
348 (sleep (random 0.1d0
))
349 (interrupt-thread c func
))
350 (loop until
(= *interrupt-count
* 100) do
(sleep 0.1))
352 (wait-for-threads (list c
))))
354 (format t
"~&interrupt count test done~%")
357 (make-thread (lambda ()
359 (sb-ext:gc
) (princ "\\") (force-output))
361 (make-thread (lambda ()
364 (princ "/") (force-output))
367 (when (and a-done b-done
) (return))
372 (defun waste (&optional
(n 100000))
373 (loop repeat n do
(make-string 16384)))
375 (loop for i below
100 do
378 (sb-thread:make-thread
386 (defparameter *aaa
* nil
)
387 (loop for i below
100 do
390 (sb-thread:make-thread
392 (let ((*aaa
* (waste)))
394 (let ((*aaa
* (waste)))
398 (format t
"~&gc test done~%")
400 ;; this used to deadlock on session-lock
401 (sb-thread:make-thread
(lambda () (sb-ext:gc
)))
402 ;; expose thread creation races by exiting quickly
403 (sb-thread:make-thread
(lambda ()))
405 (defun exercise-syscall (fn reference-errno
)
406 (sb-thread:make-thread
410 (let ((errno (sb-unix::get-errno
)))
411 (sleep (random 0.1d0
))
412 (unless (eql errno reference-errno
)
413 (format t
"Got errno: ~A (~A) instead of ~A~%"
418 (sb-ext:quit
:unix-status
1)))))))
420 (let* ((nanosleep-errno (progn
421 (sb-unix:nanosleep -
1 0)
422 (sb-unix::get-errno
)))
425 :if-does-not-exist nil
)
426 (sb-unix::get-errno
)))
429 (exercise-syscall (lambda () (sb-unix:nanosleep -
1 0)) nanosleep-errno
)
430 (exercise-syscall (lambda () (open "no-such-file"
431 :if-does-not-exist nil
))
433 (sb-thread:make-thread
(lambda () (loop (sb-ext:gc
) (sleep 1)))))))
435 (princ "terminating threads")
436 (dolist (thread threads
)
437 (sb-thread:terminate-thread thread
)))
439 (format t
"~&errno test done~%")
442 (let ((thread (sb-thread:make-thread
(lambda () (sleep 0.1)))))
443 (sb-thread:interrupt-thread
446 (assert (find-restart 'sb-thread
:terminate-thread
))))))
450 (format t
"~&thread startup sigmask test done~%")
452 (sb-debug::enable-debugger
)
453 (let* ((main-thread *current-thread
*)
455 (make-thread (lambda ()
457 (interrupt-thread main-thread
#'break
)
459 (interrupt-thread main-thread
#'continue
)))))
460 (with-session-lock (*session
*)
462 (loop while
(thread-alive-p interruptor-thread
)))
464 (format t
"~&session lock test done~%")
468 (loop for i below
100 collect
469 (sb-thread:make-thread
(lambda ())))))
471 (format t
"~&creation test done~%")
473 ;; watch out for *current-thread* being the parent thread after exit
475 (thread (sb-thread:make-thread
477 (setq sap
(thread-sap-for-id
478 (thread-os-thread *current-thread
*)))))))
479 (wait-for-threads (list thread
))
480 (assert (null (symbol-value-in-thread 'sb-thread
:*current-thread
*
483 ;; interrupt handlers are per-thread with pthreads, make sure the
484 ;; handler installed in one thread is global
485 (sb-thread:make-thread
487 (sb-ext:run-program
"sleep" '("1") :search t
:wait nil
)))
489 (with-test (:name
(:thread-start
:dynamic-values-and-gc
))
490 (let ((gc-thread (sb-thread:make-thread
(lambda ()
491 (loop (sleep (random 0.2))
492 (sb-ext:gc
:full t
))))))
494 (loop for i below
3000
495 when
(zerop (mod i
30))
498 (let ((*x
* (lambda ())))
499 (declare (special *x
*))
500 (sb-thread:make-thread
(lambda () (functionp *x
*))))))
501 (sb-thread:terminate-thread gc-thread
)
504 #|
;; a cll post from eric marsden
506 |
(setq *debugger-hook
*
507 |
(lambda (condition old-debugger-hook
)
508 |
(debug:backtrace
10)
509 |
(unix:unix-exit
2)))
511 |
(mp::start-sigalrm-yield
)
512 |
(flet ((roomy () (loop (with-output-to-string (*standard-output
*) (room)))))
513 |
(mp:make-process
#'roomy
)
514 |
(mp:make-process
#'roomy
)))