;*=====================================================================*/
;*    serrano/prgm/project/bigloo/fthread/src/Llib/_scheduler.scm      */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Thu May 29 07:51:57 2003                          */
;*    Last change :  Sat Aug 16 15:24:46 2003 (serrano)                */
;*    Copyright   :  2003 Manuel Serrano                               */
;*    -------------------------------------------------------------    */
;*    The private scheduler implementation.                            */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __ft_%scheduler
   
   (include "debug.sch"
	    "_scheduler.sch")
   
   (import  __ft_types
	    __ft_%types
	    __ft_scheduler
	    __ft_%thread
	    __ft_env
	    __ft_%env
	    __ft_signal)
   
   (export  (%get-optional-scheduler::scheduler ::symbol ::pair-nil)
	    (%schedule-instant ::%scheduler)
	    (%broadcast! scdl::%scheduler ::obj ::obj)
	    (%scheduler-next-thread ::thread ::scheduler)
	    (%scheduler-switch-to-next-thread ::thread ::scheduler)
	    (%scheduler-time ::scheduler)
	    (%scheduler-add-async-runnable! ::%scheduler ::thread)
	    (%scheduler-add-async! ::%scheduler ::%sigasync)
	    (%scheduler-spawn-async ::%scheduler ::%sigasync)
	    (%scheduler-add-broadcast! ::%scheduler ::obj ::obj)
	    (%scheduler-waiting-threads::pair-nil ::%scheduler)))

;*---------------------------------------------------------------------*/
;*    %get-optional-scheduler ...                                      */
;*---------------------------------------------------------------------*/
(define (%get-optional-scheduler who o)
   (cond
      ((null? o)
       (let ((s (default-scheduler)))
	  (if (scheduler? s)
	      s
	      (default-scheduler (make-scheduler)))))
      ((scheduler? (car o))
       (car o))
      (else
       (error who "Illegal scheduler" (car o)))))

;*---------------------------------------------------------------------*/
;*    %scheduler-get-async-runnable ...                                */
;*    -------------------------------------------------------------    */
;*    Aquires the async lock and then returns the contents of async    */
;*    runnable. If the optional argument is provided, its value        */
;*    replaces the former value of the list.                           */
;*---------------------------------------------------------------------*/
(define (%scheduler-get-async-runnable scdl::%scheduler . nv)
   (synchronize scdl
      ;;; the synchronized body		
      (let ((v (%scheduler-async-runnable scdl)))
	 (if (pair? nv)
	     (%scheduler-async-runnable-set! scdl (car nv)))
	 v)))

