;*=====================================================================*/
;*    serrano/prgm/project/bigloo/fthread/src/Llib/thread.scm          */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Mon Feb  4 11:49:11 2002                          */
;*    Last change :  Sat Aug 16 15:05:50 2003 (serrano)                */
;*    Copyright   :  2002-03 Manuel Serrano                            */
;*    -------------------------------------------------------------    */
;*    The public FairThreads implementation.                           */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __ft_thread

   (include "_thread.sch"
	    "debug.sch")
   
   (with   __ft_eval)
   
   (import __ft_types
	   __ft_%types
	   __ft_%thread
	   __ft_scheduler
	   __ft_%scheduler
	   __ft_env
	   __ft_%env
	   __ft_signal
	   __ft_exception
	   __ft_%exception
	   __ft_%mutex)
   
   (static (class %thread::thread)
	   
	   (class %sigjoin
	      (thread::thread read-only)))
   
   (export (make-thread::thread ::procedure . name)
	   (thread-sleep! ::int)
	   (thread-await! ::obj . timeout)
	   (thread-await*! ::pair . timeout)
	   (thread-await-values! ::obj . timeout)
	   (thread-await-values*! ::pair . timeout)
	   (thread-join! ::thread . timeout)
	   (current-thread)
	   (thread-start! ::thread . scheduler)
	   (thread-terminate! ::thread)
	   (thread-suspend! ::thread)
	   (thread-resume! ::thread)
	   (thread-yield!)
	   (thread-get-values! ::obj)
	   (thread-get-values*! ::pair)))

;*---------------------------------------------------------------------*/
;*    object-equal? ::%sigjoin ...                                     */
;*---------------------------------------------------------------------*/
(define-method (object-equal? o1::%sigjoin o2)
   (and (%sigjoin? o2)
	(eq? (%sigjoin-thread o1)
	     (%sigjoin-thread o2))))

