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 (assert (eql 1 (length (list-all-threads))))
18 (assert (eq *current-thread
*
19 (find (thread-name *current-thread
*) (list-all-threads)
20 :key
#'thread-name
:test
#'equal
)))
22 (assert (thread-alive-p *current-thread
*))
25 (interrupt-thread *current-thread
* (lambda () (setq a
1)))
28 (let ((spinlock (make-spinlock)))
29 (with-spinlock (spinlock)))
31 (let ((mutex (make-mutex)))
35 #-sb-thread
(sb-ext:quit
:unix-status
104)
37 (let ((old-threads (list-all-threads))
38 (thread (make-thread (lambda ()
39 (assert (find *current-thread
* *all-threads
*))
41 (new-threads (list-all-threads)))
42 (assert (thread-alive-p thread
))
43 (assert (eq thread
(first new-threads
)))
44 (assert (= (1+ (length old-threads
)) (length new-threads
)))
46 (assert (not (thread-alive-p thread
))))
48 ;;; We had appalling scaling properties for a while. Make sure they
50 (defun scaling-test (function &optional
(nthreads 5))
51 "Execute FUNCTION with NTHREADS lurking to slow it down."
52 (let ((queue (sb-thread:make-waitqueue
))
53 (mutex (sb-thread:make-mutex
)))
54 ;; Start NTHREADS idle threads.
56 (sb-thread:make-thread
(lambda ()
57 (sb-thread:condition-wait queue mutex
)
59 (let ((start-time (get-internal-run-time)))
61 (prog1 (- (get-internal-run-time) start-time
)
62 (sb-thread:condition-broadcast queue
)))))
64 "A function that does work with the CPU."
65 (if (zerop n
) 1 (* n
(fact (1- n
)))))
66 (let ((work (lambda () (fact 15000))))
67 (let ((zero (scaling-test work
0))
68 (four (scaling-test work
4)))
69 ;; a slightly weak assertion, but good enough for starters.
70 (assert (< four
(* 1.5 zero
)))))
72 ;;; For one of the interupt-thread tests, we want a foreign function
73 ;;; that does not make syscalls
75 (with-open-file (o "threads-foreign.c" :direction
:output
:if-exists
:supersede
)
76 (format o
"void loop_forever() { while(1) ; }~%"))
79 (or #+linux
'("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
80 (error "Missing shared library compilation options for this platform"))
82 (sb-alien:load-shared-object
"threads-foreign.so")
83 (sb-alien:define-alien-routine loop-forever sb-alien
:void
)
86 ;;; elementary "can we get a lock and release it again"
87 (let ((l (make-mutex :name
"foo"))
89 (assert (eql (mutex-value l
) nil
) nil
"1")
90 (sb-thread:get-mutex l
)
91 (assert (eql (mutex-value l
) p
) nil
"3")
92 (sb-thread:release-mutex l
)
93 (assert (eql (mutex-value l
) nil
) nil
"5"))
95 (labels ((ours-p (value)
96 (sb-vm:control-stack-pointer-valid-p
97 (sb-sys:int-sap
(sb-kernel:get-lisp-obj-address value
)))))
98 (let ((l (make-mutex :name
"rec")))
99 (assert (eql (mutex-value l
) nil
) nil
"1")
100 (sb-thread:with-recursive-lock
(l)
101 (assert (ours-p (mutex-value l
)) nil
"3")
102 (sb-thread:with-recursive-lock
(l)
103 (assert (ours-p (mutex-value l
)) nil
"4"))
104 (assert (ours-p (mutex-value l
)) nil
"5"))
105 (assert (eql (mutex-value l
) nil
) nil
"6")))
107 (let ((l (make-spinlock :name
"spinlock"))
108 (p *current-thread
*))
109 (assert (eql (spinlock-value l
) 0) nil
"1")
111 (assert (eql (spinlock-value l
) p
) nil
"2"))
112 (assert (eql (spinlock-value l
) 0) nil
"3"))
114 ;; test that SLEEP actually sleeps for at least the given time, even
115 ;; if interrupted by another thread exiting/a gc/anything
116 (let ((start-time (get-universal-time)))
117 (make-thread (lambda () (sleep 1) (sb-ext:gc
:full t
)))
119 (assert (>= (get-universal-time) (+ 5 start-time
))))
122 (let ((queue (make-waitqueue :name
"queue"))
123 (lock (make-mutex :name
"lock"))
125 (labels ((in-new-thread ()
127 (assert (eql (mutex-value lock
) *current-thread
*))
128 (format t
"~A got mutex~%" *current-thread
*)
129 ;; now drop it and sleep
130 (condition-wait queue lock
)
131 ;; after waking we should have the lock again
132 (assert (eql (mutex-value lock
) *current-thread
*))
135 (make-thread #'in-new-thread
)
136 (sleep 2) ; give it a chance to start
137 ;; check the lock is free while it's asleep
138 (format t
"parent thread ~A~%" *current-thread
*)
139 (assert (eql (mutex-value lock
) nil
))
142 (condition-notify queue
))
145 (let ((queue (make-waitqueue :name
"queue"))
146 (lock (make-mutex :name
"lock")))
147 (labels ((ours-p (value)
148 (sb-vm:control-stack-pointer-valid-p
149 (sb-sys:int-sap
(sb-kernel:get-lisp-obj-address value
))))
151 (with-recursive-lock (lock)
152 (assert (ours-p (mutex-value lock
)))
153 (format t
"~A got mutex~%" (mutex-value lock
))
154 ;; now drop it and sleep
155 (condition-wait queue lock
)
156 ;; after waking we should have the lock again
157 (format t
"woken, ~A got mutex~%" (mutex-value lock
))
158 (assert (ours-p (mutex-value lock
))))))
159 (make-thread #'in-new-thread
)
160 (sleep 2) ; give it a chance to start
161 ;; check the lock is free while it's asleep
162 (format t
"parent thread ~A~%" *current-thread
*)
163 (assert (eql (mutex-value lock
) nil
))
164 (with-recursive-lock (lock)
165 (condition-notify queue
))
168 (let ((mutex (make-mutex :name
"contended")))
170 (let ((me *current-thread
*))
174 (assert (eql (mutex-value mutex
) me
)))
175 (assert (not (eql (mutex-value mutex
) me
))))
176 (format t
"done ~A~%" *current-thread
*))))
177 (let ((kid1 (make-thread #'run
))
178 (kid2 (make-thread #'run
)))
179 (format t
"contention ~A ~A~%" kid1 kid2
))))
181 (defun test-interrupt (function-to-interrupt &optional quit-p
)
182 (let ((child (make-thread function-to-interrupt
)))
183 ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
185 (format t
"interrupting child ~A~%" child
)
186 (interrupt-thread child
188 (format t
"child pid ~A~%" *current-thread
*)
189 (when quit-p
(sb-ext:quit
))))
193 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
194 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
197 (let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child
))
199 (test-interrupt #'loop-forever
:quit
)
201 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
202 (terminate-thread child
))
204 (let ((lock (make-mutex :name
"loctite"))
207 (setf child
(test-interrupt
210 (assert (eql (mutex-value lock
) *current-thread
*)))
211 (assert (not (eql (mutex-value lock
) *current-thread
*)))
213 ;;hold onto lock for long enough that child can't get it immediately
215 (interrupt-thread child
(lambda () (format t
"l ~A~%" (mutex-value lock
))))
216 (format t
"parent releasing lock~%"))
217 (terminate-thread child
))
219 (format t
"~&locking test done~%")
221 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
224 (let ((thread (sb-thread:make-thread
(lambda () (loop (alloc-stuff))))))
226 (loop repeat
4 collect
227 (sb-thread:make-thread
233 (sb-thread:interrupt-thread
236 (loop while
(some #'thread-alive-p killers
) do
(sleep 0.1))
237 (sb-thread:terminate-thread thread
)))
240 (format t
"~&multi interrupt test done~%")
242 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
243 ;; NB this only works on x86: other ports don't have a symbol for
244 ;; pseudo-atomic atomicity
245 (format t
"new thread ~A~%" c
)
250 (princ ".") (force-output)
251 (assert (eq (thread-state *current-thread
*) :running
))
252 (assert (zerop SB-KERNEL
:*PSEUDO-ATOMIC-ATOMIC
*)))))
253 (terminate-thread c
))
255 (format t
"~&interrupt test done~%")
257 (defparameter *interrupt-count
* 0)
259 (declaim (notinline check-interrupt-count
))
260 (defun check-interrupt-count (i)
261 (declare (optimize (debug 1) (speed 1)))
262 ;; This used to lose if eflags were not restored after an interrupt.
263 (unless (typep i
'fixnum
)
264 (error "!!!!!!!!!!!")))
266 (let ((c (make-thread
268 (handler-bind ((error #'(lambda (cond)
271 most-positive-fixnum
))))
272 (loop (check-interrupt-count *interrupt-count
*)))))))
273 (let ((func (lambda ()
276 (sb-impl::atomic-incf
/symbol
*interrupt-count
*))))
277 (setq *interrupt-count
* 0)
280 (interrupt-thread c func
))
282 (assert (= 100 *interrupt-count
*))
283 (terminate-thread c
)))
285 (format t
"~&interrupt count test done~%")
288 (make-thread (lambda ()
290 (sb-ext:gc
) (princ "\\") (force-output))
292 (make-thread (lambda ()
295 (princ "/") (force-output))
298 (when (and a-done b-done
) (return))
303 (defun waste (&optional
(n 100000))
304 (loop repeat n do
(make-string 16384)))
306 (loop for i below
100 do
309 (sb-thread:make-thread
317 (defparameter *aaa
* nil
)
318 (loop for i below
100 do
321 (sb-thread:make-thread
323 (let ((*aaa
* (waste)))
325 (let ((*aaa
* (waste)))
329 (format t
"~&gc test done~%")
331 ;; this used to deadlock on session-lock
332 (sb-thread:make-thread
(lambda () (sb-ext:gc
)))
333 ;; expose thread creation races by exiting quickly
334 (sb-thread:make-thread
(lambda ()))
336 (defun exercise-syscall (fn reference-errno
)
337 (sb-thread:make-thread
341 (let ((errno (sb-unix::get-errno
)))
343 (unless (eql errno reference-errno
)
344 (format t
"Got errno: ~A (~A) instead of ~A~%"
349 (sb-ext:quit
:unix-status
1)))))))
351 (let* ((nanosleep-errno (progn
352 (sb-unix:nanosleep -
1 0)
353 (sb-unix::get-errno
)))
356 :if-does-not-exist nil
)
357 (sb-unix::get-errno
)))
360 (exercise-syscall (lambda () (sb-unix:nanosleep -
1 0)) nanosleep-errno
)
361 (exercise-syscall (lambda () (open "no-such-file"
362 :if-does-not-exist nil
))
364 (sb-thread:make-thread
(lambda () (loop (sb-ext:gc
) (sleep 1)))))))
366 (princ "terminating threads")
367 (dolist (thread threads
)
368 (sb-thread:terminate-thread thread
)))
370 (format t
"~&errno test done~%")
373 (let ((thread (sb-thread:make-thread
(lambda () (sleep 0.1)))))
374 (sb-thread:interrupt-thread
377 (assert (find-restart 'sb-thread
:terminate-thread
))))))
381 (format t
"~&thread startup sigmask test done~%")
383 (sb-debug::enable-debugger
)
384 (let* ((main-thread *current-thread
*)
386 (make-thread (lambda ()
388 (interrupt-thread main-thread
#'break
)
390 (interrupt-thread main-thread
#'continue
)))))
391 (with-session-lock (*session
*)
393 (loop while
(thread-alive-p interruptor-thread
)))
395 (format t
"~&session lock test done~%")
396 #|
;; a cll post from eric marsden
398 |
(setq *debugger-hook
*
399 |
(lambda (condition old-debugger-hook
)
400 |
(debug:backtrace
10)
401 |
(unix:unix-exit
2)))
403 |
(mp::start-sigalrm-yield
)
404 |
(flet ((roomy () (loop (with-output-to-string (*standard-output
*) (room)))))
405 |
(mp:make-process
#'roomy
)
406 |
(mp:make-process
#'roomy
)))
409 ;; give the other thread time to die before we leave, otherwise the
410 ;; overall exit status is 0, not 104
413 (sb-ext:quit
:unix-status
104)