Commit | Line | Data |
---|---|---|
5925aed0 KR |
1 | ;;;; threads.test --- Tests for Guile threading. -*- scheme -*- |
2 | ;;;; | |
8a177d31 | 3 | ;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. |
5925aed0 | 4 | ;;;; |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
5925aed0 | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
5925aed0 | 18 | |
2e77f720 | 19 | (define-module (test-threads) |
c21a5ddc LC |
20 | #:use-module (ice-9 threads) |
21 | #:use-module (system base compile) | |
22 | #:use-module (test-suite lib)) | |
2e77f720 | 23 | |
4201062d NJ |
24 | (define (asyncs-still-working?) |
25 | (let ((a #f)) | |
26 | (system-async-mark (lambda () | |
27 | (set! a #t))) | |
28 | ;; The point of the following (equal? ...) is to go through | |
29 | ;; primitive code (scm_equal_p) that includes a SCM_TICK call and | |
30 | ;; hence gives system asyncs a chance to run. Of course the | |
31 | ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the | |
32 | ;; near future we may be using the VM instead of the traditional | |
33 | ;; compiler, and then we will still want asyncs-still-working? to | |
34 | ;; work. (The VM should probably have SCM_TICK calls too, but | |
35 | ;; let's not rely on that here.) | |
36 | (equal? '(a b c) '(a b c)) | |
37 | a)) | |
5925aed0 | 38 | |
d8d925f3 | 39 | (if (provided? 'threads) |
23f2b9a3 | 40 | (begin |
5925aed0 | 41 | |
23f2b9a3 KR |
42 | (with-test-prefix "parallel" |
43 | (pass-if "no forms" | |
44 | (call-with-values | |
45 | (lambda () | |
46 | (parallel)) | |
d8d925f3 | 47 | (lambda () |
23f2b9a3 | 48 | #t))) |
d8d925f3 | 49 | |
23f2b9a3 KR |
50 | (pass-if "1" |
51 | (call-with-values | |
52 | (lambda () | |
53 | (parallel 1)) | |
54 | (lambda (x) | |
55 | (equal? x 1)))) | |
d8d925f3 | 56 | |
23f2b9a3 KR |
57 | (pass-if "1 2" |
58 | (call-with-values | |
59 | (lambda () | |
60 | (parallel 1 2)) | |
61 | (lambda (x y) | |
62 | (and (equal? x 1) | |
63 | (equal? y 2))))) | |
64 | ||
65 | (pass-if "1 2 3" | |
66 | (call-with-values | |
67 | (lambda () | |
68 | (parallel 1 2 3)) | |
69 | (lambda (x y z) | |
70 | (and (equal? x 1) | |
71 | (equal? y 2) | |
72 | (equal? z 3)))))) | |
73 | ||
c21a5ddc LC |
74 | ;; |
75 | ;; par-map | |
76 | ;; | |
77 | ||
78 | (with-test-prefix "par-map" | |
79 | ||
80 | (pass-if "simple" | |
81 | (compile '(letrec ((fibo (lambda (n) | |
82 | (if (<= n 1) | |
83 | n | |
84 | (+ (fibo (- n 1)) | |
85 | (fibo (- n 2))))))) | |
86 | (equal? (par-map fibo (iota 13)) | |
87 | (map fibo (iota 13)))) | |
88 | #:to 'value | |
8a177d31 LC |
89 | #:env (current-module))) |
90 | ||
91 | (pass-if-equal "long list" (map 1+ (iota 10000)) | |
92 | ;; In Guile 2.0.7, this would trigger a stack overflow. | |
93 | ;; See <http://bugs.gnu.org/13188>. | |
94 | (par-map 1+ (iota 10000)))) | |
c21a5ddc LC |
95 | |
96 | ;; | |
97 | ;; par-for-each | |
98 | ;; | |
99 | ||
100 | (with-test-prefix "par-for-each" | |
101 | ||
102 | (pass-if "simple" | |
103 | (compile '(let ((v (make-vector 6 #f))) | |
104 | (par-for-each (lambda (n) | |
105 | (vector-set! v n n)) | |
106 | (iota 6)) | |
107 | (equal? v (list->vector (iota 6)))) | |
108 | #:to 'value | |
109 | #:env (current-module)))) | |
110 | ||
23f2b9a3 KR |
111 | ;; |
112 | ;; n-par-for-each | |
113 | ;; | |
114 | ||
115 | (with-test-prefix "n-par-for-each" | |
116 | ||
117 | (pass-if "0 in limit 10" | |
118 | (n-par-for-each 10 noop '()) | |
119 | #t) | |
120 | ||
121 | (pass-if "6 in limit 10" | |
122 | (let ((v (make-vector 6 #f))) | |
123 | (n-par-for-each 10 (lambda (n) | |
124 | (vector-set! v n #t)) | |
125 | '(0 1 2 3 4 5)) | |
126 | (equal? v '#(#t #t #t #t #t #t)))) | |
127 | ||
128 | (pass-if "6 in limit 1" | |
129 | (let ((v (make-vector 6 #f))) | |
130 | (n-par-for-each 1 (lambda (n) | |
131 | (vector-set! v n #t)) | |
132 | '(0 1 2 3 4 5)) | |
133 | (equal? v '#(#t #t #t #t #t #t)))) | |
134 | ||
135 | (pass-if "6 in limit 2" | |
136 | (let ((v (make-vector 6 #f))) | |
137 | (n-par-for-each 2 (lambda (n) | |
138 | (vector-set! v n #t)) | |
139 | '(0 1 2 3 4 5)) | |
140 | (equal? v '#(#t #t #t #t #t #t)))) | |
141 | ||
142 | (pass-if "6 in limit 3" | |
143 | (let ((v (make-vector 6 #f))) | |
144 | (n-par-for-each 3 (lambda (n) | |
145 | (vector-set! v n #t)) | |
146 | '(0 1 2 3 4 5)) | |
147 | (equal? v '#(#t #t #t #t #t #t))))) | |
148 | ||
149 | ;; | |
150 | ;; n-for-each-par-map | |
151 | ;; | |
152 | ||
153 | (with-test-prefix "n-for-each-par-map" | |
154 | ||
4201062d NJ |
155 | (pass-if "asyncs are still working 2" |
156 | (asyncs-still-working?)) | |
157 | ||
23f2b9a3 KR |
158 | (pass-if "0 in limit 10" |
159 | (n-for-each-par-map 10 noop noop '()) | |
160 | #t) | |
161 | ||
162 | (pass-if "6 in limit 10" | |
163 | (let ((result '())) | |
164 | (n-for-each-par-map 10 | |
165 | (lambda (n) (set! result (cons n result))) | |
166 | (lambda (n) (* 2 n)) | |
167 | '(0 1 2 3 4 5)) | |
168 | (equal? result '(10 8 6 4 2 0)))) | |
169 | ||
170 | (pass-if "6 in limit 1" | |
171 | (let ((result '())) | |
172 | (n-for-each-par-map 1 | |
173 | (lambda (n) (set! result (cons n result))) | |
174 | (lambda (n) (* 2 n)) | |
175 | '(0 1 2 3 4 5)) | |
176 | (equal? result '(10 8 6 4 2 0)))) | |
177 | ||
178 | (pass-if "6 in limit 2" | |
179 | (let ((result '())) | |
180 | (n-for-each-par-map 2 | |
181 | (lambda (n) (set! result (cons n result))) | |
182 | (lambda (n) (* 2 n)) | |
183 | '(0 1 2 3 4 5)) | |
184 | (equal? result '(10 8 6 4 2 0)))) | |
185 | ||
186 | (pass-if "6 in limit 3" | |
187 | (let ((result '())) | |
188 | (n-for-each-par-map 3 | |
189 | (lambda (n) (set! result (cons n result))) | |
190 | (lambda (n) (* 2 n)) | |
191 | '(0 1 2 3 4 5)) | |
2e77f720 LC |
192 | (equal? result '(10 8 6 4 2 0))))) |
193 | ||
6180e336 NJ |
194 | ;; |
195 | ;; timed mutex locking | |
196 | ;; | |
197 | ||
198 | (with-test-prefix "lock-mutex" | |
199 | ||
4201062d NJ |
200 | (pass-if "asyncs are still working 3" |
201 | (asyncs-still-working?)) | |
202 | ||
6180e336 NJ |
203 | (pass-if "timed locking fails if timeout exceeded" |
204 | (let ((m (make-mutex))) | |
205 | (lock-mutex m) | |
206 | (let ((t (begin-thread (lock-mutex m (+ (current-time) 1))))) | |
207 | (not (join-thread t))))) | |
208 | ||
4201062d NJ |
209 | (pass-if "asyncs are still working 6" |
210 | (asyncs-still-working?)) | |
211 | ||
6180e336 NJ |
212 | (pass-if "timed locking succeeds if mutex unlocked within timeout" |
213 | (let* ((m (make-mutex)) | |
214 | (c (make-condition-variable)) | |
215 | (cm (make-mutex))) | |
216 | (lock-mutex cm) | |
217 | (let ((t (begin-thread (begin (lock-mutex cm) | |
218 | (signal-condition-variable c) | |
219 | (unlock-mutex cm) | |
220 | (lock-mutex m | |
ed756f78 | 221 | (+ (current-time) 5)))))) |
6180e336 NJ |
222 | (lock-mutex m) |
223 | (wait-condition-variable c cm) | |
224 | (unlock-mutex cm) | |
225 | (sleep 1) | |
226 | (unlock-mutex m) | |
4201062d NJ |
227 | (join-thread t)))) |
228 | ||
229 | (pass-if "asyncs are still working 7" | |
230 | (asyncs-still-working?)) | |
231 | ||
232 | ) | |
6180e336 NJ |
233 | |
234 | ;; | |
235 | ;; timed mutex unlocking | |
236 | ;; | |
237 | ||
238 | (with-test-prefix "unlock-mutex" | |
239 | ||
4201062d NJ |
240 | (pass-if "asyncs are still working 5" |
241 | (asyncs-still-working?)) | |
242 | ||
6180e336 NJ |
243 | (pass-if "timed unlocking returns #f if timeout exceeded" |
244 | (let ((m (make-mutex)) | |
245 | (c (make-condition-variable))) | |
246 | (lock-mutex m) | |
247 | (not (unlock-mutex m c (current-time))))) | |
248 | ||
4201062d NJ |
249 | (pass-if "asyncs are still working 4" |
250 | (asyncs-still-working?)) | |
251 | ||
6180e336 NJ |
252 | (pass-if "timed unlocking returns #t if condition signaled" |
253 | (let ((m1 (make-mutex)) | |
254 | (m2 (make-mutex)) | |
255 | (c1 (make-condition-variable)) | |
256 | (c2 (make-condition-variable))) | |
257 | (lock-mutex m1) | |
258 | (let ((t (begin-thread (begin (lock-mutex m1) | |
259 | (signal-condition-variable c1) | |
260 | (lock-mutex m2) | |
261 | (unlock-mutex m1) | |
74926120 NJ |
262 | (unlock-mutex m2 |
263 | c2 | |
264 | (+ (current-time) | |
ed756f78 | 265 | 5)))))) |
6180e336 NJ |
266 | (wait-condition-variable c1 m1) |
267 | (unlock-mutex m1) | |
268 | (lock-mutex m2) | |
269 | (signal-condition-variable c2) | |
270 | (unlock-mutex m2) | |
271 | (join-thread t))))) | |
272 | ||
273 | ;; | |
274 | ;; timed joining | |
275 | ;; | |
276 | ||
277 | (with-test-prefix "join-thread" | |
278 | ||
279 | (pass-if "timed joining fails if timeout exceeded" | |
280 | (let* ((m (make-mutex)) | |
281 | (c (make-condition-variable)) | |
282 | (t (begin-thread (begin (lock-mutex m) | |
283 | (wait-condition-variable c m)))) | |
284 | (r (join-thread t (current-time)))) | |
285 | (cancel-thread t) | |
286 | (not r))) | |
74926120 | 287 | |
6180e336 NJ |
288 | (pass-if "join-thread returns timeoutval on timeout" |
289 | (let* ((m (make-mutex)) | |
290 | (c (make-condition-variable)) | |
291 | (t (begin-thread (begin (lock-mutex m) | |
292 | (wait-condition-variable c m)))) | |
293 | (r (join-thread t (current-time) 'foo))) | |
294 | (cancel-thread t) | |
295 | (eq? r 'foo))) | |
74926120 | 296 | |
6180e336 NJ |
297 | |
298 | (pass-if "timed joining succeeds if thread exits within timeout" | |
299 | (let ((t (begin-thread (begin (sleep 1) #t)))) | |
ed756f78 | 300 | (join-thread t (+ (current-time) 5)))) |
4201062d NJ |
301 | |
302 | (pass-if "asyncs are still working 1" | |
303 | (asyncs-still-working?)) | |
304 | ||
21346c4f NJ |
305 | ;; scm_join_thread_timed has a SCM_TICK in the middle of it, |
306 | ;; to allow asyncs to run (including signal delivery). We | |
307 | ;; used to have a bug whereby if the joined thread terminated | |
308 | ;; at the same time as the joining thread is in this SCM_TICK, | |
309 | ;; scm_join_thread_timed would not notice and would hang | |
310 | ;; forever. So in this test we are setting up the following | |
311 | ;; sequence of events. | |
312 | ;; T=0 other thread is created and starts running | |
313 | ;; T=2 main thread sets up an async that will sleep for 10 seconds | |
314 | ;; T=2 main thread calls join-thread, which will... | |
315 | ;; T=2 ...call the async, which starts sleeping | |
316 | ;; T=5 other thread finishes its work and terminates | |
317 | ;; T=7 async completes, main thread continues inside join-thread. | |
318 | (pass-if "don't hang when joined thread terminates in SCM_TICK" | |
319 | (let ((other-thread (make-thread sleep 5))) | |
320 | (letrec ((delay-count 10) | |
321 | (aproc (lambda () | |
322 | (set! delay-count (- delay-count 1)) | |
323 | (if (zero? delay-count) | |
324 | (sleep 5) | |
325 | (system-async-mark aproc))))) | |
326 | (sleep 2) | |
327 | (system-async-mark aproc) | |
328 | (join-thread other-thread))) | |
329 | #t)) | |
6180e336 | 330 | |
2e77f720 LC |
331 | ;; |
332 | ;; thread cancellation | |
333 | ;; | |
334 | ||
335 | (with-test-prefix "cancel-thread" | |
336 | ||
337 | (pass-if "cancel succeeds" | |
338 | (let ((m (make-mutex))) | |
339 | (lock-mutex m) | |
340 | (let ((t (begin-thread (begin (lock-mutex m) 'foo)))) | |
341 | (cancel-thread t) | |
342 | (join-thread t) | |
343 | #t))) | |
344 | ||
345 | (pass-if "handler result passed to join" | |
346 | (let ((m (make-mutex))) | |
347 | (lock-mutex m) | |
348 | (let ((t (begin-thread (lock-mutex m)))) | |
349 | (set-thread-cleanup! t (lambda () 'foo)) | |
350 | (cancel-thread t) | |
351 | (eq? (join-thread t) 'foo)))) | |
352 | ||
353 | (pass-if "can cancel self" | |
354 | (let ((m (make-mutex))) | |
355 | (lock-mutex m) | |
356 | (let ((t (begin-thread (begin | |
357 | (set-thread-cleanup! (current-thread) | |
358 | (lambda () 'foo)) | |
359 | (cancel-thread (current-thread)) | |
360 | (lock-mutex m))))) | |
361 | (eq? (join-thread t) 'foo)))) | |
362 | ||
363 | (pass-if "handler supplants final expr" | |
364 | (let ((t (begin-thread (begin (set-thread-cleanup! (current-thread) | |
365 | (lambda () 'bar)) | |
366 | 'foo)))) | |
367 | (eq? (join-thread t) 'bar))) | |
368 | ||
369 | (pass-if "remove handler by setting false" | |
370 | (let ((m (make-mutex))) | |
371 | (lock-mutex m) | |
372 | (let ((t (begin-thread (lock-mutex m) 'bar))) | |
373 | (set-thread-cleanup! t (lambda () 'foo)) | |
374 | (set-thread-cleanup! t #f) | |
375 | (unlock-mutex m) | |
376 | (eq? (join-thread t) 'bar)))) | |
377 | ||
378 | (pass-if "initial handler is false" | |
6180e336 NJ |
379 | (not (thread-cleanup (current-thread))))) |
380 | ||
adc085f1 JG |
381 | ;; |
382 | ;; mutex ownership | |
383 | ;; | |
384 | ||
385 | (with-test-prefix "mutex-ownership" | |
386 | (pass-if "mutex ownership for locked mutex" | |
387 | (let ((m (make-mutex))) | |
388 | (lock-mutex m) | |
389 | (eq? (mutex-owner m) (current-thread)))) | |
390 | ||
391 | (pass-if "mutex ownership for unlocked mutex" | |
392 | (let ((m (make-mutex))) | |
393 | (not (mutex-owner m)))) | |
394 | ||
395 | (pass-if "locking mutex on behalf of other thread" | |
396 | (let* ((m (make-mutex)) | |
397 | (t (begin-thread 'foo))) | |
398 | (lock-mutex m #f t) | |
399 | (eq? (mutex-owner m) t))) | |
400 | ||
401 | (pass-if "locking mutex with no owner" | |
402 | (let ((m (make-mutex))) | |
403 | (lock-mutex m #f #f) | |
a0faf7dd LC |
404 | (not (mutex-owner m)))) |
405 | ||
406 | (pass-if "mutex with owner not retained (bug #27450)" | |
407 | (let ((g (make-guardian))) | |
408 | (g (let ((m (make-mutex))) (lock-mutex m) m)) | |
409 | ||
410 | ;; Avoid false references to M on the stack. | |
5270a001 | 411 | (clear-stale-stack-references) |
a0faf7dd LC |
412 | |
413 | (gc) (gc) | |
414 | (let ((m (g))) | |
415 | (and (mutex? m) | |
416 | (eq? (mutex-owner m) (current-thread))))))) | |
adc085f1 JG |
417 | |
418 | ;; | |
419 | ;; mutex lock levels | |
420 | ;; | |
421 | ||
422 | (with-test-prefix "mutex-lock-levels" | |
74926120 | 423 | |
adc085f1 JG |
424 | (pass-if "unlocked level is 0" |
425 | (let ((m (make-mutex))) | |
426 | (and (not (mutex-locked? m)) (eqv? (mutex-level m) 0)))) | |
427 | ||
428 | (pass-if "non-recursive lock level is 1" | |
429 | (let ((m (make-mutex))) | |
430 | (lock-mutex m) | |
431 | (and (mutex-locked? m) (eqv? (mutex-level m) 1)))) | |
432 | ||
433 | (pass-if "recursive lock level is >1" | |
434 | (let ((m (make-mutex 'recursive))) | |
435 | (lock-mutex m) | |
436 | (lock-mutex m) | |
437 | (and (mutex-locked? m) (eqv? (mutex-level m) 2))))) | |
438 | ||
6180e336 NJ |
439 | ;; |
440 | ;; mutex behavior | |
441 | ;; | |
442 | ||
443 | (with-test-prefix "mutex-behavior" | |
444 | ||
445 | (pass-if "unchecked unlock" | |
446 | (let* ((m (make-mutex 'unchecked-unlock))) | |
447 | (unlock-mutex m))) | |
448 | ||
449 | (pass-if "allow external unlock" | |
450 | (let* ((m (make-mutex 'allow-external-unlock)) | |
451 | (t (begin-thread (lock-mutex m)))) | |
452 | (join-thread t) | |
453 | (unlock-mutex m))) | |
454 | ||
455 | (pass-if "recursive mutexes" | |
456 | (let* ((m (make-mutex 'recursive))) | |
457 | (lock-mutex m) | |
74926120 | 458 | (lock-mutex m))) |
6180e336 NJ |
459 | |
460 | (pass-if "locking abandoned mutex throws exception" | |
461 | (let* ((m (make-mutex)) | |
462 | (t (begin-thread (lock-mutex m))) | |
463 | (success #f)) | |
464 | (join-thread t) | |
465 | (catch 'abandoned-mutex-error | |
466 | (lambda () (lock-mutex m)) | |
467 | (lambda key (set! success #t))) | |
468 | success))))) | |
d20912e6 LC |
469 | |
470 | ||
471 | ;; | |
472 | ;; nproc | |
473 | ;; | |
474 | ||
475 | (with-test-prefix "nproc" | |
476 | ||
477 | (pass-if "total-processor-count" | |
478 | (>= (total-processor-count) 1)) | |
479 | ||
480 | (pass-if "current-processor-count" | |
481 | (and (>= (current-processor-count) 1) | |
482 | (>= (total-processor-count) (current-processor-count))))) |