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