mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
356 lines
9.1 KiB
Scheme
356 lines
9.1 KiB
Scheme
;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
|
|
;;;;
|
|
;;;; Copyright 2003, 2006, 2007 Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or modify
|
|
;;;; it under the terms of the GNU General Public License as published by
|
|
;;;; the Free Software Foundation; either version 2, or (at your option)
|
|
;;;; any later version.
|
|
;;;;
|
|
;;;; This program is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;;; GNU General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU General Public License
|
|
;;;; along with this software; see the file COPYING. If not, write to
|
|
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
;;;; Boston, MA 02110-1301 USA
|
|
|
|
(define-module (test-threads)
|
|
:use-module (ice-9 threads)
|
|
:use-module (test-suite lib))
|
|
|
|
|
|
(if (provided? 'threads)
|
|
(begin
|
|
|
|
(with-test-prefix "parallel"
|
|
(pass-if "no forms"
|
|
(call-with-values
|
|
(lambda ()
|
|
(parallel))
|
|
(lambda ()
|
|
#t)))
|
|
|
|
(pass-if "1"
|
|
(call-with-values
|
|
(lambda ()
|
|
(parallel 1))
|
|
(lambda (x)
|
|
(equal? x 1))))
|
|
|
|
(pass-if "1 2"
|
|
(call-with-values
|
|
(lambda ()
|
|
(parallel 1 2))
|
|
(lambda (x y)
|
|
(and (equal? x 1)
|
|
(equal? y 2)))))
|
|
|
|
(pass-if "1 2 3"
|
|
(call-with-values
|
|
(lambda ()
|
|
(parallel 1 2 3))
|
|
(lambda (x y z)
|
|
(and (equal? x 1)
|
|
(equal? y 2)
|
|
(equal? z 3))))))
|
|
|
|
;;
|
|
;; n-par-for-each
|
|
;;
|
|
|
|
(with-test-prefix "n-par-for-each"
|
|
|
|
(pass-if "0 in limit 10"
|
|
(n-par-for-each 10 noop '())
|
|
#t)
|
|
|
|
(pass-if "6 in limit 10"
|
|
(let ((v (make-vector 6 #f)))
|
|
(n-par-for-each 10 (lambda (n)
|
|
(vector-set! v n #t))
|
|
'(0 1 2 3 4 5))
|
|
(equal? v '#(#t #t #t #t #t #t))))
|
|
|
|
(pass-if "6 in limit 1"
|
|
(let ((v (make-vector 6 #f)))
|
|
(n-par-for-each 1 (lambda (n)
|
|
(vector-set! v n #t))
|
|
'(0 1 2 3 4 5))
|
|
(equal? v '#(#t #t #t #t #t #t))))
|
|
|
|
(pass-if "6 in limit 2"
|
|
(let ((v (make-vector 6 #f)))
|
|
(n-par-for-each 2 (lambda (n)
|
|
(vector-set! v n #t))
|
|
'(0 1 2 3 4 5))
|
|
(equal? v '#(#t #t #t #t #t #t))))
|
|
|
|
(pass-if "6 in limit 3"
|
|
(let ((v (make-vector 6 #f)))
|
|
(n-par-for-each 3 (lambda (n)
|
|
(vector-set! v n #t))
|
|
'(0 1 2 3 4 5))
|
|
(equal? v '#(#t #t #t #t #t #t)))))
|
|
|
|
;;
|
|
;; n-for-each-par-map
|
|
;;
|
|
|
|
(with-test-prefix "n-for-each-par-map"
|
|
|
|
(pass-if "0 in limit 10"
|
|
(n-for-each-par-map 10 noop noop '())
|
|
#t)
|
|
|
|
(pass-if "6 in limit 10"
|
|
(let ((result '()))
|
|
(n-for-each-par-map 10
|
|
(lambda (n) (set! result (cons n result)))
|
|
(lambda (n) (* 2 n))
|
|
'(0 1 2 3 4 5))
|
|
(equal? result '(10 8 6 4 2 0))))
|
|
|
|
(pass-if "6 in limit 1"
|
|
(let ((result '()))
|
|
(n-for-each-par-map 1
|
|
(lambda (n) (set! result (cons n result)))
|
|
(lambda (n) (* 2 n))
|
|
'(0 1 2 3 4 5))
|
|
(equal? result '(10 8 6 4 2 0))))
|
|
|
|
(pass-if "6 in limit 2"
|
|
(let ((result '()))
|
|
(n-for-each-par-map 2
|
|
(lambda (n) (set! result (cons n result)))
|
|
(lambda (n) (* 2 n))
|
|
'(0 1 2 3 4 5))
|
|
(equal? result '(10 8 6 4 2 0))))
|
|
|
|
(pass-if "6 in limit 3"
|
|
(let ((result '()))
|
|
(n-for-each-par-map 3
|
|
(lambda (n) (set! result (cons n result)))
|
|
(lambda (n) (* 2 n))
|
|
'(0 1 2 3 4 5))
|
|
(equal? result '(10 8 6 4 2 0)))))
|
|
|
|
;;
|
|
;; timed mutex locking
|
|
;;
|
|
|
|
(with-test-prefix "lock-mutex"
|
|
|
|
(pass-if "timed locking fails if timeout exceeded"
|
|
(let ((m (make-mutex)))
|
|
(lock-mutex m)
|
|
(let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
|
|
(not (join-thread t)))))
|
|
|
|
(pass-if "timed locking succeeds if mutex unlocked within timeout"
|
|
(let* ((m (make-mutex))
|
|
(c (make-condition-variable))
|
|
(cm (make-mutex)))
|
|
(lock-mutex cm)
|
|
(let ((t (begin-thread (begin (lock-mutex cm)
|
|
(signal-condition-variable c)
|
|
(unlock-mutex cm)
|
|
(lock-mutex m
|
|
(+ (current-time) 2))))))
|
|
(lock-mutex m)
|
|
(wait-condition-variable c cm)
|
|
(unlock-mutex cm)
|
|
(sleep 1)
|
|
(unlock-mutex m)
|
|
(join-thread t)))))
|
|
|
|
;;
|
|
;; timed mutex unlocking
|
|
;;
|
|
|
|
(with-test-prefix "unlock-mutex"
|
|
|
|
(pass-if "timed unlocking returns #f if timeout exceeded"
|
|
(let ((m (make-mutex))
|
|
(c (make-condition-variable)))
|
|
(lock-mutex m)
|
|
(not (unlock-mutex m c (current-time)))))
|
|
|
|
(pass-if "timed unlocking returns #t if condition signaled"
|
|
(let ((m1 (make-mutex))
|
|
(m2 (make-mutex))
|
|
(c1 (make-condition-variable))
|
|
(c2 (make-condition-variable)))
|
|
(lock-mutex m1)
|
|
(let ((t (begin-thread (begin (lock-mutex m1)
|
|
(signal-condition-variable c1)
|
|
(lock-mutex m2)
|
|
(unlock-mutex m1)
|
|
(unlock-mutex m2
|
|
c2
|
|
(+ (current-time)
|
|
2))))))
|
|
(wait-condition-variable c1 m1)
|
|
(unlock-mutex m1)
|
|
(lock-mutex m2)
|
|
(signal-condition-variable c2)
|
|
(unlock-mutex m2)
|
|
(join-thread t)))))
|
|
|
|
;;
|
|
;; timed joining
|
|
;;
|
|
|
|
(with-test-prefix "join-thread"
|
|
|
|
(pass-if "timed joining fails if timeout exceeded"
|
|
(let* ((m (make-mutex))
|
|
(c (make-condition-variable))
|
|
(t (begin-thread (begin (lock-mutex m)
|
|
(wait-condition-variable c m))))
|
|
(r (join-thread t (current-time))))
|
|
(cancel-thread t)
|
|
(not r)))
|
|
|
|
(pass-if "join-thread returns timeoutval on timeout"
|
|
(let* ((m (make-mutex))
|
|
(c (make-condition-variable))
|
|
(t (begin-thread (begin (lock-mutex m)
|
|
(wait-condition-variable c m))))
|
|
(r (join-thread t (current-time) 'foo)))
|
|
(cancel-thread t)
|
|
(eq? r 'foo)))
|
|
|
|
|
|
(pass-if "timed joining succeeds if thread exits within timeout"
|
|
(let ((t (begin-thread (begin (sleep 1) #t))))
|
|
(join-thread t (+ (current-time) 2)))))
|
|
|
|
;;
|
|
;; thread cancellation
|
|
;;
|
|
|
|
(with-test-prefix "cancel-thread"
|
|
|
|
(pass-if "cancel succeeds"
|
|
(let ((m (make-mutex)))
|
|
(lock-mutex m)
|
|
(let ((t (begin-thread (begin (lock-mutex m) 'foo))))
|
|
(cancel-thread t)
|
|
(join-thread t)
|
|
#t)))
|
|
|
|
(pass-if "handler result passed to join"
|
|
(let ((m (make-mutex)))
|
|
(lock-mutex m)
|
|
(let ((t (begin-thread (lock-mutex m))))
|
|
(set-thread-cleanup! t (lambda () 'foo))
|
|
(cancel-thread t)
|
|
(eq? (join-thread t) 'foo))))
|
|
|
|
(pass-if "can cancel self"
|
|
(let ((m (make-mutex)))
|
|
(lock-mutex m)
|
|
(let ((t (begin-thread (begin
|
|
(set-thread-cleanup! (current-thread)
|
|
(lambda () 'foo))
|
|
(cancel-thread (current-thread))
|
|
(lock-mutex m)))))
|
|
(eq? (join-thread t) 'foo))))
|
|
|
|
(pass-if "handler supplants final expr"
|
|
(let ((t (begin-thread (begin (set-thread-cleanup! (current-thread)
|
|
(lambda () 'bar))
|
|
'foo))))
|
|
(eq? (join-thread t) 'bar)))
|
|
|
|
(pass-if "remove handler by setting false"
|
|
(let ((m (make-mutex)))
|
|
(lock-mutex m)
|
|
(let ((t (begin-thread (lock-mutex m) 'bar)))
|
|
(set-thread-cleanup! t (lambda () 'foo))
|
|
(set-thread-cleanup! t #f)
|
|
(unlock-mutex m)
|
|
(eq? (join-thread t) 'bar))))
|
|
|
|
(pass-if "initial handler is false"
|
|
(not (thread-cleanup (current-thread)))))
|
|
|
|
;;
|
|
;; mutex ownership
|
|
;;
|
|
|
|
(with-test-prefix "mutex-ownership"
|
|
(pass-if "mutex ownership for locked mutex"
|
|
(let ((m (make-mutex)))
|
|
(lock-mutex m)
|
|
(eq? (mutex-owner m) (current-thread))))
|
|
|
|
(pass-if "mutex ownership for unlocked mutex"
|
|
(let ((m (make-mutex)))
|
|
(not (mutex-owner m))))
|
|
|
|
(pass-if "locking mutex on behalf of other thread"
|
|
(let* ((m (make-mutex))
|
|
(t (begin-thread 'foo)))
|
|
(lock-mutex m #f t)
|
|
(eq? (mutex-owner m) t)))
|
|
|
|
(pass-if "locking mutex with no owner"
|
|
(let ((m (make-mutex)))
|
|
(lock-mutex m #f #f)
|
|
(not (mutex-owner m)))))
|
|
|
|
;;
|
|
;; mutex lock levels
|
|
;;
|
|
|
|
(with-test-prefix "mutex-lock-levels"
|
|
|
|
(pass-if "unlocked level is 0"
|
|
(let ((m (make-mutex)))
|
|
(and (not (mutex-locked? m)) (eqv? (mutex-level m) 0))))
|
|
|
|
(pass-if "non-recursive lock level is 1"
|
|
(let ((m (make-mutex)))
|
|
(lock-mutex m)
|
|
(and (mutex-locked? m) (eqv? (mutex-level m) 1))))
|
|
|
|
(pass-if "recursive lock level is >1"
|
|
(let ((m (make-mutex 'recursive)))
|
|
(lock-mutex m)
|
|
(lock-mutex m)
|
|
(and (mutex-locked? m) (eqv? (mutex-level m) 2)))))
|
|
|
|
;;
|
|
;; mutex behavior
|
|
;;
|
|
|
|
(with-test-prefix "mutex-behavior"
|
|
|
|
(pass-if "unchecked unlock"
|
|
(let* ((m (make-mutex 'unchecked-unlock)))
|
|
(unlock-mutex m)))
|
|
|
|
(pass-if "allow external unlock"
|
|
(let* ((m (make-mutex 'allow-external-unlock))
|
|
(t (begin-thread (lock-mutex m))))
|
|
(join-thread t)
|
|
(unlock-mutex m)))
|
|
|
|
(pass-if "recursive mutexes"
|
|
(let* ((m (make-mutex 'recursive)))
|
|
(lock-mutex m)
|
|
(lock-mutex m)))
|
|
|
|
(pass-if "locking abandoned mutex throws exception"
|
|
(let* ((m (make-mutex))
|
|
(t (begin-thread (lock-mutex m)))
|
|
(success #f))
|
|
(join-thread t)
|
|
(catch 'abandoned-mutex-error
|
|
(lambda () (lock-mutex m))
|
|
(lambda key (set! success #t)))
|
|
success)))))
|