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 ;;; For one of the interupt-thread tests, we want a foreign function
19 ;;; that does not make syscalls
21 (with-open-file (o "threads-foreign.c" :direction
:output
)
22 (format o
"void loop_forever() { while(1) ; }~%"))
25 (or #+linux
'("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
26 (error "Missing shared library compilation options for this platform"))
28 (sb-alien:load-1-foreign
"threads-foreign.so")
29 (sb-alien:define-alien-routine loop-forever sb-alien
:void
)
32 ;;; elementary "can we get a lock and release it again"
33 (let ((l (make-mutex :name
"foo"))
34 (p (current-thread-id)))
35 (assert (eql (mutex-value l
) nil
) nil
"1")
36 (assert (eql (mutex-lock l
) 0) nil
"2")
37 (sb-thread:get-mutex l
)
38 (assert (eql (mutex-value l
) p
) nil
"3")
39 (assert (eql (mutex-lock l
) 0) nil
"4")
40 (sb-thread:release-mutex l
)
41 (assert (eql (mutex-value l
) nil
) nil
"5")
42 (assert (eql (mutex-lock l
) 0) nil
"6")
45 (let ((queue (make-waitqueue :name
"queue"))
46 (lock (make-mutex :name
"lock")))
47 (labels ((in-new-thread ()
49 (assert (eql (mutex-value lock
) (current-thread-id)))
50 (format t
"~A got mutex~%" (current-thread-id))
51 ;; now drop it and sleep
52 (condition-wait queue lock
)
53 ;; after waking we should have the lock again
54 (assert (eql (mutex-value lock
) (current-thread-id))))))
55 (make-thread #'in-new-thread
)
56 (sleep 2) ; give it a chance to start
57 ;; check the lock is free while it's asleep
58 (format t
"parent thread ~A~%" (current-thread-id))
59 (assert (eql (mutex-value lock
) nil
))
60 (assert (eql (mutex-lock lock
) 0))
62 (condition-notify queue
))
65 (let ((queue (make-waitqueue :name
"queue"))
66 (lock (make-mutex :name
"lock")))
67 (labels ((ours-p (value)
68 (sb-vm:control-stack-pointer-valid-p
69 (sb-sys:int-sap
(sb-kernel:get-lisp-obj-address value
))))
71 (with-recursive-lock (lock)
72 (assert (ours-p (mutex-value lock
)))
73 (format t
"~A got mutex~%" (mutex-value lock
))
74 ;; now drop it and sleep
75 (condition-wait queue lock
)
76 ;; after waking we should have the lock again
77 (format t
"woken, ~A got mutex~%" (mutex-value lock
))
78 (assert (ours-p (mutex-value lock
))))))
79 (make-thread #'in-new-thread
)
80 (sleep 2) ; give it a chance to start
81 ;; check the lock is free while it's asleep
82 (format t
"parent thread ~A~%" (current-thread-id))
83 (assert (eql (mutex-value lock
) nil
))
84 (assert (eql (mutex-lock lock
) 0))
85 (with-recursive-lock (lock)
86 (condition-notify queue
))
89 (let ((mutex (make-mutex :name
"contended")))
91 (let ((me (current-thread-id)))
95 (assert (eql (mutex-value mutex
) me
)))
96 (assert (not (eql (mutex-value mutex
) me
))))
97 (format t
"done ~A~%" (current-thread-id)))))
98 (let ((kid1 (make-thread #'run
))
99 (kid2 (make-thread #'run
)))
100 (format t
"contention ~A ~A~%" kid1 kid2
))))
102 (defun test-interrupt (function-to-interrupt &optional quit-p
)
103 (let ((child (make-thread function-to-interrupt
)))
104 ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
106 (format t
"interrupting child ~A~%" child
)
107 (interrupt-thread child
109 (format t
"child pid ~A~%" (current-thread-id))
110 (when quit-p
(sb-ext:quit
))))
114 ;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
115 ;;; (d) waiting on a lock, (e) some code which we hope is likely to be
118 (let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child
))
120 (test-interrupt #'loop-forever
:quit
)
122 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
123 ;; Interrupting a sleep form causes it to return early. Welcome to Unix.
124 ;; Just to be sure our LOOP form works, let's check the child is still
126 (assert (zerop (sb-unix:unix-kill child
0)))
127 (terminate-thread child
))
129 (let ((lock (make-mutex :name
"loctite"))
132 (setf child
(test-interrupt
135 (assert (eql (mutex-value lock
) (current-thread-id))))
136 (assert (not (eql (mutex-value lock
) (current-thread-id))))
138 ;;hold onto lock for long enough that child can't get it immediately
140 (interrupt-thread child
(lambda () (format t
"l ~A~%" (mutex-value lock
))))
141 (format t
"parent releasing lock~%"))
142 (terminate-thread child
))
144 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
146 (let ((c (test-interrupt (lambda () (loop (alloc-stuff))))))
147 ;; NB this only works on x86: other ports don't have a symbol for
148 ;; pseudo-atomic atomicity
149 (format t
"new thread ~A~%" c
)
154 (princ ".") (force-output)
155 (assert (zerop SB-KERNEL
:*PSEUDO-ATOMIC-ATOMIC
*)))))
156 (terminate-thread c
))
158 (format t
"~&interrupt test done~%")
161 (make-thread (lambda ()
163 (sb-ext:gc
) (princ "\\") (force-output) )
165 (make-thread (lambda ()
168 (princ "/") (force-output))
171 (when (and a-done b-done
) (return))
173 (format t
"~&gc test done~%")
175 #|
;; a cll post from eric marsden
177 |
(setq *debugger-hook
*
178 |
(lambda (condition old-debugger-hook
)
179 |
(debug:backtrace
10)
180 |
(unix:unix-exit
2)))
182 |
(mp::start-sigalrm-yield
)
183 |
(flet ((roomy () (loop (with-output-to-string (*standard-output
*) (room)))))
184 |
(mp:make-process
#'roomy
)
185 |
(mp:make-process
#'roomy
)))
188 ;; give the other thread time to die before we leave, otherwise the
189 ;; overall exit status is 0, not 104
192 (sb-ext:quit
:unix-status
104)