;;;;
;;;; test-threads.stk			-- Testing Threads
;;;;
;;;; Copyright © 2006-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; 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 of the License, 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 program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 16-Apr-2006 12:54 (eg)
;;;; Last file update: 29-Oct-2010 08:55 (eg)
;;;;

(require "test")

(unless (eq? (%thread-system) 'none)

(thread-handler-error-show #f) ;; don't display errors asap

;;;; These tests are performed when we have threads
;;;; Most of theses tests were stolen in Gauche Scheme distribution
(test-section "Threads")

;;------------------------------------------------------------------
(test-subsection "Basic threads")

(test "current-thread" #t (eq? (current-thread) (current-thread)))

(test "thread?" '(#t #f)
      (list (thread? (current-thread)) (thread? 'foo)))

(test "make-thread" #t (thread? (make-thread (lambda () #f))))

(test "thread-name.1" "foo" (thread-name (make-thread (lambda () #f) "foo")))
(test "thread-name.2" 'foo  (thread-name (make-thread (lambda () #f) 'foo)))

(test "thread-specific" "hello"
      (begin
	(thread-specific-set! (current-thread) "hello")
	(thread-specific (current-thread))))

(test "thread-start!" "hello"
      (call-with-output-string
          (lambda (p)
	    (let ((t (thread-start! (make-thread (lambda () (display "hello" p))))))
	      (thread-join! t)
	      t))))

;; calculate fibonacchi in awful way
(define (mt-fib n)
  (let ((threads (make-vector n)))
    (dotimes (i n)
      (vector-set! threads
		   i
		   (make-thread
		    (case i
		      ((0)  (lambda () 1))
		      ((1)  (lambda () 2))
		      (else (lambda ()
			      (+ (thread-join! (vector-ref threads (- i 1)))
				 (thread-join! (vector-ref threads (- i 2))))))))))
    (dotimes (i n)
      (thread-start! (vector-ref threads (- n i 1))))
    (thread-join! (vector-ref threads (- n 1)))))

(test "thread-join!" 14930352 (mt-fib 35))

(test "Terminate a non started thread"
      42
      (let ((t (make-thread list)))
	(thread-terminate! t)
	42))

(test "Terminate a running thread"
      43
      (let ((t (make-thread (lambda () (thread-sleep! 100000)))))
	(thread-start! t)
	(thread-terminate! t)
	43))

(test "Terminate a (probably) terminated thread"
      44
      (let ((t (make-thread list)))
	(thread-start! t)
;	(thread-yield!)
;	(thread-sleep! 0.01)
	(thread-terminate! t)
	44))

;;---------------------------------------------------------------------
(test-subsection "Thread and error")

(test "uncaught-exception.1" 123
       (let ((t (make-thread (lambda () (error "foo")))))
         (thread-start! t)
         (with-handler (lambda (c)
			 ;; c is the condition associated to error "foo"
			 123)
           (thread-join! t))))

(test "uncaught-exception.2"
      1230
      (let ((t (thread-start! (make-thread (lambda () (raise 123))))))
	(with-handler (lambda (exc)
			(if (uncaught-exception? exc)
			    (* 10 (uncaught-exception-reason exc))
			    99999))
	  (+ 1 (thread-join! t)))))


;;------------------------------------------------------------------
(test-subsection "Parameterize and threads")

(test "parameter.1" 1
      (let ((local #f))
	(thread-join! (thread-start!
		       (make-thread
			(lambda ()
			  (set! local (make-parameter 1))))))
         (thread-join! (thread-start!
			(make-thread
			 (lambda ()
			   (local)))))))

(define *thr1-val* #f)
(define *thr2-val* #f)
(define p (make-parameter 3))

(test "parameter.2" '(3 4 5)
       (let ((th1 (make-thread
                   (lambda ()
		     (parameterize ((p 4))
		       (thread-yield!)
		       (set! *thr1-val* (p))))))
             (th2 (make-thread
                   (lambda ()
		     (parameterize ((p 5))
		       (thread-yield!)
		       (set! *thr2-val* (p)))))))
         (thread-start! th1)
         (thread-start! th2)
         (thread-join! th1)
         (thread-join! th2)
         (list (p) *thr1-val* *thr2-val*)))

;------------------------------------------------------------------
(test-subsection "Mutexes")

(test "make-mutex" #t (mutex? (make-mutex)))
(test "mutex-name" 'foo (mutex-name (make-mutex 'foo)))

(test "mutex-specific" "hello"
      (let ((m (make-mutex 'bar)))
	(mutex-specific-set! m "hello")
	(mutex-specific m)))

(test "lock and unlock - no blocking" #t
      (let ((m (make-mutex)))
	(mutex-lock! m)
	(mutex-unlock! m)))

(test "mutex-state"
       (list 'not-abandoned (current-thread) 'not-owned 'not-abandoned)
       (let ((m (make-mutex)))
	 (list (mutex-state m)
	       (begin
		 (mutex-lock! m)
		 (mutex-state m))
	       (begin
		 (mutex-unlock! m)
		 (mutex-lock! m #f #f)
		 (mutex-state m))
	       (begin (mutex-unlock! m)
		      (mutex-state m)))))
(test "lock/unlock"
      '((put a) (get a) (put b) (get b) (put c) (get c))
      (let ((log '())
	    (cell #f)
	    (m (make-mutex)))
	(define (put! msg)
	  (mutex-lock! m)
	  (if cell
	      (begin (mutex-unlock! m)
                     (thread-yield!)
                     (put! msg))
	      (begin (set! cell msg)
		     (set! log `((put ,msg) ,@log))
		     (mutex-unlock! m))))
	(define (get!)
	  (mutex-lock! m)
	  (if cell
	      (let(( r cell))
		(set! cell #f)
		(set! log `((get ,r) ,@log))
		(mutex-unlock! m)
		r)
	      (begin (mutex-unlock! m)
                     (thread-yield!)
                     (get!))))
	(define (producer)
	  (put! 'a)
	  (put! 'b)
	  (put! 'c))
	(define (consumer)
	  (get!)
	  (get!)
	  (get!))
	(let ((tp (thread-start! (make-thread producer 'producer)))
	      (tc (thread-start! (make-thread consumer 'consumer))))
	  (thread-join! tp)
	  (thread-join! tc)
	  (reverse log))))

(test "lock with timeout"
      '(#t #f #f #f #f #t #t)
      (let ((m (make-mutex)))
        (let* ((r0 (mutex-lock! m))
               (r1 (mutex-lock! m 0))
               (r2 (mutex-lock! m 0.05))
               (r3 (mutex-lock! m (seconds->time (+ (time->seconds (current-time))
						    0.05))))
               (r4 (mutex-lock! m (seconds->time (- (time->seconds (current-time))
						    0.05))))
               (r5 (mutex-unlock! m))
               (r6 (mutex-lock! m 0)))
          (mutex-unlock! m)
          (list r0 r1 r2 r3 r4 r5 r6))))

(test "recursive mutex"
      (list (current-thread) 0 'not-abandoned)
      (letrec ()
	(define (mutex-lock-recursively! mutex)
	  (if (eq? (mutex-state mutex) (current-thread))
	      (let ((n (mutex-specific mutex)))
		(mutex-specific-set! mutex (+ n 1)))
	      (begin
		(mutex-lock! mutex)
		(mutex-specific-set! mutex 0))))

	(define (mutex-unlock-recursively! mutex)
	  (let ((n (mutex-specific mutex)))
	    (if (= n 0)
		(mutex-unlock! mutex)
		(mutex-specific-set! mutex (- n 1)))))
	(let ((m (make-mutex)))
	  (mutex-specific-set! m 0)
	  (mutex-lock-recursively! m)
	  (mutex-lock-recursively! m)
	  (mutex-lock-recursively! m)
	  (let ((r0 (mutex-state m)))
	    (mutex-unlock-recursively! m)
	    (mutex-unlock-recursively! m)
	    (let ((r1 (mutex-specific m)))
	      (mutex-unlock-recursively! m)
	      (list r0 r1 (mutex-state m)))))))


;;------------------------------------------------------------------
(test-subsection "Condition Variables")

(test "make-condition-variable"
      #t
      (condition-variable? (make-condition-variable)))

(test "condition-varaible-name"
      'foo
      (condition-variable-name (make-condition-variable 'foo)))

(test "condition-variable-specific"
      "hello"
      (let ((c (make-condition-variable 'foo)))
	(condition-variable-specific-set! c "hello")
	(condition-variable-specific c)))

(test "condition-variable-signal!"
      '((put a) (get a) (put b) (get b) (put c) (get c))
      (let ((log '())
	    (cell #f)
	    (m  (make-mutex))
	    (put-cv (make-condition-variable))
	    (get-cv (make-condition-variable)))
	(define (put! msg)
	  (mutex-lock! m)
	  (if cell
	      (begin (mutex-unlock! m put-cv) (put! msg))
	      (begin (set! cell msg)
		     (set! log (cons `(put ,msg) log))
		     (condition-variable-signal! get-cv)
		     (mutex-unlock! m))))
	(define (get!)
	  (mutex-lock! m)
	  (if cell
	      (let ((r cell))
		(set! cell #f)
		(set! log (cons `(get ,r) log))
		(condition-variable-signal! put-cv)
		(mutex-unlock! m)
		r)
	      (begin
		(mutex-unlock! m get-cv) (get!))))
	(define (producer)
	  (put! 'a)
	  (put! 'b)
	  (put! 'c))
	(define (consumer)
	  (get!)
	  (get!)
	  (get!))

	(let ((tp (thread-start! (make-thread producer 'producer)))
	      (tc (thread-start! (make-thread consumer 'consumer))))
	  (thread-join! tp)
	  (thread-join! tc)
	  (reverse log))))

(test-section-end)

)