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) '(#+x86-64 "-fPIC"
87 "-shared" "-o" "threads-foreign.so" "threads-foreign.c")
88 #+darwin '("-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
89 (error "Missing shared library compilation options for this platform"))
91 (sb-alien:load-shared-object "threads-foreign.so")
92 (sb-alien:define-alien-routine loop-forever sb-alien:void)
95 ;;; elementary "can we get a lock and release it again"
96 (let ((l (make-mutex :name "foo"))
98 (assert (eql (mutex-value l) nil) nil "1")
99 (sb-thread:get-mutex l)
100 (assert (eql (mutex-value l) p) nil "3")
101 (sb-thread:release-mutex l)
102 (assert (eql (mutex-value l) nil) nil "5"))
104 (labels ((ours-p (value)
105 (eq *current-thread* value)))
106 (let ((l (make-mutex :name "rec")))
107 (assert (eql (mutex-value l) nil) nil "1")
108 (sb-thread:with-recursive-lock (l)
109 (assert (ours-p (mutex-value l)) nil "3")
110 (sb-thread:with-recursive-lock (l)
111 (assert (ours-p (mutex-value l)) nil "4"))
112 (assert (ours-p (mutex-value l)) nil "5"))
113 (assert (eql (mutex-value l) nil) nil "6")))
115 (with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
116 (let ((l (make-mutex :name "a mutex")))
118 (with-recursive-lock (l)))))
120 (let ((l (make-spinlock :name "spinlock")))
121 (assert (eql (spinlock-value l) 0) nil "1")
123 (assert (eql (spinlock-value l) 1) nil "2"))
124 (assert (eql (spinlock-value l) 0) nil "3"))
126 ;; test that SLEEP actually sleeps for at least the given time, even
127 ;; if interrupted by another thread exiting/a gc/anything
128 (let ((start-time (get-universal-time)))
129 (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
131 (assert (>= (get-universal-time) (+ 5 start-time))))
134 (let ((queue (make-waitqueue :name "queue"))
135 (lock (make-mutex :name "lock"))
137 (labels ((in-new-thread ()
139 (assert (eql (mutex-value lock) *current-thread*))
140 (format t "~A got mutex~%" *current-thread*)
141 ;; now drop it and sleep
142 (condition-wait queue lock)
143 ;; after waking we should have the lock again
144 (assert (eql (mutex-value lock) *current-thread*))
147 (make-thread #'in-new-thread)
148 (sleep 2) ; give it a chance to start
149 ;; check the lock is free while it's asleep
150 (format t "parent thread ~A~%" *current-thread*)
151 (assert (eql (mutex-value lock) nil))
154 (condition-notify queue))
157 (let ((queue (make-waitqueue :name "queue"))
158 (lock (make-mutex :name "lock")))
159 (labels ((ours-p (value)
160 (eq *current-thread* value))
162 (with-recursive-lock (lock)
163 (assert (ours-p (mutex-value lock)))
164 (format t "~A got mutex~%" (mutex-value lock))
165 ;; now drop it and sleep
166 (condition-wait queue lock)
167 ;; after waking we should have the lock again
168 (format t "woken, ~A got mutex~%" (mutex-value lock))
169 (assert (ours-p (mutex-value lock))))))
170 (make-thread #'in-new-thread)
171 (sleep 2) ; give it a chance to start
172 ;; check the lock is free while it's asleep
173 (format t "parent thread ~A~%" *current-thread*)
174 (assert (eql (mutex-value lock) nil))
175 (with-recursive-lock (lock)
176 (condition-notify queue))
179 (let ((mutex (make-mutex :name "contended")))
181 (let ((me *current-thread*))
185 (assert (eql (mutex-value mutex) me)))
186 (assert (not (eql (mutex-value mutex) me))))
187 (format t "done ~A~%" *current-thread*))))
188 (let ((kid1 (make-thread #'run))
189 (kid2 (make-thread #'run)))
190 (format t "contention ~A ~A~%" kid1 kid2)
191 (wait-for-threads (list kid1 kid2)))))
195 (defmacro raises-timeout-p (&body body)
196 `(handler-case (progn (progn ,@body) nil)
197 (sb-ext:timeout () t)))
199 (with-test (:name (:semaphore :wait-forever))
200 (let ((sem (make-semaphore :count 0)))
201 (assert (raises-timeout-p
202 (sb-ext:with-timeout 0.1
203 (wait-on-semaphore sem))))))
205 (with-test (:name (:semaphore :initial-count))
206 (let ((sem (make-semaphore :count 1)))
207 (sb-ext:with-timeout 0.1
208 (wait-on-semaphore sem))))
210 (with-test (:name (:semaphore :wait-then-signal))
211 (let ((sem (make-semaphore))
213 (make-thread (lambda ()
216 (signal-semaphore sem)))
217 (wait-on-semaphore sem)
218 (assert signalled-p)))
220 (with-test (:name (:semaphore :signal-then-wait))
221 (let ((sem (make-semaphore))
223 (make-thread (lambda ()
224 (signal-semaphore sem)
225 (setq signalled-p t)))
226 (loop until signalled-p)
227 (wait-on-semaphore sem)
228 (assert signalled-p)))
230 (with-test (:name (:semaphore :multiple-signals))
231 (let* ((sem (make-semaphore :count 5))
232 (threads (loop repeat 20
233 collect (make-thread (lambda ()
234 (wait-on-semaphore sem))))))
235 (flet ((count-live-threads ()
236 (count-if #'thread-alive-p threads)))
238 (assert (= 15 (count-live-threads)))
239 (signal-semaphore sem 10)
241 (assert (= 5 (count-live-threads)))
242 (signal-semaphore sem 3)
244 (assert (= 2 (count-live-threads)))
245 (signal-semaphore sem 4)
247 (assert (= 0 (count-live-threads))))))
249 (format t "~&semaphore tests done~%")
251 (defun test-interrupt (function-to-interrupt &optional quit-p)
252 (let ((child (make-thread function-to-interrupt)))
253 ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
255 (format t "interrupting child ~A~%" child)
256 (interrupt-thread child
258 (format t "child pid ~A~%" *current-thread*)
259 (when quit-p (sb-ext:quit))))
263 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
264 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
267 (let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child))
269 (test-interrupt #'loop-forever :quit)
271 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
272 (terminate-thread child)
273 (wait-for-threads (list child)))
275 (let ((lock (make-mutex :name "loctite"))
278 (setf child (test-interrupt
281 (assert (eql (mutex-value lock) *current-thread*)))
282 (assert (not (eql (mutex-value lock) *current-thread*)))
284 ;;hold onto lock for long enough that child can't get it immediately
286 (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
287 (format t "parent releasing lock~%"))
288 (terminate-thread child)
289 (wait-for-threads (list child)))
291 (format t "~&locking test done~%")
293 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
296 (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
298 (loop repeat 4 collect
299 (sb-thread:make-thread
302 (sleep (random 0.1d0))
305 (sb-thread:interrupt-thread thread (lambda ()))))))))
306 (wait-for-threads killers)
307 (sb-thread:terminate-thread thread)
308 (wait-for-threads (list thread))))
311 (format t "~&multi interrupt test done~%")
313 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
314 ;; NB this only works on x86: other ports don't have a symbol for
315 ;; pseudo-atomic atomicity
317 (sleep (random 0.1d0))
320 (princ ".") (force-output)
321 (assert (thread-alive-p *current-thread*))
322 (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
324 (wait-for-threads (list c)))
326 (format t "~&interrupt test done~%")
328 (defparameter *interrupt-count* 0)
330 (declaim (notinline check-interrupt-count))
331 (defun check-interrupt-count (i)
332 (declare (optimize (debug 1) (speed 1)))
333 ;; This used to lose if eflags were not restored after an interrupt.
334 (unless (typep i 'fixnum)
335 (error "!!!!!!!!!!!")))
337 (let ((c (make-thread
339 (handler-bind ((error #'(lambda (cond)
342 most-positive-fixnum))))
343 (loop (check-interrupt-count *interrupt-count*)))))))
344 (let ((func (lambda ()
347 (sb-impl::atomic-incf/symbol *interrupt-count*))))
348 (setq *interrupt-count* 0)
350 (sleep (random 0.1d0))
351 (interrupt-thread c func))
352 (loop until (= *interrupt-count* 100) do (sleep 0.1))
354 (wait-for-threads (list c))))
356 (format t "~&interrupt count test done~%")
359 (make-thread (lambda ()
361 (sb-ext:gc) (princ "\\") (force-output))
363 (make-thread (lambda ()
366 (princ "/") (force-output))
369 (when (and a-done b-done) (return))
374 (defun waste (&optional (n 100000))
375 (loop repeat n do (make-string 16384)))
377 (loop for i below 100 do
380 (sb-thread:make-thread
388 (defparameter *aaa* nil)
389 (loop for i below 100 do
392 (sb-thread:make-thread
394 (let ((*aaa* (waste)))
396 (let ((*aaa* (waste)))
400 (format t "~&gc test done~%")
402 ;; this used to deadlock on session-lock
403 (sb-thread:make-thread (lambda () (sb-ext:gc)))
404 ;; expose thread creation races by exiting quickly
405 (sb-thread:make-thread (lambda ()))
407 (defun exercise-syscall (fn reference-errno)
408 (sb-thread:make-thread
412 (let ((errno (sb-unix::get-errno)))
413 (sleep (random 0.1d0))
414 (unless (eql errno reference-errno)
415 (format t "Got errno: ~A (~A) instead of ~A~%"
420 (sb-ext:quit :unix-status 1)))))))
422 (let* ((nanosleep-errno (progn
423 (sb-unix:nanosleep -1 0)
424 (sb-unix::get-errno)))
427 :if-does-not-exist nil)
428 (sb-unix::get-errno)))
431 (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
432 (exercise-syscall (lambda () (open "no-such-file"
433 :if-does-not-exist nil))
435 (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
437 (princ "terminating threads")
438 (dolist (thread threads)
439 (sb-thread:terminate-thread thread)))
441 (format t "~&errno test done~%")
444 (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
445 (sb-thread:interrupt-thread
448 (assert (find-restart 'sb-thread:terminate-thread))))))
452 (format t "~&thread startup sigmask test done~%")
454 (sb-debug::enable-debugger)
455 (let* ((main-thread *current-thread*)
457 (make-thread (lambda ()
459 (interrupt-thread main-thread #'break)
461 (interrupt-thread main-thread #'continue)))))
462 (with-session-lock (*session*)
464 (loop while (thread-alive-p interruptor-thread)))
466 (format t "~&session lock test done~%")
470 (loop for i below 100 collect
471 (sb-thread:make-thread (lambda ())))))
473 (format t "~&creation test done~%")
475 ;; interrupt handlers are per-thread with pthreads, make sure the
476 ;; handler installed in one thread is global
477 (sb-thread:make-thread
479 (sb-ext:run-program "sleep" '("1") :search t :wait nil)))
481 ;;;; Binding stack safety
483 (defparameter *x* nil)
484 (defparameter *n-gcs-requested* 0)
485 (defparameter *n-gcs-done* 0)
488 (defun make-something-big ()
489 (let ((x (make-string 32000)))
491 (let ((counter counter))
492 (sb-ext:finalize x (lambda () (format t " ~S" counter)
495 (defmacro wait-for-gc ()
497 (incf *n-gcs-requested*)
498 (loop while (< *n-gcs-done* *n-gcs-requested*))))
501 (loop until (< *n-gcs-done* *n-gcs-requested*))
507 (defun exercise-binding ()
509 (let ((*x* (make-something-big)))
511 ;; at this point the binding stack looks like this:
512 ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
515 ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
516 ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
517 ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
518 ;; unbinding but values are not).
520 ;; bump bsp as if a BIND had just started
521 (incf sb-vm::*binding-stack-pointer* 2)
523 (decf sb-vm::*binding-stack-pointer* 2))))
525 (with-test (:name (:binding-stack-gc-safety))
529 (push (sb-thread:make-thread #'exercise-binding) threads)
530 (push (sb-thread:make-thread (lambda ()
536 (mapc #'sb-thread:terminate-thread threads))))
538 (format t "~&binding test done~%")
540 ;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a
541 ;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form
542 ;; causing the next gc hang SBCL.
543 (with-test (:name (:hash-table-thread-safety))
544 (let* ((hash (make-hash-table))
545 (threads (list (sb-thread:make-thread
548 ;;(princ "1") (force-output)
549 (setf (gethash (random 100) hash) 'h))))
550 (sb-thread:make-thread
553 ;;(princ "2") (force-output)
554 (remhash (random 100) hash))))
555 (sb-thread:make-thread
559 (sb-ext:gc :full t)))))))
562 (mapc #'sb-thread:terminate-thread threads))))
564 (format t "~&hash table test done~%")
565 #| ;; a cll post from eric marsden
567 | (setq *debugger-hook*
568 | (lambda (condition old-debugger-hook)
569 | (debug:backtrace 10)
570 | (unix:unix-exit 2)))
572 | (mp::start-sigalrm-yield)
573 | (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
574 | (mp:make-process #'roomy)
575 | (mp:make-process #'roomy)))
578 (with-test (:name (:condition-variable :notify-multiple))
579 (flet ((tester (notify-fun)
580 (let ((queue (make-waitqueue :name "queue"))
581 (lock (make-mutex :name "lock"))
586 (format t "condition-wait ~a~%" x)
588 (condition-wait queue lock)
589 (format t "woke up ~a~%" x)
592 (let ((threads (loop for x from 1 to 10
595 (sb-thread:make-thread (lambda ()
599 (funcall notify-fun queue))
601 (mapcar #'terminate-thread threads)
602 ;; Check that all threads woke up at least once
603 (assert (= (length (remove-duplicates data)) 10)))))))
604 (tester (lambda (queue)
605 (format t "~&(condition-notify queue 10)~%")
607 (condition-notify queue 10)))
608 (tester (lambda (queue)
609 (format t "~&(condition-broadcast queue)~%")
611 (condition-broadcast queue)))))
613 (with-test (:name (:mutex :finalization))
616 (setf a (make-mutex)))))