guile/test-suite/tests/threads.test

;;;; 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))

(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))

(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 "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) 2))))))
	      (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 (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))
		(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))))

	(pass-if "asyncs are still working 1"
	  (asyncs-still-working?))

	)

      ;;
      ;; 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)))))