Commit | Line | Data |
---|---|---|
5925aed0 KR |
1 | ;;;; threads.test --- Tests for Guile threading. -*- scheme -*- |
2 | ;;;; | |
2e77f720 | 3 | ;;;; Copyright 2003, 2006, 2007 Free Software Foundation, Inc. |
5925aed0 KR |
4 | ;;;; |
5 | ;;;; This program is free software; you can redistribute it and/or modify | |
6 | ;;;; it under the terms of the GNU General Public License as published by | |
7 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;;;; any later version. | |
9 | ;;;; | |
10 | ;;;; This program is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | ;;;; GNU General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU General Public License | |
16 | ;;;; along with this software; see the file COPYING. If not, write to | |
92205699 MV |
17 | ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
18 | ;;;; Boston, MA 02110-1301 USA | |
5925aed0 | 19 | |
2e77f720 LC |
20 | (define-module (test-threads) |
21 | :use-module (ice-9 threads) | |
22 | :use-module (test-suite lib)) | |
23 | ||
5925aed0 | 24 | |
d8d925f3 | 25 | (if (provided? 'threads) |
23f2b9a3 | 26 | (begin |
5925aed0 | 27 | |
23f2b9a3 KR |
28 | (with-test-prefix "parallel" |
29 | (pass-if "no forms" | |
30 | (call-with-values | |
31 | (lambda () | |
32 | (parallel)) | |
d8d925f3 | 33 | (lambda () |
23f2b9a3 | 34 | #t))) |
d8d925f3 | 35 | |
23f2b9a3 KR |
36 | (pass-if "1" |
37 | (call-with-values | |
38 | (lambda () | |
39 | (parallel 1)) | |
40 | (lambda (x) | |
41 | (equal? x 1)))) | |
d8d925f3 | 42 | |
23f2b9a3 KR |
43 | (pass-if "1 2" |
44 | (call-with-values | |
45 | (lambda () | |
46 | (parallel 1 2)) | |
47 | (lambda (x y) | |
48 | (and (equal? x 1) | |
49 | (equal? y 2))))) | |
50 | ||
51 | (pass-if "1 2 3" | |
52 | (call-with-values | |
53 | (lambda () | |
54 | (parallel 1 2 3)) | |
55 | (lambda (x y z) | |
56 | (and (equal? x 1) | |
57 | (equal? y 2) | |
58 | (equal? z 3)))))) | |
59 | ||
60 | ;; | |
61 | ;; n-par-for-each | |
62 | ;; | |
63 | ||
64 | (with-test-prefix "n-par-for-each" | |
65 | ||
66 | (pass-if "0 in limit 10" | |
67 | (n-par-for-each 10 noop '()) | |
68 | #t) | |
69 | ||
70 | (pass-if "6 in limit 10" | |
71 | (let ((v (make-vector 6 #f))) | |
72 | (n-par-for-each 10 (lambda (n) | |
73 | (vector-set! v n #t)) | |
74 | '(0 1 2 3 4 5)) | |
75 | (equal? v '#(#t #t #t #t #t #t)))) | |
76 | ||
77 | (pass-if "6 in limit 1" | |
78 | (let ((v (make-vector 6 #f))) | |
79 | (n-par-for-each 1 (lambda (n) | |
80 | (vector-set! v n #t)) | |
81 | '(0 1 2 3 4 5)) | |
82 | (equal? v '#(#t #t #t #t #t #t)))) | |
83 | ||
84 | (pass-if "6 in limit 2" | |
85 | (let ((v (make-vector 6 #f))) | |
86 | (n-par-for-each 2 (lambda (n) | |
87 | (vector-set! v n #t)) | |
88 | '(0 1 2 3 4 5)) | |
89 | (equal? v '#(#t #t #t #t #t #t)))) | |
90 | ||
91 | (pass-if "6 in limit 3" | |
92 | (let ((v (make-vector 6 #f))) | |
93 | (n-par-for-each 3 (lambda (n) | |
94 | (vector-set! v n #t)) | |
95 | '(0 1 2 3 4 5)) | |
96 | (equal? v '#(#t #t #t #t #t #t))))) | |
97 | ||
98 | ;; | |
99 | ;; n-for-each-par-map | |
100 | ;; | |
101 | ||
102 | (with-test-prefix "n-for-each-par-map" | |
103 | ||
104 | (pass-if "0 in limit 10" | |
105 | (n-for-each-par-map 10 noop noop '()) | |
106 | #t) | |
107 | ||
108 | (pass-if "6 in limit 10" | |
109 | (let ((result '())) | |
110 | (n-for-each-par-map 10 | |
111 | (lambda (n) (set! result (cons n result))) | |
112 | (lambda (n) (* 2 n)) | |
113 | '(0 1 2 3 4 5)) | |
114 | (equal? result '(10 8 6 4 2 0)))) | |
115 | ||
116 | (pass-if "6 in limit 1" | |
117 | (let ((result '())) | |
118 | (n-for-each-par-map 1 | |
119 | (lambda (n) (set! result (cons n result))) | |
120 | (lambda (n) (* 2 n)) | |
121 | '(0 1 2 3 4 5)) | |
122 | (equal? result '(10 8 6 4 2 0)))) | |
123 | ||
124 | (pass-if "6 in limit 2" | |
125 | (let ((result '())) | |
126 | (n-for-each-par-map 2 | |
127 | (lambda (n) (set! result (cons n result))) | |
128 | (lambda (n) (* 2 n)) | |
129 | '(0 1 2 3 4 5)) | |
130 | (equal? result '(10 8 6 4 2 0)))) | |
131 | ||
132 | (pass-if "6 in limit 3" | |
133 | (let ((result '())) | |
134 | (n-for-each-par-map 3 | |
135 | (lambda (n) (set! result (cons n result))) | |
136 | (lambda (n) (* 2 n)) | |
137 | '(0 1 2 3 4 5)) | |
2e77f720 LC |
138 | (equal? result '(10 8 6 4 2 0))))) |
139 | ||
6180e336 NJ |
140 | ;; |
141 | ;; timed mutex locking | |
142 | ;; | |
143 | ||
144 | (with-test-prefix "lock-mutex" | |
145 | ||
146 | (pass-if "timed locking fails if timeout exceeded" | |
147 | (let ((m (make-mutex))) | |
148 | (lock-mutex m) | |
149 | (let ((t (begin-thread (lock-mutex m (+ (current-time) 1))))) | |
150 | (not (join-thread t))))) | |
151 | ||
152 | (pass-if "timed locking succeeds if mutex unlocked within timeout" | |
153 | (let* ((m (make-mutex)) | |
154 | (c (make-condition-variable)) | |
155 | (cm (make-mutex))) | |
156 | (lock-mutex cm) | |
157 | (let ((t (begin-thread (begin (lock-mutex cm) | |
158 | (signal-condition-variable c) | |
159 | (unlock-mutex cm) | |
160 | (lock-mutex m | |
161 | (+ (current-time) 2)))))) | |
162 | (lock-mutex m) | |
163 | (wait-condition-variable c cm) | |
164 | (unlock-mutex cm) | |
165 | (sleep 1) | |
166 | (unlock-mutex m) | |
167 | (join-thread t))))) | |
168 | ||
169 | ;; | |
170 | ;; timed mutex unlocking | |
171 | ;; | |
172 | ||
173 | (with-test-prefix "unlock-mutex" | |
174 | ||
175 | (pass-if "timed unlocking returns #f if timeout exceeded" | |
176 | (let ((m (make-mutex)) | |
177 | (c (make-condition-variable))) | |
178 | (lock-mutex m) | |
179 | (not (unlock-mutex m c (current-time))))) | |
180 | ||
181 | (pass-if "timed unlocking returns #t if condition signaled" | |
182 | (let ((m1 (make-mutex)) | |
183 | (m2 (make-mutex)) | |
184 | (c1 (make-condition-variable)) | |
185 | (c2 (make-condition-variable))) | |
186 | (lock-mutex m1) | |
187 | (let ((t (begin-thread (begin (lock-mutex m1) | |
188 | (signal-condition-variable c1) | |
189 | (lock-mutex m2) | |
190 | (unlock-mutex m1) | |
74926120 NJ |
191 | (unlock-mutex m2 |
192 | c2 | |
193 | (+ (current-time) | |
6180e336 NJ |
194 | 2)))))) |
195 | (wait-condition-variable c1 m1) | |
196 | (unlock-mutex m1) | |
197 | (lock-mutex m2) | |
198 | (signal-condition-variable c2) | |
199 | (unlock-mutex m2) | |
200 | (join-thread t))))) | |
201 | ||
202 | ;; | |
203 | ;; timed joining | |
204 | ;; | |
205 | ||
206 | (with-test-prefix "join-thread" | |
207 | ||
208 | (pass-if "timed joining fails if timeout exceeded" | |
209 | (let* ((m (make-mutex)) | |
210 | (c (make-condition-variable)) | |
211 | (t (begin-thread (begin (lock-mutex m) | |
212 | (wait-condition-variable c m)))) | |
213 | (r (join-thread t (current-time)))) | |
214 | (cancel-thread t) | |
215 | (not r))) | |
74926120 | 216 | |
6180e336 NJ |
217 | (pass-if "join-thread returns timeoutval on timeout" |
218 | (let* ((m (make-mutex)) | |
219 | (c (make-condition-variable)) | |
220 | (t (begin-thread (begin (lock-mutex m) | |
221 | (wait-condition-variable c m)))) | |
222 | (r (join-thread t (current-time) 'foo))) | |
223 | (cancel-thread t) | |
224 | (eq? r 'foo))) | |
74926120 | 225 | |
6180e336 NJ |
226 | |
227 | (pass-if "timed joining succeeds if thread exits within timeout" | |
228 | (let ((t (begin-thread (begin (sleep 1) #t)))) | |
229 | (join-thread t (+ (current-time) 2))))) | |
230 | ||
2e77f720 LC |
231 | ;; |
232 | ;; thread cancellation | |
233 | ;; | |
234 | ||
235 | (with-test-prefix "cancel-thread" | |
236 | ||
237 | (pass-if "cancel succeeds" | |
238 | (let ((m (make-mutex))) | |
239 | (lock-mutex m) | |
240 | (let ((t (begin-thread (begin (lock-mutex m) 'foo)))) | |
241 | (cancel-thread t) | |
242 | (join-thread t) | |
243 | #t))) | |
244 | ||
245 | (pass-if "handler result passed to join" | |
246 | (let ((m (make-mutex))) | |
247 | (lock-mutex m) | |
248 | (let ((t (begin-thread (lock-mutex m)))) | |
249 | (set-thread-cleanup! t (lambda () 'foo)) | |
250 | (cancel-thread t) | |
251 | (eq? (join-thread t) 'foo)))) | |
252 | ||
253 | (pass-if "can cancel self" | |
254 | (let ((m (make-mutex))) | |
255 | (lock-mutex m) | |
256 | (let ((t (begin-thread (begin | |
257 | (set-thread-cleanup! (current-thread) | |
258 | (lambda () 'foo)) | |
259 | (cancel-thread (current-thread)) | |
260 | (lock-mutex m))))) | |
261 | (eq? (join-thread t) 'foo)))) | |
262 | ||
263 | (pass-if "handler supplants final expr" | |
264 | (let ((t (begin-thread (begin (set-thread-cleanup! (current-thread) | |
265 | (lambda () 'bar)) | |
266 | 'foo)))) | |
267 | (eq? (join-thread t) 'bar))) | |
268 | ||
269 | (pass-if "remove handler by setting false" | |
270 | (let ((m (make-mutex))) | |
271 | (lock-mutex m) | |
272 | (let ((t (begin-thread (lock-mutex m) 'bar))) | |
273 | (set-thread-cleanup! t (lambda () 'foo)) | |
274 | (set-thread-cleanup! t #f) | |
275 | (unlock-mutex m) | |
276 | (eq? (join-thread t) 'bar)))) | |
277 | ||
278 | (pass-if "initial handler is false" | |
6180e336 NJ |
279 | (not (thread-cleanup (current-thread))))) |
280 | ||
adc085f1 JG |
281 | ;; |
282 | ;; mutex ownership | |
283 | ;; | |
284 | ||
285 | (with-test-prefix "mutex-ownership" | |
286 | (pass-if "mutex ownership for locked mutex" | |
287 | (let ((m (make-mutex))) | |
288 | (lock-mutex m) | |
289 | (eq? (mutex-owner m) (current-thread)))) | |
290 | ||
291 | (pass-if "mutex ownership for unlocked mutex" | |
292 | (let ((m (make-mutex))) | |
293 | (not (mutex-owner m)))) | |
294 | ||
295 | (pass-if "locking mutex on behalf of other thread" | |
296 | (let* ((m (make-mutex)) | |
297 | (t (begin-thread 'foo))) | |
298 | (lock-mutex m #f t) | |
299 | (eq? (mutex-owner m) t))) | |
300 | ||
301 | (pass-if "locking mutex with no owner" | |
302 | (let ((m (make-mutex))) | |
303 | (lock-mutex m #f #f) | |
304 | (not (mutex-owner m))))) | |
305 | ||
306 | ;; | |
307 | ;; mutex lock levels | |
308 | ;; | |
309 | ||
310 | (with-test-prefix "mutex-lock-levels" | |
74926120 | 311 | |
adc085f1 JG |
312 | (pass-if "unlocked level is 0" |
313 | (let ((m (make-mutex))) | |
314 | (and (not (mutex-locked? m)) (eqv? (mutex-level m) 0)))) | |
315 | ||
316 | (pass-if "non-recursive lock level is 1" | |
317 | (let ((m (make-mutex))) | |
318 | (lock-mutex m) | |
319 | (and (mutex-locked? m) (eqv? (mutex-level m) 1)))) | |
320 | ||
321 | (pass-if "recursive lock level is >1" | |
322 | (let ((m (make-mutex 'recursive))) | |
323 | (lock-mutex m) | |
324 | (lock-mutex m) | |
325 | (and (mutex-locked? m) (eqv? (mutex-level m) 2))))) | |
326 | ||
6180e336 NJ |
327 | ;; |
328 | ;; mutex behavior | |
329 | ;; | |
330 | ||
331 | (with-test-prefix "mutex-behavior" | |
332 | ||
333 | (pass-if "unchecked unlock" | |
334 | (let* ((m (make-mutex 'unchecked-unlock))) | |
335 | (unlock-mutex m))) | |
336 | ||
337 | (pass-if "allow external unlock" | |
338 | (let* ((m (make-mutex 'allow-external-unlock)) | |
339 | (t (begin-thread (lock-mutex m)))) | |
340 | (join-thread t) | |
341 | (unlock-mutex m))) | |
342 | ||
343 | (pass-if "recursive mutexes" | |
344 | (let* ((m (make-mutex 'recursive))) | |
345 | (lock-mutex m) | |
74926120 | 346 | (lock-mutex m))) |
6180e336 NJ |
347 | |
348 | (pass-if "locking abandoned mutex throws exception" | |
349 | (let* ((m (make-mutex)) | |
350 | (t (begin-thread (lock-mutex m))) | |
351 | (success #f)) | |
352 | (join-thread t) | |
353 | (catch 'abandoned-mutex-error | |
354 | (lambda () (lock-mutex m)) | |
355 | (lambda key (set! success #t))) | |
356 | success))))) |