0.8.17.17:
[sbcl.git] / tests / threads.impure.lisp
1 ;;;; miscellaneous tests of thread stuff
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;; 
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.
13
14 #-sb-thread (quit :unix-status 104)
15
16 (in-package "SB-THREAD") ; this is white-box testing, really
17
18 ;;; We had appalling scaling properties for a while.  Make sure they
19 ;;; don't reappear.
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.
25     (dotimes (i nthreads)
26       (sb-thread:make-thread (lambda ()
27                                (sb-thread:condition-wait queue mutex)
28                                (sb-ext:quit))))
29     (let ((start-time (get-internal-run-time)))
30       (funcall function)
31       (prog1 (- (get-internal-run-time) start-time)
32         (sb-thread:condition-broadcast queue)))))
33 (defun fact (n)
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)))))
41
42 ;;; For one of the interupt-thread tests, we want a foreign function
43 ;;; that does not make syscalls
44
45 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
46   (format o "void loop_forever() { while(1) ; }~%"))
47 (sb-ext:run-program     
48  "cc"
49  (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
50      (error "Missing shared library compilation options for this platform"))
51  :search t)
52 (sb-alien:load-shared-object "threads-foreign.so")
53 (sb-alien:define-alien-routine loop-forever sb-alien:void)
54
55
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")
67   (describe l))
68
69 (let ((queue (make-waitqueue :name "queue"))
70       (lock (make-mutex :name "lock")))
71   (labels ((in-new-thread ()
72              (with-mutex (lock)
73                (assert (eql (mutex-value lock) (current-thread-id)))
74                (format t "~A got mutex~%" (current-thread-id))
75                ;; now drop it and sleep
76                (condition-wait queue lock)
77                ;; after waking we should have the lock again
78                (assert (eql (mutex-value lock) (current-thread-id))))))
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-mutex (lock)
86       (condition-notify queue))
87     (sleep 1)))
88
89 (let ((queue (make-waitqueue :name "queue"))
90       (lock (make-mutex :name "lock")))
91   (labels ((ours-p (value)
92              (sb-vm:control-stack-pointer-valid-p
93               (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
94            (in-new-thread ()
95              (with-recursive-lock (lock)
96                (assert (ours-p (mutex-value lock)))
97                (format t "~A got mutex~%" (mutex-value lock))
98                ;; now drop it and sleep
99                (condition-wait queue lock)
100                ;; after waking we should have the lock again
101                (format t "woken, ~A got mutex~%" (mutex-value lock))
102                (assert (ours-p (mutex-value lock))))))
103     (make-thread #'in-new-thread)
104     (sleep 2)                           ; give it  a chance to start
105     ;; check the lock is free while it's asleep
106     (format t "parent thread ~A~%" (current-thread-id))
107     (assert (eql (mutex-value lock) nil))    
108     (assert (eql (mutex-lock lock) 0))
109     (with-recursive-lock (lock)
110       (condition-notify queue))
111     (sleep 1)))
112
113 (let ((mutex (make-mutex :name "contended")))
114   (labels ((run ()
115              (let ((me (current-thread-id)))
116                (dotimes (i 100)
117                  (with-mutex (mutex)
118                    (sleep .1)
119                    (assert (eql (mutex-value mutex) me)))
120                  (assert (not (eql (mutex-value mutex) me))))
121                (format t "done ~A~%" (current-thread-id)))))
122     (let ((kid1 (make-thread #'run))
123           (kid2 (make-thread #'run)))
124       (format t "contention ~A ~A~%" kid1 kid2))))
125
126 (defun test-interrupt (function-to-interrupt &optional quit-p)
127   (let ((child  (make-thread function-to-interrupt)))
128     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
129     (sleep 2)
130     (format t "interrupting child ~A~%" child)
131     (interrupt-thread child
132                       (lambda ()
133                         (format t "child pid ~A~%" (current-thread-id))
134                         (when quit-p (sb-ext:quit))))
135     (sleep 1)
136     child))
137
138 ;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
139 ;;; (d) waiting on a lock, (e) some code which we hope is likely to be
140 ;;; in pseudo-atomic
141
142 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
143
144 (test-interrupt #'loop-forever :quit)
145
146 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
147   ;; Interrupting a sleep form causes it to return early.  Welcome to Unix.
148   ;; Just to be sure our LOOP form works, let's check the child is still
149   ;; there
150   (assert (zerop (sb-unix:unix-kill child 0)))
151   (terminate-thread child))
152                 
153 (let ((lock (make-mutex :name "loctite"))
154       child)
155   (with-mutex (lock)
156     (setf child (test-interrupt
157                  (lambda ()
158                    (with-mutex (lock)
159                      (assert (eql (mutex-value lock) (current-thread-id))))
160                    (assert (not (eql (mutex-value lock) (current-thread-id))))
161                    (sleep 60))))
162     ;;hold onto lock for long enough that child can't get it immediately
163     (sleep 20)
164     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
165     (format t "parent releasing lock~%"))
166   (terminate-thread child))
167
168 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
169
170 (let ((c (test-interrupt (lambda () (loop (alloc-stuff))))))
171   ;; NB this only works on x86: other ports don't have a symbol for
172   ;; pseudo-atomic atomicity
173   (format t "new thread ~A~%" c)
174   (dotimes (i 100)
175     (sleep (random 1d0))
176     (interrupt-thread c
177                       (lambda ()
178                         (princ ".") (force-output)
179                         (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
180   (terminate-thread c))
181
182 (format t "~&interrupt test done~%")
183
184 (let (a-done b-done)
185   (make-thread (lambda ()
186                  (dotimes (i 100) 
187                    (sb-ext:gc) (princ "\\") (force-output) )
188                  (setf a-done t)))
189   (make-thread (lambda ()
190                  (dotimes (i 25) 
191                    (sb-ext:gc :full t)
192                    (princ "/") (force-output))
193                  (setf b-done t)))
194   (loop
195    (when (and a-done b-done) (return))
196    (sleep 1)))
197 (format t "~&gc test done~%")
198
199 #|  ;; a cll post from eric marsden
200 | (defun crash ()
201 |   (setq *debugger-hook*
202 |         (lambda (condition old-debugger-hook)
203 |           (debug:backtrace 10)
204 |           (unix:unix-exit 2)))
205 |   #+live-dangerously
206 |   (mp::start-sigalrm-yield)
207 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
208 |     (mp:make-process #'roomy)
209 |     (mp:make-process #'roomy)))
210 |#
211
212 ;; give the other thread time to die before we leave, otherwise the
213 ;; overall exit status is 0, not 104
214 (sleep 2) 
215
216 (sb-ext:quit :unix-status 104)