;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013,
+;;;; 2014 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,
+;;;; 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 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
+;;;; 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 (test-suite lib))
-
+ #: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
(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-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)
(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))
(signal-condition-variable c)
(unlock-mutex cm)
(lock-mutex m
- (+ (current-time) 2))))))
+ (+ (current-time) 5))))))
(lock-mutex m)
(wait-condition-variable c cm)
(unlock-mutex cm)
(sleep 1)
(unlock-mutex m)
- (join-thread t)))))
+ (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 (unlock-mutex m c (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))
(signal-condition-variable c1)
(lock-mutex m2)
(unlock-mutex m1)
- (unlock-mutex m2
- c2
- (+ (current-time)
- 2))))))
+ (unlock-mutex m2
+ c2
+ (+ (current-time)
+ 5))))))
(wait-condition-variable c1 m1)
(unlock-mutex m1)
(lock-mutex m2)
(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)
(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)
(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)))))
+ (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))))
#t)))
(pass-if "handler result passed to join"
+ (require-cancel-thread)
(let ((m (make-mutex)))
(lock-mutex m)
(let ((t (begin-thread (lock-mutex m))))
(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
(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))))
+
+ (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
;;
(pass-if "recursive mutexes"
(let* ((m (make-mutex 'recursive)))
(lock-mutex m)
- (lock-mutex m)))
+ (lock-mutex m)))
(pass-if "locking abandoned mutex throws exception"
(let* ((m (make-mutex))
(lambda () (lock-mutex m))
(lambda key (set! success #t)))
success)))))
+
+
+;;
+;; 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)))))
HCoop / bpt / guile.git / blobdiff