2 ;;;; miscellaneous tests of thread stuff
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
15 (in-package "SB-THREAD") ; this is white-box testing, really
17 (use-package :test-util)
19 (defun wait-for-threads (threads)
20 (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
22 (assert (eql 1 (length (list-all-threads))))
24 (assert (eq *current-thread*
25 (find (thread-name *current-thread*) (list-all-threads)
26 :key #'thread-name :test #'equal)))
28 (assert (thread-alive-p *current-thread*))
31 (interrupt-thread *current-thread* (lambda () (setq a 1)))
34 (let ((spinlock (make-spinlock)))
35 (with-spinlock (spinlock)))
37 (let ((mutex (make-mutex)))
41 #-sb-thread (sb-ext:quit :unix-status 104)
43 (let ((old-threads (list-all-threads))
44 (thread (make-thread (lambda ()
45 (assert (find *current-thread* *all-threads*))
47 (new-threads (list-all-threads)))
48 (assert (thread-alive-p thread))
49 (assert (eq thread (first new-threads)))
50 (assert (= (1+ (length old-threads)) (length new-threads)))
52 (assert (not (thread-alive-p thread))))
54 ;;; We had appalling scaling properties for a while. Make sure they
56 (defun scaling-test (function &optional (nthreads 5))
57 "Execute FUNCTION with NTHREADS lurking to slow it down."
58 (let ((queue (sb-thread:make-waitqueue))
59 (mutex (sb-thread:make-mutex)))
60 ;; Start NTHREADS idle threads.
62 (sb-thread:make-thread (lambda ()
64 (sb-thread:condition-wait queue mutex))
66 (let ((start-time (get-internal-run-time)))
68 (prog1 (- (get-internal-run-time) start-time)
69 (sb-thread:condition-broadcast queue)))))
71 "A function that does work with the CPU."
72 (if (zerop n) 1 (* n (fact (1- n)))))
73 (let ((work (lambda () (fact 15000))))
74 (let ((zero (scaling-test work 0))
75 (four (scaling-test work 4)))
76 ;; a slightly weak assertion, but good enough for starters.
77 (assert (< four (* 1.5 zero)))))
79 ;;; For one of the interupt-thread tests, we want a foreign function
80 ;;; that does not make syscalls
82 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
83 (format o "void loop_forever() { while(1) ; }~%"))
85 #-sunos "cc" #+sunos "gcc"
86 (or #+(or linux freebsd sunos) '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
87 #+darwin '("-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
88 (error "Missing shared library compilation options for this platform"))
90 (sb-alien:load-shared-object "threads-foreign.so")
91 (sb-alien:define-alien-routine loop-forever sb-alien:void)
94 ;;; elementary "can we get a lock and release it again"
95 (let ((l (make-mutex :name "foo"))
97 (assert (eql (mutex-value l) nil) nil "1")
98 (sb-thread:get-mutex l)
99 (assert (eql (mutex-value l) p) nil "3")
100 (sb-thread:release-mutex l)
101 (assert (eql (mutex-value l) nil) nil "5"))
103 (labels ((ours-p (value)
104 (eq *current-thread* value)))
105 (let ((l (make-mutex :name "rec")))
106 (assert (eql (mutex-value l) nil) nil "1")
107 (sb-thread:with-recursive-lock (l)
108 (assert (ours-p (mutex-value l)) nil "3")
109 (sb-thread:with-recursive-lock (l)
110 (assert (ours-p (mutex-value l)) nil "4"))
111 (assert (ours-p (mutex-value l)) nil "5"))
112 (assert (eql (mutex-value l) nil) nil "6")))
114 (with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
115 (let ((l (make-mutex :name "a mutex")))
117 (with-recursive-lock (l)))))
119 (let ((l (make-spinlock :name "spinlock")))
120 (assert (eql (spinlock-value l) 0) nil "1")
122 (assert (eql (spinlock-value l) 1) nil "2"))
123 (assert (eql (spinlock-value l) 0) nil "3"))
125 ;; test that SLEEP actually sleeps for at least the given time, even
126 ;; if interrupted by another thread exiting/a gc/anything
127 (let ((start-time (get-universal-time)))
128 (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
130 (assert (>= (get-universal-time) (+ 5 start-time))))
133 (let ((queue (make-waitqueue :name "queue"))
134 (lock (make-mutex :name "lock"))
136 (labels ((in-new-thread ()
138 (assert (eql (mutex-value lock) *current-thread*))
139 (format t "~A got mutex~%" *current-thread*)
140 ;; now drop it and sleep
141 (condition-wait queue lock)
142 ;; after waking we should have the lock again
143 (assert (eql (mutex-value lock) *current-thread*))
146 (make-thread #'in-new-thread)
147 (sleep 2) ; give it a chance to start
148 ;; check the lock is free while it's asleep
149 (format t "parent thread ~A~%" *current-thread*)
150 (assert (eql (mutex-value lock) nil))
153 (condition-notify queue))
156 (let ((queue (make-waitqueue :name "queue"))
157 (lock (make-mutex :name "lock")))
158 (labels ((ours-p (value)
159 (eq *current-thread* value))
161 (with-recursive-lock (lock)
162 (assert (ours-p (mutex-value lock)))
163 (format t "~A got mutex~%" (mutex-value lock))
164 ;; now drop it and sleep
165 (condition-wait queue lock)
166 ;; after waking we should have the lock again
167 (format t "woken, ~A got mutex~%" (mutex-value lock))
168 (assert (ours-p (mutex-value lock))))))
169 (make-thread #'in-new-thread)
170 (sleep 2) ; give it a chance to start
171 ;; check the lock is free while it's asleep
172 (format t "parent thread ~A~%" *current-thread*)
173 (assert (eql (mutex-value lock) nil))
174 (with-recursive-lock (lock)
175 (condition-notify queue))
178 (let ((mutex (make-mutex :name "contended")))
180 (let ((me *current-thread*))
184 (assert (eql (mutex-value mutex) me)))
185 (assert (not (eql (mutex-value mutex) me))))
186 (format t "done ~A~%" *current-thread*))))
187 (let ((kid1 (make-thread #'run))
188 (kid2 (make-thread #'run)))
189 (format t "contention ~A ~A~%" kid1 kid2)
190 (wait-for-threads (list kid1 kid2)))))
194 (defmacro raises-timeout-p (&body body)
195 `(handler-case (progn (progn ,@body) nil)
196 (sb-ext:timeout () t)))
198 (with-test (:name (:semaphore :wait-forever))
199 (let ((sem (make-semaphore :count 0)))
200 (assert (raises-timeout-p
201 (sb-ext:with-timeout 0.1
202 (wait-on-semaphore sem))))))
204 (with-test (:name (:semaphore :initial-count))
205 (let ((sem (make-semaphore :count 1)))
206 (sb-ext:with-timeout 0.1
207 (wait-on-semaphore sem))))
209 (with-test (:name (:semaphore :wait-then-signal))
210 (let ((sem (make-semaphore))
212 (make-thread (lambda ()
215 (signal-semaphore sem)))
216 (wait-on-semaphore sem)
217 (assert signalled-p)))
219 (with-test (:name (:semaphore :signal-then-wait))
220 (let ((sem (make-semaphore))
222 (make-thread (lambda ()
223 (signal-semaphore sem)
224 (setq signalled-p t)))
225 (loop until signalled-p)
226 (wait-on-semaphore sem)
227 (assert signalled-p)))
229 (with-test (:name (:semaphore :multiple-signals))
230 (let* ((sem (make-semaphore :count 5))
231 (threads (loop repeat 20
232 collect (make-thread (lambda ()
233 (wait-on-semaphore sem))))))
234 (flet ((count-live-threads ()
235 (count-if #'thread-alive-p threads)))
237 (assert (= 15 (count-live-threads)))
238 (signal-semaphore sem 10)
240 (assert (= 5 (count-live-threads)))
241 (signal-semaphore sem 3)
243 (assert (= 2 (count-live-threads)))
244 (signal-semaphore sem 4)
246 (assert (= 0 (count-live-threads))))))
248 (format t "~&semaphore tests done~%")
250 (defun test-interrupt (function-to-interrupt &optional quit-p)
251 (let ((child (make-thread function-to-interrupt)))
252 ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
254 (format t "interrupting child ~A~%" child)
255 (interrupt-thread child
257 (format t "child pid ~A~%" *current-thread*)
258 (when quit-p (sb-ext:quit))))
262 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
263 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
266 (let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child))
268 (test-interrupt #'loop-forever :quit)
270 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
271 (terminate-thread child)
272 (wait-for-threads (list child)))
274 (let ((lock (make-mutex :name "loctite"))
277 (setf child (test-interrupt
280 (assert (eql (mutex-value lock) *current-thread*)))
281 (assert (not (eql (mutex-value lock) *current-thread*)))
283 ;;hold onto lock for long enough that child can't get it immediately
285 (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
286 (format t "parent releasing lock~%"))
287 (terminate-thread child)
288 (wait-for-threads (list child)))
290 (format t "~&locking test done~%")
292 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
295 (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
297 (loop repeat 4 collect
298 (sb-thread:make-thread
301 (sleep (random 0.1d0))
304 (sb-thread:interrupt-thread thread (lambda ()))))))))
305 (wait-for-threads killers)
306 (sb-thread:terminate-thread thread)
307 (wait-for-threads (list thread))))
310 (format t "~&multi interrupt test done~%")
312 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
313 ;; NB this only works on x86: other ports don't have a symbol for
314 ;; pseudo-atomic atomicity
316 (sleep (random 0.1d0))
319 (princ ".") (force-output)
320 (assert (thread-alive-p *current-thread*))
321 (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
323 (wait-for-threads (list c)))
325 (format t "~&interrupt test done~%")
327 (defparameter *interrupt-count* 0)
329 (declaim (notinline check-interrupt-count))
330 (defun check-interrupt-count (i)
331 (declare (optimize (debug 1) (speed 1)))
332 ;; This used to lose if eflags were not restored after an interrupt.
333 (unless (typep i 'fixnum)
334 (error "!!!!!!!!!!!")))
336 (let ((c (make-thread
338 (handler-bind ((error #'(lambda (cond)
341 most-positive-fixnum))))
342 (loop (check-interrupt-count *interrupt-count*)))))))
343 (let ((func (lambda ()
346 (sb-impl::atomic-incf/symbol *interrupt-count*))))
347 (setq *interrupt-count* 0)
349 (sleep (random 0.1d0))
350 (interrupt-thread c func))
351 (loop until (= *interrupt-count* 100) do (sleep 0.1))
353 (wait-for-threads (list c))))
355 (format t "~&interrupt count test done~%")
358 (make-thread (lambda ()
360 (sb-ext:gc) (princ "\\") (force-output))
362 (make-thread (lambda ()
365 (princ "/") (force-output))
368 (when (and a-done b-done) (return))
373 (defun waste (&optional (n 100000))
374 (loop repeat n do (make-string 16384)))
376 (loop for i below 100 do
379 (sb-thread:make-thread
387 (defparameter *aaa* nil)
388 (loop for i below 100 do
391 (sb-thread:make-thread
393 (let ((*aaa* (waste)))
395 (let ((*aaa* (waste)))
399 (format t "~&gc test done~%")
401 ;; this used to deadlock on session-lock
402 (sb-thread:make-thread (lambda () (sb-ext:gc)))
403 ;; expose thread creation races by exiting quickly
404 (sb-thread:make-thread (lambda ()))
406 (defun exercise-syscall (fn reference-errno)
407 (sb-thread:make-thread
411 (let ((errno (sb-unix::get-errno)))
412 (sleep (random 0.1d0))
413 (unless (eql errno reference-errno)
414 (format t "Got errno: ~A (~A) instead of ~A~%"
419 (sb-ext:quit :unix-status 1)))))))
421 (let* ((nanosleep-errno (progn
422 (sb-unix:nanosleep -1 0)
423 (sb-unix::get-errno)))
426 :if-does-not-exist nil)
427 (sb-unix::get-errno)))
430 (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
431 (exercise-syscall (lambda () (open "no-such-file"
432 :if-does-not-exist nil))
434 (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
436 (princ "terminating threads")
437 (dolist (thread threads)
438 (sb-thread:terminate-thread thread)))
440 (format t "~&errno test done~%")
443 (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
444 (sb-thread:interrupt-thread
447 (assert (find-restart 'sb-thread:terminate-thread))))))
451 (format t "~&thread startup sigmask test done~%")
453 (sb-debug::enable-debugger)
454 (let* ((main-thread *current-thread*)
456 (make-thread (lambda ()
458 (interrupt-thread main-thread #'break)
460 (interrupt-thread main-thread #'continue)))))
461 (with-session-lock (*session*)
463 (loop while (thread-alive-p interruptor-thread)))
465 (format t "~&session lock test done~%")
469 (loop for i below 100 collect
470 (sb-thread:make-thread (lambda ())))))
472 (format t "~&creation test done~%")
474 ;; interrupt handlers are per-thread with pthreads, make sure the
475 ;; handler installed in one thread is global
476 (sb-thread:make-thread
478 (sb-ext:run-program "sleep" '("1") :search t :wait nil)))
480 ;;;; Binding stack safety
482 (defparameter *x* nil)
483 (defparameter *n-gcs-requested* 0)
484 (defparameter *n-gcs-done* 0)
487 (defun make-something-big ()
488 (let ((x (make-string 32000)))
490 (let ((counter counter))
491 (sb-ext:finalize x (lambda () (format t " ~S" counter)
494 (defmacro wait-for-gc ()
496 (incf *n-gcs-requested*)
497 (loop while (< *n-gcs-done* *n-gcs-requested*))))
500 (loop until (< *n-gcs-done* *n-gcs-requested*))
506 (defun exercise-binding ()
508 (let ((*x* (make-something-big)))
510 ;; at this point the binding stack looks like this:
511 ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
514 ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
515 ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
516 ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
517 ;; unbinding but values are not).
519 ;; bump bsp as if a BIND had just started
520 (incf sb-vm::*binding-stack-pointer* 2)
522 (decf sb-vm::*binding-stack-pointer* 2))))
524 (with-test (:name (:binding-stack-gc-safety))
528 (push (sb-thread:make-thread #'exercise-binding) threads)
529 (push (sb-thread:make-thread (lambda ()
535 (mapc #'sb-thread:terminate-thread threads))))
537 (format t "~&binding test done~%")
539 ;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a
540 ;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form
541 ;; causing the next gc hang SBCL.
542 (with-test (:name (:hash-table-thread-safety))
543 (let* ((hash (make-hash-table))
544 (threads (list (sb-thread:make-thread
547 ;;(princ "1") (force-output)
548 (setf (gethash (random 100) hash) 'h))))
549 (sb-thread:make-thread
552 ;;(princ "2") (force-output)
553 (remhash (random 100) hash))))
554 (sb-thread:make-thread
558 (sb-ext:gc :full t)))))))
561 (mapc #'sb-thread:terminate-thread threads))))
563 (format t "~&hash table test done~%")
564 #| ;; a cll post from eric marsden
566 | (setq *debugger-hook*
567 | (lambda (condition old-debugger-hook)
568 | (debug:backtrace 10)
569 | (unix:unix-exit 2)))
571 | (mp::start-sigalrm-yield)
572 | (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
573 | (mp:make-process #'roomy)
574 | (mp:make-process #'roomy)))
577 (with-test (:name (:condition-variable :notify-multiple))
578 (flet ((tester (notify-fun)
579 (let ((queue (make-waitqueue :name "queue"))
580 (lock (make-mutex :name "lock"))
585 (format t "condition-wait ~a~%" x)
587 (condition-wait queue lock)
588 (format t "woke up ~a~%" x)
591 (let ((threads (loop for x from 1 to 10
594 (sb-thread:make-thread (lambda ()
598 (funcall notify-fun queue))
600 (mapcar #'terminate-thread threads)
601 ;; Check that all threads woke up at least once
602 (assert (= (length (remove-duplicates data)) 10)))))))
603 (tester (lambda (queue)
604 (format t "~&(condition-notify queue 10)~%")
606 (condition-notify queue 10)))
607 (tester (lambda (queue)
608 (format t "~&(condition-broadcast queue)~%")
610 (condition-broadcast queue)))))
612 (with-test (:name (:mutex :finalization))
615 (setf a (make-mutex)))))