1 ;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
3 ;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013,
4 ;;;; 2014 Free Software Foundation, Inc.
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.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
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
20 (define-module (test-threads)
21 #:use-module (ice-9 threads)
22 #:use-module (system base compile)
23 #:use-module (test-suite lib))
25 (define (asyncs-still-working?)
27 (system-async-mark (lambda ()
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))
40 (define (require-cancel-thread)
41 ;; Skip the test when 'cancel-thread' is unavailable.
42 (unless (defined? 'cancel-thread)
45 (if (provided? 'threads)
48 (with-test-prefix "parallel"
84 (with-test-prefix "par-map"
87 (compile '(letrec ((fibo (lambda (n)
92 (equal? (par-map fibo (iota 13))
93 (map fibo (iota 13))))
95 #:env (current-module)))
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))))
106 (with-test-prefix "par-for-each"
109 (compile '(let ((v (make-vector 6 #f)))
110 (par-for-each (lambda (n)
113 (equal? v (list->vector (iota 6))))
115 #:env (current-module))))
121 (with-test-prefix "n-par-for-each"
123 (pass-if "0 in limit 10"
124 (n-par-for-each 10 noop '())
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))
132 (equal? v '#(#t #t #t #t #t #t))))
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))
139 (equal? v '#(#t #t #t #t #t #t))))
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))
146 (equal? v '#(#t #t #t #t #t #t))))
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))
153 (equal? v '#(#t #t #t #t #t #t)))))
156 ;; n-for-each-par-map
159 (with-test-prefix "n-for-each-par-map"
161 (pass-if "asyncs are still working 2"
162 (asyncs-still-working?))
164 (pass-if "0 in limit 10"
165 (n-for-each-par-map 10 noop noop '())
168 (pass-if "6 in limit 10"
170 (n-for-each-par-map 10
171 (lambda (n) (set! result (cons n result)))
174 (equal? result '(10 8 6 4 2 0))))
176 (pass-if "6 in limit 1"
178 (n-for-each-par-map 1
179 (lambda (n) (set! result (cons n result)))
182 (equal? result '(10 8 6 4 2 0))))
184 (pass-if "6 in limit 2"
186 (n-for-each-par-map 2
187 (lambda (n) (set! result (cons n result)))
190 (equal? result '(10 8 6 4 2 0))))
192 (pass-if "6 in limit 3"
194 (n-for-each-par-map 3
195 (lambda (n) (set! result (cons n result)))
198 (equal? result '(10 8 6 4 2 0)))))
201 ;; timed mutex locking
204 (with-test-prefix "lock-mutex"
206 (pass-if "asyncs are still working 3"
207 (asyncs-still-working?))
209 (pass-if "timed locking fails if timeout exceeded"
210 (let ((m (make-mutex)))
212 (let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
213 (not (join-thread t)))))
215 (pass-if "asyncs are still working 6"
216 (asyncs-still-working?))
218 (pass-if "timed locking succeeds if mutex unlocked within timeout"
219 (let* ((m (make-mutex))
220 (c (make-condition-variable))
223 (let ((t (begin-thread (begin (lock-mutex cm)
224 (signal-condition-variable c)
227 (+ (current-time) 5))))))
229 (wait-condition-variable c cm)
235 (pass-if "asyncs are still working 7"
236 (asyncs-still-working?))
241 ;; timed mutex unlocking
244 (with-test-prefix "unlock-mutex"
246 (pass-if "asyncs are still working 5"
247 (asyncs-still-working?))
249 (pass-if "timed unlocking returns #f if timeout exceeded"
250 (let ((m (make-mutex))
251 (c (make-condition-variable)))
253 (not (unlock-mutex m c (current-time)))))
255 (pass-if "asyncs are still working 4"
256 (asyncs-still-working?))
258 (pass-if "timed unlocking returns #t if condition signaled"
259 (let ((m1 (make-mutex))
261 (c1 (make-condition-variable))
262 (c2 (make-condition-variable)))
264 (let ((t (begin-thread (begin (lock-mutex m1)
265 (signal-condition-variable c1)
272 (wait-condition-variable c1 m1)
275 (signal-condition-variable c2)
283 (with-test-prefix "join-thread"
285 (pass-if "timed joining fails if timeout exceeded"
286 (require-cancel-thread)
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))))
295 (pass-if "join-thread returns timeoutval on timeout"
296 (require-cancel-thread)
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)))
306 (pass-if "timed joining succeeds if thread exits within timeout"
307 (let ((t (begin-thread (begin (sleep 1) #t))))
308 (join-thread t (+ (current-time) 5))))
310 (pass-if "asyncs are still working 1"
311 (asyncs-still-working?))
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)
330 (set! delay-count (- delay-count 1))
331 (if (zero? delay-count)
333 (system-async-mark aproc)))))
335 (system-async-mark aproc)
336 (join-thread other-thread)))
340 ;; thread cancellation
343 (with-test-prefix "cancel-thread"
345 (pass-if "cancel succeeds"
346 (require-cancel-thread)
347 (let ((m (make-mutex)))
349 (let ((t (begin-thread (begin (lock-mutex m) 'foo))))
354 (pass-if "handler result passed to join"
355 (require-cancel-thread)
356 (let ((m (make-mutex)))
358 (let ((t (begin-thread (lock-mutex m))))
359 (set-thread-cleanup! t (lambda () 'foo))
361 (eq? (join-thread t) 'foo))))
363 (pass-if "can cancel self"
364 (require-cancel-thread)
365 (let ((m (make-mutex)))
367 (let ((t (begin-thread (begin
368 (set-thread-cleanup! (current-thread)
370 (cancel-thread (current-thread))
372 (eq? (join-thread t) 'foo))))
374 (pass-if "handler supplants final expr"
375 (let ((t (begin-thread (begin (set-thread-cleanup! (current-thread)
378 (eq? (join-thread t) 'bar)))
380 (pass-if "remove handler by setting false"
381 (let ((m (make-mutex)))
383 (let ((t (begin-thread (lock-mutex m) 'bar)))
384 (set-thread-cleanup! t (lambda () 'foo))
385 (set-thread-cleanup! t #f)
387 (eq? (join-thread t) 'bar))))
389 (pass-if "initial handler is false"
390 (not (thread-cleanup (current-thread)))))
396 (with-test-prefix "mutex-ownership"
397 (pass-if "mutex ownership for locked mutex"
398 (let ((m (make-mutex)))
400 (eq? (mutex-owner m) (current-thread))))
402 (pass-if "mutex ownership for unlocked mutex"
403 (let ((m (make-mutex)))
404 (not (mutex-owner m))))
406 (pass-if "locking mutex on behalf of other thread"
407 (let* ((m (make-mutex))
408 (t (begin-thread 'foo)))
410 (eq? (mutex-owner m) t)))
412 (pass-if "locking mutex with no owner"
413 (let ((m (make-mutex)))
415 (not (mutex-owner m))))
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))
421 ;; Avoid false references to M on the stack.
422 (clear-stale-stack-references)
427 (eq? (mutex-owner m) (current-thread)))))))
433 (with-test-prefix "mutex-lock-levels"
435 (pass-if "unlocked level is 0"
436 (let ((m (make-mutex)))
437 (and (not (mutex-locked? m)) (eqv? (mutex-level m) 0))))
439 (pass-if "non-recursive lock level is 1"
440 (let ((m (make-mutex)))
442 (and (mutex-locked? m) (eqv? (mutex-level m) 1))))
444 (pass-if "recursive lock level is >1"
445 (let ((m (make-mutex 'recursive)))
448 (and (mutex-locked? m) (eqv? (mutex-level m) 2)))))
454 (with-test-prefix "mutex-behavior"
456 (pass-if "unchecked unlock"
457 (let* ((m (make-mutex 'unchecked-unlock)))
460 (pass-if "allow external unlock"
461 (let* ((m (make-mutex 'allow-external-unlock))
462 (t (begin-thread (lock-mutex m))))
466 (pass-if "recursive mutexes"
467 (let* ((m (make-mutex 'recursive)))
471 (pass-if "locking abandoned mutex throws exception"
472 (let* ((m (make-mutex))
473 (t (begin-thread (lock-mutex m)))
476 (catch 'abandoned-mutex-error
477 (lambda () (lock-mutex m))
478 (lambda key (set! success #t)))
486 (with-test-prefix "nproc"
488 (pass-if "total-processor-count"
489 (>= (total-processor-count) 1))
491 (pass-if "current-processor-count"
492 (and (>= (current-processor-count) 1)
493 (>= (total-processor-count) (current-processor-count)))))