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 (defun wait-for-threads (threads)
17 (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
19 (assert (eql 1 (length (list-all-threads))))
21 (assert (eq *current-thread*
22 (find (thread-name *current-thread*) (list-all-threads)
23 :key #'thread-name :test #'equal)))
25 (assert (thread-alive-p *current-thread*))
28 (interrupt-thread *current-thread* (lambda () (setq a 1)))
31 (let ((spinlock (make-spinlock)))
32 (with-spinlock (spinlock)))
34 (let ((mutex (make-mutex)))
38 #-sb-thread (sb-ext:quit :unix-status 104)
40 (let ((old-threads (list-all-threads))
41 (thread (make-thread (lambda ()
42 (assert (find *current-thread* *all-threads*))
44 (new-threads (list-all-threads)))
45 (assert (thread-alive-p thread))
46 (assert (eq thread (first new-threads)))
47 (assert (= (1+ (length old-threads)) (length new-threads)))
49 (assert (not (thread-alive-p thread))))
51 ;;; We had appalling scaling properties for a while. Make sure they
53 (defun scaling-test (function &optional (nthreads 5))
54 "Execute FUNCTION with NTHREADS lurking to slow it down."
55 (let ((queue (sb-thread:make-waitqueue))
56 (mutex (sb-thread:make-mutex)))
57 ;; Start NTHREADS idle threads.
59 (sb-thread:make-thread (lambda ()
61 (sb-thread:condition-wait queue mutex))
63 (let ((start-time (get-internal-run-time)))
65 (prog1 (- (get-internal-run-time) start-time)
66 (sb-thread:condition-broadcast queue)))))
68 "A function that does work with the CPU."
69 (if (zerop n) 1 (* n (fact (1- n)))))
70 (let ((work (lambda () (fact 15000))))
71 (let ((zero (scaling-test work 0))
72 (four (scaling-test work 4)))
73 ;; a slightly weak assertion, but good enough for starters.
74 (assert (< four (* 1.5 zero)))))
76 ;;; For one of the interupt-thread tests, we want a foreign function
77 ;;; that does not make syscalls
79 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
80 (format o "void loop_forever() { while(1) ; }~%"))
83 (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
84 (error "Missing shared library compilation options for this platform"))
86 (sb-alien:load-shared-object "threads-foreign.so")
87 (sb-alien:define-alien-routine loop-forever sb-alien:void)
90 ;;; elementary "can we get a lock and release it again"
91 (let ((l (make-mutex :name "foo"))
93 (assert (eql (mutex-value l) nil) nil "1")
94 (sb-thread:get-mutex l)
95 (assert (eql (mutex-value l) p) nil "3")
96 (sb-thread:release-mutex l)
97 (assert (eql (mutex-value l) nil) nil "5"))
99 (labels ((ours-p (value)
100 (sb-vm:control-stack-pointer-valid-p
101 (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))))
102 (let ((l (make-mutex :name "rec")))
103 (assert (eql (mutex-value l) nil) nil "1")
104 (sb-thread:with-recursive-lock (l)
105 (assert (ours-p (mutex-value l)) nil "3")
106 (sb-thread:with-recursive-lock (l)
107 (assert (ours-p (mutex-value l)) nil "4"))
108 (assert (ours-p (mutex-value l)) nil "5"))
109 (assert (eql (mutex-value l) nil) nil "6")))
111 (let ((l (make-spinlock :name "spinlock"))
112 (p *current-thread*))
113 (assert (eql (spinlock-value l) 0) nil "1")
115 (assert (eql (spinlock-value l) p) nil "2"))
116 (assert (eql (spinlock-value l) 0) nil "3"))
118 ;; test that SLEEP actually sleeps for at least the given time, even
119 ;; if interrupted by another thread exiting/a gc/anything
120 (let ((start-time (get-universal-time)))
121 (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
123 (assert (>= (get-universal-time) (+ 5 start-time))))
126 (let ((queue (make-waitqueue :name "queue"))
127 (lock (make-mutex :name "lock"))
129 (labels ((in-new-thread ()
131 (assert (eql (mutex-value lock) *current-thread*))
132 (format t "~A got mutex~%" *current-thread*)
133 ;; now drop it and sleep
134 (condition-wait queue lock)
135 ;; after waking we should have the lock again
136 (assert (eql (mutex-value lock) *current-thread*))
139 (make-thread #'in-new-thread)
140 (sleep 2) ; give it a chance to start
141 ;; check the lock is free while it's asleep
142 (format t "parent thread ~A~%" *current-thread*)
143 (assert (eql (mutex-value lock) nil))
146 (condition-notify queue))
149 (let ((queue (make-waitqueue :name "queue"))
150 (lock (make-mutex :name "lock")))
151 (labels ((ours-p (value)
152 (sb-vm:control-stack-pointer-valid-p
153 (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
155 (with-recursive-lock (lock)
156 (assert (ours-p (mutex-value lock)))
157 (format t "~A got mutex~%" (mutex-value lock))
158 ;; now drop it and sleep
159 (condition-wait queue lock)
160 ;; after waking we should have the lock again
161 (format t "woken, ~A got mutex~%" (mutex-value lock))
162 (assert (ours-p (mutex-value lock))))))
163 (make-thread #'in-new-thread)
164 (sleep 2) ; give it a chance to start
165 ;; check the lock is free while it's asleep
166 (format t "parent thread ~A~%" *current-thread*)
167 (assert (eql (mutex-value lock) nil))
168 (with-recursive-lock (lock)
169 (condition-notify queue))
172 (let ((mutex (make-mutex :name "contended")))
174 (let ((me *current-thread*))
178 (assert (eql (mutex-value mutex) me)))
179 (assert (not (eql (mutex-value mutex) me))))
180 (format t "done ~A~%" *current-thread*))))
181 (let ((kid1 (make-thread #'run))
182 (kid2 (make-thread #'run)))
183 (format t "contention ~A ~A~%" kid1 kid2)
184 (wait-for-threads (list kid1 kid2)))))
186 (defun test-interrupt (function-to-interrupt &optional quit-p)
187 (let ((child (make-thread function-to-interrupt)))
188 ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
190 (format t "interrupting child ~A~%" child)
191 (interrupt-thread child
193 (format t "child pid ~A~%" *current-thread*)
194 (when quit-p (sb-ext:quit))))
198 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
199 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
202 (let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child))
204 (test-interrupt #'loop-forever :quit)
206 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
207 (terminate-thread child)
208 (wait-for-threads (list child)))
210 (let ((lock (make-mutex :name "loctite"))
213 (setf child (test-interrupt
216 (assert (eql (mutex-value lock) *current-thread*)))
217 (assert (not (eql (mutex-value lock) *current-thread*)))
219 ;;hold onto lock for long enough that child can't get it immediately
221 (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
222 (format t "parent releasing lock~%"))
223 (terminate-thread child)
224 (wait-for-threads (list child)))
226 (format t "~&locking test done~%")
228 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
231 (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
233 (loop repeat 4 collect
234 (sb-thread:make-thread
237 (sleep (random 0.1d0))
240 (sb-thread:interrupt-thread thread (lambda ()))))))))
241 (wait-for-threads killers)
242 (sb-thread:terminate-thread thread)
243 (wait-for-threads (list thread))))
246 (format t "~&multi interrupt test done~%")
248 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
249 ;; NB this only works on x86: other ports don't have a symbol for
250 ;; pseudo-atomic atomicity
252 (sleep (random 0.1d0))
255 (princ ".") (force-output)
256 (assert (eq (thread-state *current-thread*) :running))
257 (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
259 (wait-for-threads (list c)))
261 (format t "~&interrupt test done~%")
263 (defparameter *interrupt-count* 0)
265 (declaim (notinline check-interrupt-count))
266 (defun check-interrupt-count (i)
267 (declare (optimize (debug 1) (speed 1)))
268 ;; This used to lose if eflags were not restored after an interrupt.
269 (unless (typep i 'fixnum)
270 (error "!!!!!!!!!!!")))
272 (let ((c (make-thread
274 (handler-bind ((error #'(lambda (cond)
277 most-positive-fixnum))))
278 (loop (check-interrupt-count *interrupt-count*)))))))
279 (let ((func (lambda ()
282 (sb-impl::atomic-incf/symbol *interrupt-count*))))
283 (setq *interrupt-count* 0)
285 (sleep (random 0.1d0))
286 (interrupt-thread c func))
287 (loop until (= *interrupt-count* 100) do (sleep 0.1))
289 (wait-for-threads (list c))))
291 (format t "~&interrupt count test done~%")
294 (make-thread (lambda ()
296 (sb-ext:gc) (princ "\\") (force-output))
298 (make-thread (lambda ()
301 (princ "/") (force-output))
304 (when (and a-done b-done) (return))
309 (defun waste (&optional (n 100000))
310 (loop repeat n do (make-string 16384)))
312 (loop for i below 100 do
315 (sb-thread:make-thread
323 (defparameter *aaa* nil)
324 (loop for i below 100 do
327 (sb-thread:make-thread
329 (let ((*aaa* (waste)))
331 (let ((*aaa* (waste)))
335 (format t "~&gc test done~%")
337 ;; this used to deadlock on session-lock
338 (sb-thread:make-thread (lambda () (sb-ext:gc)))
339 ;; expose thread creation races by exiting quickly
340 (sb-thread:make-thread (lambda ()))
342 (defun exercise-syscall (fn reference-errno)
343 (sb-thread:make-thread
347 (let ((errno (sb-unix::get-errno)))
348 (sleep (random 0.1d0))
349 (unless (eql errno reference-errno)
350 (format t "Got errno: ~A (~A) instead of ~A~%"
355 (sb-ext:quit :unix-status 1)))))))
357 (let* ((nanosleep-errno (progn
358 (sb-unix:nanosleep -1 0)
359 (sb-unix::get-errno)))
362 :if-does-not-exist nil)
363 (sb-unix::get-errno)))
366 (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
367 (exercise-syscall (lambda () (open "no-such-file"
368 :if-does-not-exist nil))
370 (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
372 (princ "terminating threads")
373 (dolist (thread threads)
374 (sb-thread:terminate-thread thread)))
376 (format t "~&errno test done~%")
379 (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
380 (sb-thread:interrupt-thread
383 (assert (find-restart 'sb-thread:terminate-thread))))))
387 (format t "~&thread startup sigmask test done~%")
389 (sb-debug::enable-debugger)
390 (let* ((main-thread *current-thread*)
392 (make-thread (lambda ()
394 (interrupt-thread main-thread #'break)
396 (interrupt-thread main-thread #'continue)))))
397 (with-session-lock (*session*)
399 (loop while (thread-alive-p interruptor-thread)))
401 (format t "~&session lock test done~%")
406 (loop for i below 100 collect
407 (sb-thread:make-thread (lambda ()))))
412 (format t "~&creation test done~%")
414 ;; watch out for *current-thread* being the parent thread after exit
415 (let ((thread (sb-thread:make-thread (lambda ()))))
416 (wait-for-threads (list thread))
417 (assert (null (symbol-value-in-thread 'sb-thread:*current-thread*
420 #| ;; a cll post from eric marsden
422 | (setq *debugger-hook*
423 | (lambda (condition old-debugger-hook)
424 | (debug:backtrace 10)
425 | (unix:unix-exit 2)))
427 | (mp::start-sigalrm-yield)
428 | (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
429 | (mp:make-process #'roomy)
430 | (mp:make-process #'roomy)))
433 ;; give the other thread time to die before we leave, otherwise the
434 ;; overall exit status is 0, not 104