;*---------------------------------------------------------------------*/
;*    make-thread ...                                                  */
;*---------------------------------------------------------------------*/
(define (make-thread thunk . name)
   (define (thread-body t)
      (with-access::%thread t (%state %result %mutexes cleanup scheduler)
	 ;; terminate is used to abruptly terminate a thread
	 (let ((res (bind-exit (terminate)
		       (%thread-%terminate-set! t terminate)
		       (try (thunk)
			    (lambda (escape obj proc msg)
			       (notify-error obj proc msg)
			       (terminate #f))))))
	    ;; store the result of the thread
	    (set! %result res)
	    ;; abandon all the mutexes owned by the thread
  	    (for-each abandon-mutex! %mutexes)
	    (set! %mutexes '())
	    ;; broadcast a signal for the thread termination
	    (broadcast! (instantiate::%sigjoin (thread t)) res)
	    ;; invoke the thread cleanup
	    (if (procedure? cleanup)
		(if (correct-arity? cleanup 1)
		    (cleanup res)
		    (error t "Illegal cleanup function" cleanup)))
	    ;; kill the thread is now dead and switch back to the scheduler
	    (%thread-kill! t))))
   (if (not (correct-arity? thunk 0))
       (error "make-thread"
	      "Illegal thread body (should be a procedure of 0 arguments)"
	      thunk)
       (let ((the-name (if (null? name)
			   (gensym 'fairthread)
			   (cond
			      ((symbol? (car name))
			       (car name))
			      ((string? (car name))
			       (string->symbol (car name)))
			      (else
			       (gensym 'fairthread))))))
	  (letrec ((t (instantiate::%thread
			 (%builtin ($bglthread-new/name
				    (lambda () (thread-body t))
				    the-name))
			 (name (if (pair? name) (car name) the-name))
			 (%exc-handlers (list uncaught-exception-hdl)))))
	     (%thread-setup! t)
	     t))))

;*---------------------------------------------------------------------*/
;*    thread-join! ...                                                 */
;*---------------------------------------------------------------------*/
(define (thread-join! t . args)
   (with-access::thread t (%state %result %exc-result %exc-raised)
      (if (or (eq? %state 'terminated) (eq? %state 'dead))
	  (if %exc-raised
	      (raise %exc-result)
	      %result)
	  (match-case args
	     ((?to ?to-val)
	      (if (not (number? to))
		  (bigloo-type-error "thread-join" "integer" to)
		  (let ((v (thread-await! (instantiate::%sigjoin
					     (thread t))
					  to)))
		     (cond
			((terminated-thread-exception? (thread-%exc-result t))
			 (raise (thread-%exc-result t)))
			(v
			 v)
			(else
			 to-val)))))
	     ((?to)
	      (if (not (number? to))
		  (bigloo-type-error "thread-join" "integer" to)
		  (let ((v (thread-await! (instantiate::%sigjoin
					     (thread t))
					  to)))
		     (cond
			((terminated-thread-exception? (thread-%exc-result t))
			 (raise (thread-%exc-result t)))
			(v
			 v)
			(else
			 (raise *join-timeout-exception*))))))
	     (else
	      (let ((v (thread-await! (instantiate::%sigjoin
					 (thread t)))))
		 (cond
		    ((terminated-thread-exception? (thread-%exc-result t))
		     (raise (thread-%exc-result t)))
		    (else
		     v))))))))

;*---------------------------------------------------------------------*/
;*    thread-await! ...                                                */
;*---------------------------------------------------------------------*/
(define (thread-await! sig . arg)
   (let* ((t (current-thread)))
      ;; wait until the signal is present
      (define (await scdl::scheduler sig::obj)
	 (let ((env (scheduler-env+ scdl)))
	    (cond
	       ((signal-lookup sig env)
		;; the signal is present we return its value
		(signal-value sig env))
	       ((and (%sigasync? sig) (not (%sigasync-spawned sig)))
		;; this is an asynchronous signal not already spawned 
		(with-access::%sigasync sig (spawned id thunk)
		   (set! spawned #t)
		   ;; detach the thread, i.e., make it asynchronous (unfair)
		   (%thread-asynchronize! t id)
		   (let ((res (thunk)))
		      ;; attach the thread, i.e., make it synchronous (fair)
		      (%thread-synchronize! t)
		      (%broadcast! scdl sig res)
		      res)))
	       (else
		;; the signal is absent, we block the thread on the signal
		(signal-register-thread! sig env t)
		(%thread-cooperate t)
		;; we reach this point when the signal has been emitted
		(signal-value sig env)))))
      ;; await at most n instants until the signal is present
      (define (await-ntimes scdl::scheduler sig::obj timeout)
	 (if (and (number? timeout) (> timeout 0))
	     (let ((env (scheduler-env+ scdl)))
		(cond
		   ((signal-lookup sig env)
		    (signal-value sig env))
		   (else
		    ;; register the thread on the signal
		    (signal-register-thread! sig env t)
		    ;; if we are waiting for an asynchronous signal,
		    ;; it is time to spawn it
		    (if (%sigasync? sig)
			(%scheduler-spawn-async scdl sig))
		    ;; we now mark that the current thread is timeout on SIG
		    (%thread-timeout! t timeout)
		    ;; we reach this point when the thread is unblocked
		    (if (signal-lookup sig env)
			;; we have a value for the signal
			(signal-value sig env)
			;; we got unblock because of the timeout
			#f))))
	     (error "thread-await" "Illegal timeout" timeout)))
      (cond
	 ((not (thread? t))
	  (error "thread-await" "no such thread" t))
	 ((not (%thread-attached? t))
	  (error "thread-await" "unattached thread" t))
	 ((pair? arg)
	  (await-ntimes (thread-scheduler t) sig (car arg)))
	 (else
	  (await (thread-scheduler t) sig)))))

;*---------------------------------------------------------------------*/
;*    thread-await*! ...                                               */
;*---------------------------------------------------------------------*/
(define (thread-await*! s* . arg)
   (let* ((t (current-thread)))
      ;; await until one of the signals is present
      (define (await* e* s)
	 (let ((env (scheduler-env+ s)))
	    (let loop ((es e*))
	       (cond
		  ((null? es)
		   (let ((scdl (thread-scheduler t)))
		      (for-each (lambda (e)
				   (signal-register-thread! e env t))
				e*)
		      (%thread-cooperate t)
		      (values (%thread-%awake-value t)
			      (%thread-%awake-signal t))))
		  ((signal-lookup (car es) env)
		   (values (signal-value (car es) env) (car es)))
		  (else
		   (loop (cdr es)))))))
      ;; await at most n instants until one of the signals is present
      (define (await*-ntimes e* s timeout)
	 (if (and (number? timeout) (>= timeout 0))
	     (let ((env (scheduler-env+ s)))
		(let loop ((es e*)
			   (stage 'init))
		   (cond
		      ((null? es)
		       (if (eq? stage 'init)
			   (let ((scdl (thread-scheduler t)))
			      (for-each (lambda (e)
					   (signal-register-thread! e env t))
					e*)
			      (%thread-timeout! t timeout)
			      (loop e* 'end))
			   (values #f #f)))
		      ((signal-lookup (car es) env)
		       (values (signal-value (car es) env) (car es)))
		      (else
		       (loop (cdr es) stage)))))
	     (error "thread-await*" "Illegal timeout" timeout)))
      (cond
	 ((not (thread? t))
	  (error "thread-await" "no such thread" t))
	 ((not (%thread-attached? t))
	  (error "thread-await" "unattached thread" t))
	 ((pair? arg)
	  (await*-ntimes s* (thread-scheduler t) (car arg)))
	 (else
	  (await* s* (thread-scheduler t))))))

;*---------------------------------------------------------------------*/
;*    thread-sleep! ...                                                */
;*---------------------------------------------------------------------*/
(define (thread-sleep! timeout)
   (let ((t (current-thread)))
      (if (thread? t)
	  (if (>fx timeout 0)
	      (%thread-timeout! t timeout))
	  (error 'thread-sleep! "No current thread" t))))

;*---------------------------------------------------------------------*/
;*    thread-yield! ...                                                */
;*---------------------------------------------------------------------*/
(define (thread-yield!)
   (let ((t (current-thread)))
      (if (thread? t)
	  (%thread-yield! t)
	  (error 'thread-yield! "No current thread" t))))

;*---------------------------------------------------------------------*/
;*    thread-get-values! ...                                           */
;*---------------------------------------------------------------------*/
(define (thread-get-values! s)
   (let ((t (current-thread)))
      (if (thread? t)
	  (begin
	     (thread-yield!)
	     (signal-last-values s (scheduler-env+ (thread-scheduler t)))))))

;*---------------------------------------------------------------------*/
;*    thread-get-values*! ...                                          */
;*---------------------------------------------------------------------*/
(define (thread-get-values*! s*)
   (let ((t (current-thread)))
      (if (thread? t)
	  (begin
	     (thread-yield!)
	     (map (lambda (s)
		     (cons s (signal-last-values
			      s (scheduler-env+ (thread-scheduler t)))))
		  s*)))))

;*---------------------------------------------------------------------*/
;*    thread-await-values! ...                                         */
;*---------------------------------------------------------------------*/
(define (thread-await-values! s . tmt)
   (apply thread-await! s tmt)
   (thread-get-values! s))
   
;*---------------------------------------------------------------------*/
;*    thread-await-values*! ...                                        */
;*---------------------------------------------------------------------*/
(define (thread-await-values*! s* . tmt)
   (apply thread-await*! s* tmt)
   (thread-get-values*! s*))
   
;*---------------------------------------------------------------------*/
;*    object-display ::thread ...                                      */
;*---------------------------------------------------------------------*/
(define-method (object-display o::thread . port)
   (with-output-to-port (if (pair? port) (car port) (current-output-port))
      (lambda ()
	 (with-access::thread o (name)
	    (display* "#<thread:" name ">")))))

;*---------------------------------------------------------------------*/
;*    object-write ::thread ...                                        */
;*---------------------------------------------------------------------*/
(define-method (object-write o::thread . port)
   (with-output-to-port (if (pair? port) (car port) (current-output-port))
      (lambda ()
	 (with-access::thread o (name %state %timeout %signals)
	    (display* "#<thread:" name
		      " state=" %state
		      " timeout=" %timeout
		      " signals=" %signals
		      ">")))))

;*---------------------------------------------------------------------*/
;*    object-print ::thread ...                                        */
;*---------------------------------------------------------------------*/
(define-method (object-print o::thread port print-slot)
   (object-write o port))

;*---------------------------------------------------------------------*/
;*    current-thread ...                                               */
;*---------------------------------------------------------------------*/
(define (current-thread)
   (if (not (scheduler? (current-scheduler)))
       #f
       (%scheduler-current-thread (current-scheduler))))

;*---------------------------------------------------------------------*/
;*    thread-start! ...                                                */
;*---------------------------------------------------------------------*/
(define (thread-start! t . o)
   ;; check that the thread is not already attached to a scheduler
   ;; (i.e. the thread is not already running in another scheduler)
   (if (%thread-attached? t)
       (error "thread-start!" "thread already running" t)
       (let ((scdl (%get-optional-scheduler 'thread-start! o)))
	  ;; attach the thread to the scheduler
	  (with-access::thread t (scheduler %state)
	     (set! scheduler scdl)
	     (set! %state 'started)
	     ;; start the builtin thread
	     ($bglthread-start (thread-%builtin t)))
	  ;; adding a thread only appends it to the list of thread
	  ;; to be started at the next scheduler instant
	  (with-access::%scheduler scdl (tostart %live-thread-number)
	     ;; increment the number of live threads
	     (set! %live-thread-number (+fx 1 %live-thread-number))
	     ;; thread are append in the inverse order
	     (set! tostart (cons t tostart)))
	  ;; return the started thread
	  t)))
   
;*---------------------------------------------------------------------*/
;*    thread-terminate! ...                                            */
;*---------------------------------------------------------------------*/
(define (thread-terminate! t)
   (with-access::thread t (scheduler %exc-result)
      (with-debug 3 '%thread-terminate!
	 (debug-item "t=" (debug-string t))
	 (debug-item "attached?=" (%thread-attached? t))
	 (debug-item "dead?=" (%thread-is-dead t))
	 (debug-item "toterminate?=" (%thread-is-toterminate t))
	 (debug-item "terminated?=" (%thread-is-terminated t)))
      (cond
	 ((not (%thread-attached? t))
	  ;; it is an error to terminate an unattached thread
	  (error 'thread-terminate! "Unattached thread" t))
	 ((%thread-is-dead t)
	  ;; nothing to do, it is already dead!
	  #unspecified)
	 ((%thread-is-toterminate t)
	  ;; the thread has already been terminated in the instant, we skip
	  #unspecified)
	 (else
	  ;; mark that the thread is terminated (which is not dead)
	  (%thread-is-toterminate t #t)
	  ;; mark the termination result
	  (set! %exc-result *terminated-thread-exception*)
	  ;; adding a thread simply append it to the list of thread
	  ;; to be stoped at the next scheduler instant
	  (with-access::%scheduler scheduler (toterminate)
	     ;; thread are append in the inverse order.
	     (set! toterminate (cons t toterminate)))))))

;*---------------------------------------------------------------------*/
;*    thread-suspend/resume! ...                                       */
;*---------------------------------------------------------------------*/
(define (thread-suspend/resume! t who val)
   (cond
      ((not (%thread-attached? t))
       ;; it is an error to terminate an unattached thread
       (error who "Unattached thread" t))
      ((or (%thread-is-toterminate t)
	   (%thread-is-terminated t)
	   (%thread-is-dead t))
       ;; the thread is dead or terminated, nothing to do
       #unspecified)
      (else
       (let ((scdl (thread-scheduler t)))
	  ;; adding a thread simply append it to the list of thread
	  ;; to be stoped at the next scheduler instant
	  (with-access::%scheduler scdl (tosuspend/resume)
	     (set! tosuspend/resume (cons (cons t val) tosuspend/resume)))))))

;*---------------------------------------------------------------------*/
;*    thread-suspend! ...                                              */
;*---------------------------------------------------------------------*/
(define (thread-suspend! t)
   (thread-suspend/resume! t 'thread-suspend! #t))

;*---------------------------------------------------------------------*/
;*    thread-resume! ...                                               */
;*---------------------------------------------------------------------*/
(define (thread-resume! t)
   (thread-suspend/resume! t 'thread-resume! #f))
