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 #-sb-thread (quit :unix-status 104)
16 (in-package "SB-THREAD") ; this is white-box testing, really
18 ;;; We had appalling scaling properties for a while. Make sure they
20 (defun scaling-test (function &optional (nthreads 5))
21 "Execute FUNCTION with NTHREADS lurking to slow it down."
22 (let ((queue (sb-thread:make-waitqueue))
23 (mutex (sb-thread:make-mutex)))
24 ;; Start NTHREADS idle threads.
26 (sb-thread:make-thread (lambda ()
27 (sb-thread:condition-wait queue mutex)
29 (let ((start-time (get-internal-run-time)))
31 (prog1 (- (get-internal-run-time) start-time)
32 (sb-thread:condition-broadcast queue)))))
34 "A function that does work with the CPU."
35 (if (zerop n) 1 (* n (fact (1- n)))))
36 (let ((work (lambda () (fact 15000))))
37 (let ((zero (scaling-test work 0))
38 (four (scaling-test work 4)))
39 ;; a slightly weak assertion, but good enough for starters.
40 (assert (< four (* 1.5 zero)))))
42 ;;; For one of the interupt-thread tests, we want a foreign function
43 ;;; that does not make syscalls
45 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
46 (format o "void loop_forever() { while(1) ; }~%"))
49 (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
50 (error "Missing shared library compilation options for this platform"))
52 (sb-alien:load-shared-object "threads-foreign.so")
53 (sb-alien:define-alien-routine loop-forever sb-alien:void)
56 ;;; elementary "can we get a lock and release it again"
57 (let ((l (make-mutex :name "foo"))
58 (p (current-thread-id)))
59 (assert (eql (mutex-value l) nil) nil "1")
60 (assert (eql (mutex-lock l) 0) nil "2")
61 (sb-thread:get-mutex l)
62 (assert (eql (mutex-value l) p) nil "3")
63 (assert (eql (mutex-lock l) 0) nil "4")
64 (sb-thread:release-mutex l)
65 (assert (eql (mutex-value l) nil) nil "5")
66 (assert (eql (mutex-lock l) 0) nil "6")
69 (let ((l (make-waitqueue :name "spinlock"))
70 (p (current-thread-id)))
71 (assert (eql (waitqueue-lock l) 0) nil "1")
73 (assert (eql (waitqueue-lock l) p) nil "2"))
74 (assert (eql (waitqueue-lock l) 0) nil "3")
77 ;; test that SLEEP actually sleeps for at least the given time, even
78 ;; if interrupted by another thread exiting/a gc/anything
79 (let ((start-time (get-universal-time)))
80 (make-thread (lambda () (sleep 1))) ; kid waits 1 then dies ->SIG_THREAD_EXIT
82 (assert (>= (get-universal-time) (+ 5 start-time))))
85 (let ((queue (make-waitqueue :name "queue"))
86 (lock (make-mutex :name "lock")))
87 (labels ((in-new-thread ()
89 (assert (eql (mutex-value lock) (current-thread-id)))
90 (format t "~A got mutex~%" (current-thread-id))
91 ;; now drop it and sleep
92 (condition-wait queue lock)
93 ;; after waking we should have the lock again
94 (assert (eql (mutex-value lock) (current-thread-id))))))
95 (make-thread #'in-new-thread)
96 (sleep 2) ; give it a chance to start
97 ;; check the lock is free while it's asleep
98 (format t "parent thread ~A~%" (current-thread-id))
99 (assert (eql (mutex-value lock) nil))
100 (assert (eql (mutex-lock lock) 0))
102 (condition-notify queue))
105 (let ((queue (make-waitqueue :name "queue"))
106 (lock (make-mutex :name "lock")))
107 (labels ((ours-p (value)
108 (sb-vm:control-stack-pointer-valid-p
109 (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
111 (with-recursive-lock (lock)
112 (assert (ours-p (mutex-value lock)))
113 (format t "~A got mutex~%" (mutex-value lock))
114 ;; now drop it and sleep
115 (condition-wait queue lock)
116 ;; after waking we should have the lock again
117 (format t "woken, ~A got mutex~%" (mutex-value lock))
118 (assert (ours-p (mutex-value lock))))))
119 (make-thread #'in-new-thread)
120 (sleep 2) ; give it a chance to start
121 ;; check the lock is free while it's asleep
122 (format t "parent thread ~A~%" (current-thread-id))
123 (assert (eql (mutex-value lock) nil))
124 (assert (eql (mutex-lock lock) 0))
125 (with-recursive-lock (lock)
126 (condition-notify queue))
129 (let ((mutex (make-mutex :name "contended")))
131 (let ((me (current-thread-id)))
135 (assert (eql (mutex-value mutex) me)))
136 (assert (not (eql (mutex-value mutex) me))))
137 (format t "done ~A~%" (current-thread-id)))))
138 (let ((kid1 (make-thread #'run))
139 (kid2 (make-thread #'run)))
140 (format t "contention ~A ~A~%" kid1 kid2))))
142 (defun test-interrupt (function-to-interrupt &optional quit-p)
143 (let ((child (make-thread function-to-interrupt)))
144 ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
146 (format t "interrupting child ~A~%" child)
147 (interrupt-thread child
149 (format t "child pid ~A~%" (current-thread-id))
150 (when quit-p (sb-ext:quit))))
154 ;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
155 ;;; (d) waiting on a lock, (e) some code which we hope is likely to be
158 (let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child))
160 (test-interrupt #'loop-forever :quit)
162 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
163 (terminate-thread child))
165 (let ((lock (make-mutex :name "loctite"))
168 (setf child (test-interrupt
171 (assert (eql (mutex-value lock) (current-thread-id))))
172 (assert (not (eql (mutex-value lock) (current-thread-id))))
174 ;;hold onto lock for long enough that child can't get it immediately
176 (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
177 (format t "parent releasing lock~%"))
178 (terminate-thread child))
180 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
182 (let ((c (test-interrupt (lambda () (loop (alloc-stuff))))))
183 ;; NB this only works on x86: other ports don't have a symbol for
184 ;; pseudo-atomic atomicity
185 (format t "new thread ~A~%" c)
190 (princ ".") (force-output)
191 (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
192 (terminate-thread c))
195 (defparameter *interrupt-count* 0)
197 (declaim (notinline check-interrupt-count))
198 (defun check-interrupt-count (i)
199 (declare (optimize (debug 1) (speed 1)))
200 ;; This used to lose if eflags were not restored after an interrupt.
201 (unless (typep i 'fixnum)
202 (error "!!!!!!!!!!!")))
204 (let ((c (make-thread
206 (handler-bind ((error #'(lambda (cond)
209 most-positive-fixnum))))
210 (loop (check-interrupt-count *interrupt-count*)))))))
211 (let ((func (lambda ()
214 (sb-impl::atomic-incf/symbol *interrupt-count*))))
215 (sb-sys:with-pinned-objects (func)
216 (setq *interrupt-count* 0)
219 (interrupt-thread c func))
221 (assert (= 100 *interrupt-count*))
222 (terminate-thread c))))
224 (format t "~&interrupt test done~%")
227 (make-thread (lambda ()
229 (sb-ext:gc) (princ "\\") (force-output) )
231 (make-thread (lambda ()
234 (princ "/") (force-output))
237 (when (and a-done b-done) (return))
242 (defun waste (&optional (n 100000))
243 (loop repeat n do (make-string 16384)))
245 (loop for i below 100 do
248 (sb-thread:make-thread
256 (defparameter *aaa* nil)
257 (loop for i below 100 do
260 (sb-thread:make-thread
262 (let ((*aaa* (waste)))
264 (let ((*aaa* (waste)))
268 (format t "~&gc test done~%")
270 ;; this used to deadlock on session-lock
271 (sb-thread:make-thread (lambda () (sb-ext:gc)))
272 ;; expose thread creation races by exiting quickly
273 (sb-thread:make-thread (lambda ()))
275 (defun exercise-syscall (fn reference-errno)
276 (sb-thread:make-thread
280 (let ((errno (sb-unix::get-errno)))
282 (unless (eql errno reference-errno)
283 (format t "Got errno: ~A (~A) instead of ~A~%"
288 (sb-ext:quit :unix-status 1)))))))
290 (let* ((nanosleep-errno (progn
291 (sb-unix:nanosleep -1 0)
292 (sb-unix::get-errno)))
295 :if-does-not-exist nil)
296 (sb-unix::get-errno)))
299 (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
300 (exercise-syscall (lambda () (open "no-such-file"
301 :if-does-not-exist nil))
303 (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
305 (princ "terminating threads")
306 (dolist (thread threads)
307 (sb-thread:terminate-thread thread)))
309 (format t "~&errno test done~%")
312 (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
313 (sb-thread:interrupt-thread
316 (assert (find-restart 'sb-thread:terminate-thread))))))
320 (format t "~&thread startup sigmask test done~%")
322 #| ;; a cll post from eric marsden
324 | (setq *debugger-hook*
325 | (lambda (condition old-debugger-hook)
326 | (debug:backtrace 10)
327 | (unix:unix-exit 2)))
329 | (mp::start-sigalrm-yield)
330 | (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
331 | (mp:make-process #'roomy)
332 | (mp:make-process #'roomy)))
335 ;; give the other thread time to die before we leave, otherwise the
336 ;; overall exit status is 0, not 104
339 (sb-ext:quit :unix-status 104)