;*---------------------------------------------------------------------*/
;*    %scheduler-add-async-runnable! ...                               */
;*    -------------------------------------------------------------    */
;*    Aquires the async lock and then adds a thread to the async       */
;*    runnable list                                                    */
;*---------------------------------------------------------------------*/
(define (%scheduler-add-async-runnable! scdl::%scheduler t::thread)
   (with-debug 2 '%scheduler-add-async-runnable
      (debug-item "t=" t)
      (synchronize scdl
          ;;; the synchronized body
	  (with-access::%scheduler scdl (%builtin async-runnable)
	     (set! async-runnable (cons t async-runnable))
	     ($bglasync-scheduler-notify %builtin)
	     #unspecified))))

;*---------------------------------------------------------------------*/
;*    %scheduler-add-async! ...                                        */
;*---------------------------------------------------------------------*/
(define (%scheduler-add-async! scdl::%scheduler sig::%sigasync)
   (with-access::%scheduler scdl (tospawn)
      (set! tospawn (cons sig tospawn))))

;*---------------------------------------------------------------------*/
;*    %scheduler-next-thread ...                                       */
;*---------------------------------------------------------------------*/
(define (%scheduler-next-thread t::thread scdl::scheduler)
   (with-access::%scheduler scdl (threads-runnable threads-yield current-thread)
      (with-debug 2 '%scheduler-next-thread
	 (%scheduler-next-thread-debug t scdl)
	 (let loop ((runnable threads-runnable))
	    (if (pair? runnable)
		;; there is another thread to execute...
		(let ((nt (car runnable)))
		   (cond
		      ((thread-%is-suspend nt)
		       ;; it is suspended
		       (set! threads-yield (cons nt threads-yield))
		       (loop (cdr runnable)))
		      ((%thread-is-dead nt)
		       (loop (cdr runnable)))
		      (else
		       (set! threads-runnable (cdr runnable))
		       (%scheduler-current-thread-set! scdl nt)
		       nt)))
		(let ((async (%scheduler-get-async-runnable scdl '())))
		   (if (pair? async)
		       (let ((nt (car async)))
			  (set! threads-runnable (cdr async))
			  (%scheduler-current-thread-set! scdl nt)
			  nt)
		       ;; there is no more threads, this is the end of the 
		       ;; (the micro instant), we switch back to the scheduler
		       scdl)))))))

;*---------------------------------------------------------------------*/
;*    %scheduler-next-thread-debug ...                                 */
;*---------------------------------------------------------------------*/
(define (%scheduler-next-thread-debug t scdl)
   (with-output-to-port (current-error-port)
      (lambda ()
	 (with-access::%scheduler scdl (threads-runnable
					threads-yield
					threads-timeout
					%live-thread-number)
	    (debug-item "%live-thread-number=" %live-thread-number)
	    (debug-item "runnable=" (debug-string threads-runnable))
	    (debug-item "yield=" (debug-string threads-yield))
	    (debug-item "timeout=" (debug-string threads-timeout))
	    (debug-item "async-runnable="
			(debug-string
			 (%scheduler-get-async-runnable scdl)))))))
   
;*---------------------------------------------------------------------*/
;*    %scheduler-switch-to-next-thread ...                             */
;*    -------------------------------------------------------------    */
;*    Switches to the next threads or ends the current instant.        */
;*---------------------------------------------------------------------*/
(define (%scheduler-switch-to-next-thread t::thread scdl::scheduler)
   (with-access::thread t (%builtin)
      (with-debug 3 '%scheduler-switch-to-next-thread
	 (let ((nt (%scheduler-next-thread t scdl)))
	    (%scheduler-switch-to-next-thread-debug t scdl nt)
	    ($bglthread-switch %builtin (thread-%builtin nt))
	    ($bglthread-wait %builtin)
	    #unspecified))))

;*---------------------------------------------------------------------*/
;*    %scheduler-switch-to-next-thread-debug ...                       */
;*---------------------------------------------------------------------*/
(define (%scheduler-switch-to-next-thread-debug t scdl nt)
   (debug-item "scdl=" scdl)
   (debug-item "t=" t)
   (debug-item "nt=" (debug-bold (debug-string nt))))

;*---------------------------------------------------------------------*/
;*    %schedule-instant ...                                            */
;*    -------------------------------------------------------------    */
;*    Executes one instant                                             */
;*---------------------------------------------------------------------*/
(define (%schedule-instant scdl::%scheduler)
   ;; debug message
   (when-debug 1 (fprint (debug-port) (make-string 70 #\=)))
   (with-debug 1 (format "%schedule-instant: ~a" (%scheduler-time scdl))
      ;; start the new environment instant
      (%env-init-instant scdl)
      ;; terminate the threads that are dying
      (%terminate-threads scdl)
      ;; suspend/resume threads
      (%suspend/resume-threads scdl)
      ;; select the runnable threads
      (%select-threads! scdl)
      ;; add all the new user threads
      (%start-new-threads scdl)
      ;; broadcast the external signals
      (%scheduler-broadcast*! scdl)
      ;; run until the end of the instant (switch to the first runnable thread)
      (%scheduler-switch-to-next-thread scdl scdl)
      ;; start asynchronous threads (only those that are not waited yet)
      (%spawn-async scdl)))

;*---------------------------------------------------------------------*/
;*    %env-init-instant ...                                            */
;*    -------------------------------------------------------------    */
;*    Prepares the environment for the new instant.                    */
;*---------------------------------------------------------------------*/
(define (%env-init-instant scdl::scheduler)
   (with-access::%scheduler scdl (env+)
      (for-each instant-env! env+)))

;*---------------------------------------------------------------------*/
;*    %sort-threads ...                                                */
;*---------------------------------------------------------------------*/
(define (%sort-threads threads)
   (sort threads
	 (lambda (t1 t2)
	    (<fx (thread-%ident t1)
		 (thread-%ident t2)))))

;*---------------------------------------------------------------------*/
;*    %select-threads! ...                                             */
;*    -------------------------------------------------------------    */
;*    Amongst the previously idle (cooperating or waiting) threads     */
;*    selects the ones that are now ready.                             */
;*---------------------------------------------------------------------*/
(define (%select-threads! scdl::%scheduler)
   (with-access::%scheduler scdl (threads-runnable
				  threads-yield
				  threads-timeout
				  %threads-ready
				  %live-thread-number)
      (let ((runnable threads-runnable)
	    (yield threads-yield)
	    (timeout threads-timeout)
	    (tostart (%scheduler-tostart scdl))
	    (live %live-thread-number))
	 [assert (runnable)
             ;;; check the runnable threads	   
	     (every? (lambda (t) (>= (thread-%timeout t) 0)) runnable)]
	 [assert (yield)
             ;;; check the yield threads	   
	     (every? (lambda (t) (>= (thread-%timeout t) 0)) yield)]
	 [assert (timeout)
             ;;; check the timeout threads	   
	     (every? (lambda (t) (>= (thread-%timeout t) 0)) timeout)])
      ;; mark that no threads have currently yield in the instant
      (set! %threads-ready #f)
      (let ((runnable threads-yield))
	 (set! threads-yield '())
	 (set! threads-timeout
	       (filter! (lambda (t)
			   (with-access::thread t (%timeout)
			      (case %timeout
				 ((0)
				  ;; the thread has been awake by a signal
				  ;; or it is dead, we skip it
				  #f)
				 ((1)
				  ;; the thread is now ready
				  (%thread-unregister-signals! t)
				  (set! runnable (cons t runnable))
				  #f)
				 (else
				  ;; the thread is still idle
				  (set! %timeout (-fx %timeout 1))
				  (set! %threads-ready #t)
				  #t)))) 
			threads-timeout))
	 (if *thread-strict-order*
	     (set! threads-runnable (%sort-threads runnable))
	     (set! threads-runnable runnable)))))

;*---------------------------------------------------------------------*/
;*    %start-new-threads ...                                           */
;*    -------------------------------------------------------------    */
;*    Starts the newly started threads.                                */
;*---------------------------------------------------------------------*/
(define (%start-new-threads s::%scheduler)
   (with-access::%scheduler s (tostart threads-runnable)
      (if (pair? tostart)
	  (begin
	     ;; append the new threads at the end of the threads list
	     (set! threads-runnable
		   (append! threads-runnable (reverse! tostart)))
	     (set! tostart '())))))

;*---------------------------------------------------------------------*/
;*    %terminate-threads ...                                           */
;*    -------------------------------------------------------------    */
;*    Stops the terminated threads.                                    */
;*---------------------------------------------------------------------*/
(define (%terminate-threads scdl::%scheduler)
   (with-access::%scheduler scdl (toterminate
				  threads-runnable
				  threads-yield
				  threads-timeout)
      (if (pair? toterminate)
	  (with-debug 2 '%terminate-threads
	     ;; we have to remove multiple occurrences of thread to be
	     ;; terminated otherwise we will have a lock because we will run
	     ;; a terminated thread
	     (let ((thds (filter! (lambda (t)
				     (and (%thread-is-toterminate t)
					  (begin
					     (%thread-is-terminated t #t)
					     #t)))
				  toterminate)))
		(debug-item "toterminate=" (debug-string toterminate))
		(debug-item "runnable=" (debug-string toterminate))
		(debug-item "yield=" (debug-string threads-yield))
		(debug-item "timeout=" (debug-string threads-timeout))
		(set! toterminate '())
		(let ((runnable (filter! (lambda (t)
					    (not (%thread-is-toterminate t)))
					 threads-runnable))
		      (yield (filter! (lambda (t)
					 (not (%thread-is-toterminate t)))
				      threads-yield))
		      (timeout (filter! (lambda (t)
					   (not (%thread-is-toterminate t)))
					threads-timeout)))
		   (set! threads-runnable thds)
		   (debug-item "terminating=" (debug-string thds))
		   (debug-item "new-runnable=" (debug-string runnable))
		   (debug-item "new-yield=" (debug-string yield))
		   (debug-item "new-timeout" (debug-string timeout))
		   ;; run the terminated thread (i.e., kill them)
		   (%scheduler-switch-to-next-thread scdl scdl)
		   ;; restore the unterminated runnable and yield threads
		   (set! threads-runnable runnable)
		   (set! threads-yield yield)
		   (set! threads-timeout timeout)))))))

;*---------------------------------------------------------------------*/
;*    %suspend/resume-threads ...                                      */
;*---------------------------------------------------------------------*/
(define (%suspend/resume-threads scdl::%scheduler)
   (with-access::%scheduler scdl (tosuspend/resume)
      (if (pair? tosuspend/resume)
	  (begin
	     (for-each (lambda (v)
			  (thread-%is-suspend-set! (car v) (cdr v)))
		       (reverse! tosuspend/resume))
	     (set! tosuspend/resume '())))))

;*---------------------------------------------------------------------*/
;*    %scheduler-spawn-async ...                                       */
;*---------------------------------------------------------------------*/
(define (%scheduler-spawn-async scdl::%scheduler sig::%sigasync)
   (with-access::%sigasync sig (spawned id thunk)
      (if (not spawned)
	  (let ((nt (lambda ()
		       (%scheduler-add-broadcast! scdl sig (thunk))
		       #unspecified)))
	     (set! spawned #t)
	     ($bglasync-spawn (%scheduler-%builtin scdl) nt id)
	     #unspecified))))
	 
;*---------------------------------------------------------------------*/
;*    %spawn-async ...                                                 */
;*    -------------------------------------------------------------    */
;*    Spawns all the unwaited asynchronous threads. Since the          */
;*    no one is waiting for the signals, we don't have to broadcast    */
;*    any signal when the computation is complete.                     */
;*---------------------------------------------------------------------*/
(define (%spawn-async scdl::%scheduler)
   (with-access::%scheduler scdl (tospawn)
      (if (pair? tospawn)
	  (begin
	     (for-each (lambda (s) (%scheduler-spawn-async scdl s)) tospawn)
	     (set! tospawn '())))))

;*---------------------------------------------------------------------*/
;*    %broadcast! ...                                                  */
;*---------------------------------------------------------------------*/
(define (%broadcast! scdl::%scheduler sig val)
   (with-access::%scheduler scdl (env+)
      (signal-emit sig val env+)))

;*---------------------------------------------------------------------*/
;*    %scheduler-broadcast*! ...                                       */
;*---------------------------------------------------------------------*/
(define (%scheduler-broadcast*! scdl::%scheduler)
   (synchronize scdl
      ;;; the synchronized body
      (with-access::%scheduler scdl (tobroadcast)
	 (if (pair? tobroadcast)
	     (begin
		(for-each (lambda (sig)
			     (%broadcast! scdl (car sig) (cdr sig)))
			  tobroadcast)
		(set! tobroadcast '()))))))

;*---------------------------------------------------------------------*/
;*    %scheduler-add-broadcast! ...                                    */
;*---------------------------------------------------------------------*/
(define (%scheduler-add-broadcast! scdl::%scheduler sig::obj val::obj)
   (synchronize scdl
      ;;; the synchronized body
      (with-access::%scheduler scdl (%builtin tobroadcast)
	 (let ((sv (cons sig val)))
	    (set! tobroadcast (cons sv tobroadcast)))
	 ($bglasync-scheduler-notify %builtin)
	 #unspecified)))

;*---------------------------------------------------------------------*/
;*    %scheduler-time ...                                              */
;*---------------------------------------------------------------------*/
(define (%scheduler-time scdl::scheduler)
   (with-access::scheduler scdl (env+)
      (ftenv-instant (car env+))))

;*---------------------------------------------------------------------*/
;*    %scheduler-waiting-threads ...                                   */
;*---------------------------------------------------------------------*/
(define (%scheduler-waiting-threads scdl)
   (with-access::scheduler scdl (env+)
      (let loop ((envs env+)
		 (ths '()))
	 (if (pair? envs)
	     (loop (cdr envs) (append (ftenv-threads (car env+)) ths))
	     ths))))
   

