summaryrefslogtreecommitdiff
path: root/test-suite/tests/threads.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/threads.test')
-rw-r--r--test-suite/tests/threads.test450
1 files changed, 450 insertions, 0 deletions
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
new file mode 100644
index 000000000..efdf36db2
--- /dev/null
+++ b/test-suite/tests/threads.test
@@ -0,0 +1,450 @@
+;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
+;;;;
+;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013,
+;;;; 2014 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; 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 (system base compile)
+ #:use-module (test-suite lib))
+
+(define (asyncs-still-working?)
+ (let ((a #f))
+ (system-async-mark (lambda ()
+ (set! a #t)))
+ ;; The point of the following (equal? ...) is to go through
+ ;; primitive code (scm_equal_p) that includes a SCM_TICK call and
+ ;; hence gives system asyncs a chance to run. Of course the
+ ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the
+ ;; near future we may be using the VM instead of the traditional
+ ;; compiler, and then we will still want asyncs-still-working? to
+ ;; work. (The VM should probably have SCM_TICK calls too, but
+ ;; let's not rely on that here.)
+ (equal? '(a b c) '(a b c))
+ a))
+
+(define (require-cancel-thread)
+ ;; Skip the test when 'cancel-thread' is unavailable.
+ (unless (defined? 'cancel-thread)
+ (throw 'unresolved)))
+
+(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))))))
+
+ ;;
+ ;; par-map
+ ;;
+
+ (with-test-prefix "par-map"
+
+ (pass-if "simple"
+ (compile '(letrec ((fibo (lambda (n)
+ (if (<= n 1)
+ n
+ (+ (fibo (- n 1))
+ (fibo (- n 2)))))))
+ (equal? (par-map fibo (iota 13))
+ (map fibo (iota 13))))
+ #:to 'value
+ #:env (current-module)))
+
+ (pass-if-equal "long list" (map 1+ (iota 10000))
+ ;; In Guile 2.0.7, this would trigger a stack overflow.
+ ;; See <http://bugs.gnu.org/13188>.
+ (par-map 1+ (iota 10000))))
+
+ ;;
+ ;; par-for-each
+ ;;
+
+ (with-test-prefix "par-for-each"
+
+ (pass-if "simple"
+ (compile '(let ((v (make-vector 6 #f)))
+ (par-for-each (lambda (n)
+ (vector-set! v n n))
+ (iota 6))
+ (equal? v (list->vector (iota 6))))
+ #:to 'value
+ #:env (current-module))))
+
+ ;;
+ ;; 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 "asyncs are still working 2"
+ (asyncs-still-working?))
+
+ (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 "asyncs are still working 3"
+ (asyncs-still-working?))
+
+ (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 "asyncs are still working 6"
+ (asyncs-still-working?))
+
+ (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) 5))))))
+ (lock-mutex m)
+ (wait-condition-variable c cm)
+ (unlock-mutex cm)
+ (sleep 1)
+ (unlock-mutex m)
+ (join-thread t))))
+
+ (pass-if "asyncs are still working 7"
+ (asyncs-still-working?))
+
+ )
+
+ ;;
+ ;; timed mutex unlocking
+ ;;
+
+ (with-test-prefix "unlock-mutex"
+
+ (pass-if "asyncs are still working 5"
+ (asyncs-still-working?))
+
+ (pass-if "timed unlocking returns #f if timeout exceeded"
+ (let ((m (make-mutex))
+ (c (make-condition-variable)))
+ (lock-mutex m)
+ (not (wait-condition-variable c m (current-time)))))
+
+ (pass-if "asyncs are still working 4"
+ (asyncs-still-working?))
+
+ (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
+ (lock-mutex m1)
+ (signal-condition-variable c1)
+ (lock-mutex m2)
+ (unlock-mutex m1)
+ (wait-condition-variable c2 m2 (+ (current-time) 5)))))
+ (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"
+ (require-cancel-thread)
+ (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"
+ (require-cancel-thread)
+ (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) 5))))
+
+ (pass-if "asyncs are still working 1"
+ (asyncs-still-working?))
+
+ ;; scm_join_thread_timed has a SCM_TICK in the middle of it,
+ ;; to allow asyncs to run (including signal delivery). We
+ ;; used to have a bug whereby if the joined thread terminated
+ ;; at the same time as the joining thread is in this SCM_TICK,
+ ;; scm_join_thread_timed would not notice and would hang
+ ;; forever. So in this test we are setting up the following
+ ;; sequence of events.
+ ;; T=0 other thread is created and starts running
+ ;; T=2 main thread sets up an async that will sleep for 10 seconds
+ ;; T=2 main thread calls join-thread, which will...
+ ;; T=2 ...call the async, which starts sleeping
+ ;; T=5 other thread finishes its work and terminates
+ ;; T=7 async completes, main thread continues inside join-thread.
+ (pass-if "don't hang when joined thread terminates in SCM_TICK"
+ (let ((other-thread (make-thread sleep 5)))
+ (letrec ((delay-count 10)
+ (aproc (lambda ()
+ (set! delay-count (- delay-count 1))
+ (if (zero? delay-count)
+ (sleep 5)
+ (system-async-mark aproc)))))
+ (sleep 2)
+ (system-async-mark aproc)
+ (join-thread other-thread)))
+ #t))
+
+ ;;
+ ;; thread cancellation
+ ;;
+
+ (with-test-prefix "cancel-thread"
+
+ (pass-if "cancel succeeds"
+ (require-cancel-thread)
+ (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 "cancel result passed to join"
+ (require-cancel-thread)
+ (let ((m (make-mutex)))
+ (lock-mutex m)
+ (let ((t (begin-thread (lock-mutex m))))
+ (cancel-thread t 'foo)
+ (eq? (join-thread t) 'foo))))
+
+ (pass-if "can cancel self"
+ (require-cancel-thread)
+ (let ((m (make-mutex)))
+ (lock-mutex m)
+ (let ((t (begin-thread (begin
+ (cancel-thread (current-thread) 'foo)
+ (lock-mutex m)))))
+ (eq? (join-thread t) 'foo)))))
+
+ ;;
+ ;; 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 "mutex with owner not retained (bug #27450)"
+ (let ((g (make-guardian)))
+ (g (let ((m (make-mutex))) (lock-mutex m) m))
+
+ ;; Avoid false references to M on the stack.
+ (clear-stale-stack-references)
+
+ (gc) (gc)
+ (let ((m (g)))
+ (and (mutex? m)
+ (eq? (mutex-owner m) (current-thread)))))))
+
+ ;;
+ ;; 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 "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 "abandoned mutexes are dead"
+ (let* ((m (make-mutex)))
+ (join-thread (begin-thread (lock-mutex m)))
+ (not (lock-mutex m (+ (current-time) 0.1))))))))
+
+
+;;
+;; nproc
+;;
+
+(with-test-prefix "nproc"
+
+ (pass-if "total-processor-count"
+ (>= (total-processor-count) 1))
+
+ (pass-if "current-processor-count"
+ (and (>= (current-processor-count) 1)
+ (>= (total-processor-count) (current-processor-count)))))