;;; -*- Mode: Scheme -*-    Toplevel scheduler loop for Yenta.

;;; Substantially modified ca. 6/29/97 by DJB.

(require 'format)
(require 'sort)
(require 'common-list-functions)
(yreq "Utilities/yenta-utils")
(yreq "Scheduler/bombproofing")
(yreq "Logging/counter-tools")
(yreq "Logging/counters")

;;; A task is a procedure of no arguments which will be run at some point in
;;; the future.  It has a name which must be unique, or must be a list (the latter
;;; case should only be used for children of tasks).  It also has a priority
;;; which controls which task will be run next.  Due to the scheduler's syntactic
;;; constructions, a task may start partway through the procedure at declared
;;; points; this facility should be used whenever a process performs an
;;; operation that may take a while, since the scheduler is non-preemptive.

;;; Adds a task to the scheduler's tasklist.  This task will be rescheduled
;;; automatically upon completion.
(define (scheduler:add-task! name priority wait-fn proc) #f)

;;; Adds a task to the scheduler.  This task is removed from the tasklist when
;;; it completes.
(define (scheduler:add-once-task! name priority wait-fn proc) #f)

;;; Adds a task that runs after a certain interval.  The task happens only
;;; once, after ~timeout seconds.
(define (scheduler:add-timeout-task! name priority timeout proc) #f)

;;; Adds a task that runs every ~timeout seconds.  Reschedules itself for the
;;; next interval.
(define (scheduler:add-periodic-task! name priority interval proc) #f)

;;; Adds a task that runs at a certain time (given in POSIX time, as from
;;; (current-time)).
(define (scheduler:add-at-task! name priority time proc) #f)

;;; Starts the scheduler; runs until no task is ready to run and the "scheduler"
;;; task has been removed.
(define (scheduler:initialize!) #f)

;;; Displays the current tasklist.  First optional argument is whether to show
;;; the actual closure; second is port to which to send the output.
(define (scheduler:show-tasklist . flags) #f)

;;; Returns #t iff the named task will run.
(define (scheduler:task-ready? name) #f)

;;; Returns the task with the given name (a true value) if there is such a task.
(define (scheduler:task-exists? name) #f)

;;; Changes the priority of the given task.
(define (scheduler:change-task-priority! name priority) #f)

;;; Returns the time when the named task last finished running.
(define (scheduler:task-last-finished? name) #f)

;;; Returns the total duration the named task has been running.
(define (scheduler:task-total-time? name) #f)

;;; Removes all tasks with the given name.
;;; (scheduler:remove-task! "scheduler") will stop the scheduler at the next
;;; time-slice when no task is ready to run.
(define (scheduler:remove-task! name) #f)

;;; Given a task (from (scheduler:current-task)), removes it.  The task will
;;; not be scheduled again.  Will not stop the current time-slice of a task that
;;; removes itself.  Usually used on a task that called (scheduler:current-task)
;;; and put the returned task somewhere accessible.
(define (scheduler:kill-task! task) #f)

;;; Returns the task that called it.
(define (scheduler:current-task) #f)

;;; Given a task (from (scheduler:current-task)), returns the name
(define (scheduler:task-name task) #f)

;;; Returns the priority of the task that called it.
(define (scheduler:current-priority) #f)

;;; Returns the name of the task that called it.
(define (scheduler:current-name) #f)

;;; Changes the name of the currently running task
;;; Returns #t if the new name didn't exist before, is a list, or is the
;;; current name.  Return #f and has no effect otherwise.
(define (scheduler:rename-current) #f)

;;; A common wait-fn: the task runs whenever scheduled.
(define (scheduler:always) #t)

; (define (scheduler:yield . wait-fn) #f)
;  Returns control to the scheduler.  The task will continue from here when it
;  is next scheduled; if wait-fn is provided, it will be used as the wait-fn
;  for the next time-slice

;;;; Syntactic constructions:

;;; (scheduler:when condition body1 body2 ...)
;;; When condition becomes true, and this task is scheduled again, executes the
;;; body statements; the condition and body are evaluated in the current
;;; environment. (scheduler:when #t body1 body2 ...) is a good way to yield
;;; while not in any loops.  DO NOT put expressions after the scheduler:when in
;;; your procedure.

;;; (scheduler:loop condition body after1 after2 ...)
;;; Yields, then executes body as each of this task's time slices until
;;; condition is false at the start of the loop; then it executes the "after"
;;; expressions.  This is a good way to perform long computations that require
;;; loops, since it yields after each iteration.  NOTE: if the body does not
;;; include a scheduler:when, this task will prevent lower priority tasks from
;;; getting any time-slices.  DO NOT put expressions after the scheduler:loop in
;;; your procedure.  BUGS: nested loops do not work (yet)!

;;; (scheduler:split body)
;;; Sets the body to execute as a child task after this task finishes running;
;;; the current task continues executing (this call does not cause the current
;;; task to yield).  When the body completes, the child process is removed.

;;; (scheduler:both body1 body2)
;;; Runs both body expressions; the former in a child task, the latter in the
;;; parent.  Yields before running anything.

;;; (scheduler:let* bindings body1 body2 ...)
;;; Each binding must be of the form (variable (function arg ...)); the
;;; functions are called with the given arguments, plus one more, which is a
;;; procedure that should be called with the result of the computation.  The
;;; function may yield with the other scheduler syntactic constructions; the
;;; body of the scheduler:let* is packaged such that the function is still the
;;; last thing in the task procedure for the purposes of proper function of the
;;; syntactic constructions.

;;;; The actual implementation follows...
;;;; ********** ABSTRACTION BARRIER **********

(define (scheduler:soon wait-fn proc) #f) ; SET LATER!

(defmacro scheduler:when (condition . body)
  `(scheduler:soon (lambda () ,condition)
     (lambda () . ,body)))

(defmacro scheduler:loop (condition body . after)
  `(scheduler:soon scheduler:always
		   (if ,condition
		       (lambda ()
			 (scheduler:soon scheduler:always
					 (lambda ()
					   (scheduler:loop ,condition
							   ,body . ,after)))
			 ,body)
		       (lambda () . ,after))))

(defmacro scheduler:until (condition body . after)
  `(scheduler:soon scheduler:always
     (if ,condition
	 (lambda () . ,after)
	 (lambda ()
	   (scheduler:soon scheduler:always
	     (lambda ()
	       (scheduler:loop ,condition
		 ,body . ,after)))
	   ,body))))

(defmacro scheduler:simple-do (finish . body)
  `(scheduler:soon scheduler:always
     (if ,(car finish)
	 (lambda () . ,(cdr finish))
	 (lambda ()
	   (scheduler:soon scheduler:always
	     (lambda ()
	       (scheduler:simple-do ,finish 
		 . ,body)))
	   . ,body))))

(defmacro scheduler:do (bindings finish . body)
  `(let ,(map (lambda (binding) (list (car binding) (cadr binding)))
	      bindings)
     (scheduler:simple-do ,finish
       . ,(cons `(scheduler:soon scheduler:always
		   (lambda ()
		     . ,(map (lambda (binding) 
			       `(set! ,(car binding)
				      ,(caddr binding)))
			     bindings)))
		body))))

(defmacro scheduler:set! (var value-exp . rest)
  (append value-exp `((lambda (scheduler:tmp)
			(set! ,var scheduler:tmp)
			. ,rest))))

(defmacro scheduler:do-with (bindings finish . body)
  `(scheduler:let* ,(map (lambda (binding) (list (car binding) (cadr binding)))
			 bindings)
     (scheduler:simple-do ,finish
       . ,(append (map (lambda (binding)
			 `(scheduler:soon scheduler:always
			    (lambda ()
			      ,(append (caddr binding) 
				       `((lambda (scheduler:tmp)
					   (set! ,(car binding) scheduler:tmp)))))))
		       (reverse bindings)) body))))

(defmacro scheduler:sequences seqs
  `(begin
     . ,(map (lambda (seq)
	       `(scheduler:soon scheduler:always
		  (lambda ()
		    . ,seq)))
	     (reverse seqs))))

(define (scheduler:dont-use arg) 'unused)

(defmacro scheduler:call (exp)
  (append exp '((lambda (arg) 'unused))))

(defmacro scheduler:split body
  `(scheduler:add-once-task! (list (scheduler:current-name) "child")
			     (scheduler:current-priority)
                             scheduler:always
			     (lambda () . ,body)))

(defmacro scheduler:both (body1 body2)
  `(begin
     (scheduler:split . ,body1)
     (scheduler:when #t . ,body2)))

(defmacro scheduler:let* (bindings . body)
  (if (null? bindings)
      `(begin . ,body)
      (append (cadar bindings)
	      (list `(lambda (,(caar bindings))
		       (scheduler:let* ,(cdr bindings) . ,body))))))

;;;; External stuff we need for interacting with scheduler errors.

;;; Actually quits Yenta.  You can't just type (quit) at the repl,
;;; because apparently that actually gets an error if run in the
;;; context of a dynamic-wind (used to catch erring tasks), whereupon
;;; the scheduler catches the error, kills the srepl child, and continues!
;;;
;;; NOTE!  This is a -very drastic- quit.  No more tasks will run once
;;; you set this.  If you're intending to shut other things down first,
;;; you should set *yenta-exit-pending* first, presumably by calling
;;; yenta-exit.
(defvar *scheduler:quit-pending* #f)
(define (scheduler:quit)
  (set! *scheduler:quit-pending* #t))

;;; Holds tasks that we have terminated due to errors.  Each entry is
;;; a tuple of internal real time, current POSIX time, task entry, and
;;; the result from the call to accumulating-errors, which might include
;;; a backtrace.  They are pushed onto the front of the existing list,
;;; so they are in the REVERSE order in which they were killed!  This
;;; makes it convenient to get at the most recent error.
;;;
;;; This actually holds the information as real lists of real values,
;;; which means it -cannot- be a yvar---there might be things that
;;; are slashified, e.g., not readable!
(defvar *scheduler:erring-taskinfo* '())

;;; This is a yvar, so we can accumulate them across restarts, if we
;;; haven't had a chance to dump them out yet.  (We can always decide
;;; later to clear it...)  Each entry is a single string, which is the
;;; entire contents of one entry in *scheduler:erring-taskinfo*.  We
;;; store strings so we can guarantee readability (e.g., no #<...>, etc)
;;; when the persistent-state file is reloaded with try-read.
;;; Note that this, like *scheduler:erring-taskinfo*, is in REVERSE order.
(def-yenta-var *scheduler:erring-tasks* '())

;;; This is -outside- the environment, so we can adjust it if we like.

(define *scheduler:null-job-usleep-interval* 100000) ; Number of microseconds to sleep if we have nothing better to do on any given iteration.

;;; +++ Going into the scheduler environment....

(let ((tasklist '())
      (current-task-entry #f))

;;; things here are local scheduler bindings, except that the set!'s
;;; export the user-level procedures.

(define (make-ritp)
  (cons 0 0))				; Hasn't run yet.
(define (ritp-real ritp)
  (car ritp))
(define (ritp-run ritp)
  (cdr ritp))

;;; ++
;;; These will wrap in about 248 days or so, assuming our patched
;;; SCM 5c3 (or normal SCM 5c4), and -signed- values, or twice that
;;; if the relevant C functions are fixed to use unsigned values.
;;; Either way, I'm not gonna worry about it.
(define (set-ritp! ritp)
  (set-car! ritp (get-internal-real-time))
  (set-cdr! ritp (get-internal-run-time)))
(define (add-ritp! total-ritp starting-ritp)
  (set-car! total-ritp (+ (car total-ritp) (- (get-internal-real-time) 
                                              (car starting-ritp))))
  (set-cdr! total-ritp (+ (cdr total-ritp) (- (get-internal-run-time)
                                              (cdr starting-ritp)))))
;;; --

(define (priority-good? priority)
  (or (and (integer? priority)
	   (not (negative? priority)))
      (format-error "~S isn't a nonnegative number." priority)))

(define wait-fn? procedure?)

(define (wait-fn-good? wait-fn)
  (or (wait-fn? wait-fn)
      (format-error "~S isn't a procedure, so it can't be a wait-function."
                    wait-fn)))

(define (task-good? task)
  (or (procedure? task)
      (format-error "~S isn't a procedure, so it can't be a task." task)))

(define (name-good? name)
  (or (string? name)
      (and (pair? name)
	   (name-good? (car name))
	   (name-good? (cdr name)))
      (null? name)
      (format-error "~S isn't a string or a list of valid names, so it can't be a task name." name)))

(define (make-entry name priority wait-fn task next-time)
  (and (priority-good? priority)
       (wait-fn-good? wait-fn)
       (name-good? name)
       (task-good? task)
       (or (not next-time)
           (and (task-good? (car next-time))
	        (wait-fn-good? (cdr next-time)))))
  (vector wait-fn task
	  (make-ritp)		; Last run time (a particular instant).
	  (make-ritp)		; Total run time (duration).
	  name priority next-time '() '()))

(define (task-wait-fn entry)
  (vector-ref entry 0))
(define (set-wait-fn! entry new-val)
  (set-car! entry new-val))
(define (task-task entry)
  (vector-ref entry 1))
(define (set-task! entry new-task)
  (vector-set! entry 1 new-task))
(define (task-last-run entry)
  (vector-ref entry 2))
(define (task-total-time entry)
  (vector-ref entry 3))
(define (task-name entry)
  (vector-ref entry 4))
(define (task-priority entry)
  (vector-ref entry 5))
(define (task-next-time entry)
  (vector-ref entry 6))

(define (soon wait-fn task)
  (vector-set! current-task-entry 7 
	       (cons wait-fn (vector-ref current-task-entry 7)))
  (vector-set! current-task-entry 8 
	       (cons task (vector-ref current-task-entry 8))))

(define (make-level-entry priority initial-contents) ; No error checking.
  (cons priority initial-contents))
(define (level-priority level)
  (car level))
(define (level-tasks level)
  (cdr level))

(defmacro scheduler:push! (list item) `(set! ,list (cons ,item ,list)))

(define (add-level! priority list-of-task-entries)	; Doesn't check to see if it's already there.
  (let ((new-level (make-level-entry priority list-of-task-entries)))
     (scheduler:push! tasklist new-level)
     (set! tasklist
	   (sort! tasklist
	          (lambda (level1 level2)
		    (> (level-priority level1)
		       (level-priority level2)))))))

(define (has-level? n)
  (some (lambda (level)
	  (= n (level-priority level)))
	tasklist))

(define (find-level n)
  (assv n tasklist))
(define (max-level n)	; I dunno if this is useful or not.
  (level-priority (first tasklist)))

(define (names-equal? one two)
  (or (and (string? one)
	   (string? two)
	   (string-ci=? one two))
      (and (pair? one)
	   (pair? two)
	   (names-equal? (car one) (car two))
	   (names-equal? (cdr one) (cdr two)))
      (and (null? one)
	   (null? two))))

;;; [This wants to be a defvar, but it can't be, 'cause we're inside a giant LET and we'd get "ERROR: Bad placement define".  Feh.]
(define entry-for-wait-fn #f)		; Set to the current task entry while we're running its wait-fn, for use in the toplevel error catch.

(define (entry-runnable? entry)
  (set! entry-for-wait-fn entry)
  (let ((runnable? ((task-wait-fn entry))))
    (set! entry-for-wait-fn #f)	; If the wait-fn took an error, this will be left set to the task entry, for use by the error catch.
    (cond ((eq? runnable? *unspecified*) ; Make sure we've at least got something well-considered...
	   (format-error "The wait-function for scheduler task ~S returned ~S.  It should return #f or something else, but not ~:*~S!"
			 entry *unspecified*))
	  (else
	   runnable?))))

;;; [This wants to be a defvar, but it can't be, 'cause we're inside a giant LET and we'd get "ERROR: Bad placement define".  Feh.]
(define entry-for-running-task #f)	; Set to the current task entry while we're running the task, for use in the toplevel error catch.

(define (yenta-shutdown)
  (format-debug 50 "Yenta shutdown...~&")
  (boot:close-udp)
  (format-debug 50 "done.~&"))

(define (run-entry entry)		; Assumes wait-fn already returned true.
  (define current-task-starting-time (make-ritp)) ; %%% WTF?  We're consing this every time we run someone?
  (set! current-task-entry entry)	; Lots of things need to know the current task being run.
  (set-ritp! current-task-starting-time); Record when we started this task.
  (set! entry-for-running-task entry)
  ((task-task entry))			; Actually run the task.
  (set! entry-for-running-task #f)	; If the task took an error, this will be left set to the task entry, for use by the error catch.
  (when *scheduler:quit-pending*	; If it's a quit, just exit.  We're still inside the prot:accumulating-errors in initialize!, ...
    (quit))				; ... so this (quit) will really just generate an error.  Once outside a-e, init will check the flag & quit.
  (let ((next-wait-fns (vector-ref entry 7))
        (next-tasks (vector-ref entry 8)))
    (cond ((pair? next-wait-fns)
	   (vector-set! entry 0 (car next-wait-fns))
	   (vector-set! entry 1 (car next-tasks))
	   (vector-set! entry 7 (cdr next-wait-fns))
	   (vector-set! entry 8 (cdr next-tasks)))
	  (t
	   (if (task-next-time entry)
	       (begin
		 (vector-set! entry 0 (cdr (task-next-time entry)))
		 (vector-set! entry 1 (car (task-next-time entry))))
	       (kill-task! entry)))))
  (add-ritp! (task-total-time entry) current-task-starting-time) ; Update the total real- and runtime of this task.
  (set-ritp! (task-last-run entry))	; Update the real- and runtime of when this task last finished running.
  )

(define (poll-level level-tasks) ; Returns nil if it didn't run anything at this level.
  (if (null? level-tasks)
      nil				; Ran off the end without running anyone.
      (let* ((entry (car level-tasks))
	     (rest (cdr level-tasks))
	     (runnable? (entry-runnable? entry)))
	(cond (runnable?
	       ;; This call to run-entry should be after the
	       ;; rotation, because, if run task calls yield, control
	       ;; is going to escape straight to scheduler top level
	       (unless (null? rest)	; If we are not the last entry in the level....
		 (set-car! level-tasks (car rest)) ; ... rotate.
		 (set-cdr! level-tasks (append! (cdr rest) (list entry))))
	       (run-entry entry)
	       #t)			; We ran somebody.
	      (else
	       (poll-level (cdr level-tasks)))))))

;;; This is the main loop of the scheduler.
;;;
;;; It requires that at least one task that will queue up other tasks be put on the tasklist
;;; (including also the null job), since, once this gets control, it's not going to give it up, ever.
;;;
;;; Now stops if it does nothing (null job included) during a time-slice.  Thus
;;; removing the null job will cause the scheduler to quit.

(define (poll-all-levels levels) 
  (if (null? levels)
      (format t "[Scheduler stopped.]~&") ; %%% maybe logger:log-and-display, for robustness?  what if no tty?
      (let* ((level (car levels))
	     (ran-someone? (poll-level (level-tasks level))))
	(if ran-someone?
	    (poll-all-levels tasklist) ; We ran someone, so start over at the top.
	    (poll-all-levels (cdr levels)))))) ; We didn't run anyone at this level, so try the next one.

(define (null-job-task)
  (usleep *scheduler:null-job-usleep-interval*))
(define (null-job-wait-fn)
  #t)
(define (create-null-job)
  (maybe-add-task!
   "Null job"
   0					; Lowest possible priority.
   null-job-wait-fn
   null-job-task))

;;; The very toplevel of the scheduler system.  Assumes that you've already preloaded some tasks via scheduler:add-task!.
(define (initialize!)
  (create-null-job)			; Add in the null job so we don't just burn cycles.
  ;; Run everything inside the scheduler in an error catch.  This will catch all errors,
  ;; including those in task wait functions and the scheduler itself.  If the scheduler
  ;; itself gets an error, we'll wind up killing it---too bad.  Note that we -cannot-
  ;; put this catch in run-entry, since calling dynamic-wind and/or call-with-output-string
  ;; (not sure which/both) at 10Hz causes mtrigger (the sbrk, I think) to increment at
  ;; many hundreds of K per second until it wraps and memory allocation falls apart
  ;; (about 14 hours of uptime).  And it's inefficient, anyway, because it would
  ;; poke at the filesystem (via cwos) at 10Hz, and cons a bunch besides.
  (let ((stuff (prot:accumulating-errors
		(lambda ()
		  (poll-all-levels tasklist)))) ; Start up the scheduler.
	(scheduler-restart-okay #t))	; Okay to restart iff the error was not in the scheduler itself.
    ;; If prot:accumulating-errors returned, we took an error.  See if it's really a quit.
    (when *scheduler:quit-pending*	; If it's a quit, just exit.
      (yenta-shutdown)
      (quit))				; Note that this is -outside- any protection, so we really will quit and not just take the error.
    ;; It's not a quit, so we must really have taken an error somewhere.
    ;; Log the event, save the entry so some supervisory task can perhaps decide
    ;; to restart it, and kill the task so we don't get stuck in an infinite loop.
    ;; This includes the scheduler task itself, so if the scheduler errs, Yenta will stop.
    (inc! *ctr:scheduler-caught-errors*)
    (let* ((offender			; Figure out whether it was the task, the wait-fn, or the scheduler itself.
	    (cond (entry-for-running-task
		   (list 'task (task-name entry-for-running-task) entry-for-running-task))
		  (entry-for-wait-fn
		   (list 'wait-fn (task-name entry-for-wait-fn) entry-for-wait-fn))
		  (t
		   (set! scheduler-restart-okay #f) ; The scheduler itself took the error---eit!
		   (list 'scheduler "Scheduler" #f))))
	   (the-task (caddr offender)))	; This will be #f if it was the scheduler itself that died.
      (let ((elt (list (get-internal-real-time) (current-time) offender stuff errobj)))
	(push! elt *scheduler:erring-taskinfo*) ; This one is for internal manipulation.
	(push! (format nil "~S" elt) *scheduler:erring-tasks*))	; This one gets dumped.
      (when *wb:developer-world*
	(if the-task
	    (format (current-error-port) "~&[Just killed task ~S due to an error ~:[in its wait function~;in the task body~].  ~
                                            See *scheduler:erring-taskinfo* for details.]~&"
		    (task-name the-task)
		    (eq? (car offender) 'task))
	    (format (current-error-port) "~&Just killed the scheduler itself due to an error.  ~
                                            See *scheduler:erring-taskinfo* for details.]~&")))
      (when the-task			; If there's a task to kill, then kill it.
	(kill-task! the-task)))
    (when scheduler-restart-okay
      (initialize!))))			; Tail-call ourselves again if it's safe to continue.

;;;; External functions.

(define (task-exists? name)
  (walk-tasklist
   (lambda (entry)
     (if (names-equal? (task-name entry) name)
	 entry
	 #f))))

(define (add-task! name priority wait-fn task)
  (let ((exists? (task-exists? name)))
    (if (and exists? (not (list? name)))
	(format-error "Task ~S already exists:  ~S" name exists?)
	(let ((list-of-task-entries (list (make-entry name priority wait-fn
	                                   task (cons task wait-fn)))))
	  (cond ((has-level? priority)
		 (append! (level-tasks (find-level priority))
			  list-of-task-entries))
		(t
		 (add-level! priority list-of-task-entries))))))
  *unspecified*)

(define (add-once-task! name priority wait-fn task)
  (let ((exists? (task-exists? name)))
    (if (and exists? (not (list? name)))
	(format-error "Task ~S already exists:  ~S" name exists?)
	(let ((list-of-task-entries (list (make-entry name priority wait-fn
	                                   task #f))))
	  (cond ((has-level? priority)
		 (append! (level-tasks (find-level priority))
			  list-of-task-entries))
		(t
		 (add-level! priority list-of-task-entries))))))
  *unspecified*)

(define (add-timeout-task! name priority timeout task)
  (let ((.start. (current-time))) ; %%% This should be a gensym or something.
    (add-once-task! name priority
                    (lambda ()
	              (> (- (current-time) .start.) timeout))
		    task)))

(define (add-periodic-task! name priority timeout task)
  (let ((.start. (current-time))) ; %%% This should be a gensym or something.
    (add-task! name priority
               (lambda ()
	         (> (- (current-time) .start.) timeout))
	       (lambda ()
		 (task)
		 (set! .start. (current-time))))))

(define (add-at-task! name priority time task)
  (add-task! name priority
	     (lambda ()
	       (> (current-time) time))
	     task))

(define (maybe-add-task! name priority wait-fn task)
  (or (task-exists? name)
      (add-task! name priority wait-fn task)))

(define (kill-task! entry)
  (let* ((priority
	  (task-priority entry))
	 (level
	  (find-level priority))
	 (new-tasks  ; Record separately so we don't have to (possibly) call scheduler:level-tasks on empty level, which would explode.
	  (delete-if (lambda (item)	; Destructive!  [Can't just use delete 'cause EQUAL won't compare names with string-ci=?.]
		       (eqv? entry item))
		     (level-tasks level))))
    (if (null? new-tasks)		; Don't leave empty levels lying around.
	(set! tasklist (delete level tasklist))
	(set-cdr! level new-tasks)))) ; If there was only one thing on the level, and we're deleting it, ensure the change sticks.

(define (remove-task! name)
  (let ((entry (task-exists? name)))
    (when entry
      (kill-task! entry))))

(define (change-task-priority! name new-priority)
  (let ((entry (task-exists? name)))
    (if entry
	(let ((new-entry (make-entry 
			  name new-priority 
			  (wait-fn entry)
			  (task entry))))
	  (remove-task! name)
	  (add-task! new-entry))
	(format-error "Can't find task ~S to change its priority." name))))

(define (task-ready? name)		; Remember, this is a user-level procedure, not an internal procedure, since it takes a name.
  (let ((entry (task-exists? name)))
    (if entry
	(entry-runnable? entry)
	(format-error "Can't find a task named ~S to tell if it's runnable." name))))

(define (task-last-finished? name)
  (let ((entry (task-exists? name)))
    (if entry
	(let ((ritp (last-run entry)))
	  (if (eq? (ritp-real 0))
	      nil			; Task has never been run.
	      ritp))
	(format-error "Can't find a task named ~S to check when it last finished running." name))))

(define (task-total-time? name)
  (let ((entry (task-exists? name)))
    (if entry
	(total-time entry)
	(format-error "Can't find a task named ~S to check when its total times." name))))

(define (walk-tasklist fn)		; Applies fn to each entry in the tasklist, in priority order.
  (define (per-levels levels)
    (if (null? levels)
	nil				; Done with all levels.  Return nil instead of #<unspecified.>
	(let ((level (car levels)))
	  (or (per-level (level-tasks level))
	      (per-levels (cdr levels))))))
  (define (per-level level)
    (if (null? level)
	nil				; Done with this level.  Return nil instead of #<unspecified.>
	(let* ((entry (car level))
	       (done (fn entry)))
	  (if done
	      done			; Return whatever FN had to say about this entry.
	      (per-level (cdr level))))))
  (per-levels tasklist))

(define (count-tasks)
  (let ((count 0))
    (walk-tasklist
     (lambda (entry)
       (inc! count)
       #f))
    count))

(define (show-tasklist . flags)		; verbose & port
  (let ((verbose? (if (pair? flags) (car flags) nil))
	(port     (if (and (pair? flags) (pair? (cdr flags))) (cadr flags) t)))
    (define (show-entry entry)
      (format port "~&~D~10T~D~20T~D~30T~D~40T~D~50T~A~:[~2*~;~60T~A~70T~A~]~&"
	      (task-priority entry)
	      (ritp-run  (task-last-run entry))
	      (ritp-real (task-last-run entry))
	      (ritp-run  (task-total-time entry))
	      (ritp-real (task-total-time entry))
	      (task-name entry)
	      verbose?
	      (task-wait-fn entry)
	      (task-task entry))
      #f)
    (unless port
      (set! port t))
    (format port "~&~10T-----Last-----~30T-----Total----~50T~D task~:P~65TTime ~D~&~
              Pri~10TRun~20TReal~30TRun~40TReal~50TName~:[~;~60T~TWait-fn~70TTask~]~&"
	    (count-tasks)
	    (get-internal-real-time)
	    verbose?)
    (walk-tasklist show-entry)))

(set! scheduler:current-task (lambda () current-task-entry))

(set! scheduler:current-priority 
      (lambda () (task-priority current-task-entry)))

(set! scheduler:current-name
      (lambda () (task-name current-task-entry)))

(set! scheduler:rename-current
      (lambda (new-name) 
	(cond ((and (name-good? new-name)
		    (or (list? new-name)
			(not (task-exists? new-name))
			(names-equal? new-name (task-name current-task-entry))))
	       (vector-set! current-task-entry 4 new-name)
	       #t)
	      (t
	       #f))))

(set! scheduler:show-tasklist show-tasklist)
(set! scheduler:soon soon)
(set! scheduler:initialize! initialize!)
(set! scheduler:task-exists? task-exists?)
(set! scheduler:add-task! add-task!)
(set! scheduler:add-once-task! add-once-task!)
(set! scheduler:add-timeout-task! add-timeout-task!)
(set! scheduler:add-periodic-task! add-periodic-task!)
(set! scheduler:add-at-task! add-at-task!)
(set! scheduler:kill-task! kill-task!)
(set! scheduler:remove-task! remove-task!)
(set! scheduler:change-task-priority! change-task-priority!)
(set! scheduler:task-ready? task-ready?)
(set! scheduler:task-last-finished? task-last-finished?)
(set! scheduler:task-total-time? task-total-time?)
(set! scheduler:task-name task-name)

)					; --- End of scheduler environment.

;;;; Dead code.

;;; This procedure can be called by user functions to end their timeslice in the middle of
;;; computation.  The user function, when scheduled next time, will resume at the point it
;;; called scheduler:yield.  Optionally, the caller can specify a new wait function for testing resumption
;;; (scheduler:yield [new-wait-fn])
;;; This wait function will only be in effect for the next invocation of the task, and after that the task
;;; is going to revert to the old wait function.

;;; This is a legacy item and may well be removed-- you should change your
;;; code to use the deferred execution macros, which are much more efficient,
;;; and should cover almost all cases.

;(define (yield:valid-arguments? args)
;  (and (list? args)
;       (not (null? args))
;       (wait-fn? (car args))))
;
;(define (yield . args)
;  (call-with-current-continuation
;   (lambda (resume-task)
;     (let* ((current-task-wait-fn (wait-fn current-task-entry))
;	    (new-task-wait-fn (if (yield:valid-arguments? args)
;				  (car args)
;				  current-task-wait-fn))
;	    (current-task-function (task current-task-entry)))
;       (set-wait-fn! current-task-entry new-task-wait-fn)
;       (add-ritp! (total-time current-task-entry)
;		  current-task-starting-time) ; Update the total real- and runtime of this task.
;       (set-ritp! (last-run current-task-entry)) ; Update the real- and runtime of when this task last finished running.
;       (set-task! current-task-entry
;		  (lambda ()
		  ;; This will make then next invocation of the task start at the beginning again
		  ;; Note this assumes that scheduler:current-task-entry will point to the current
		  ;; task entry when this thunk is executed, which should be true if it is executed
		  ;; through scheduler:run-entry
;		  (set-wait-fn! current-task-entry current-task-wait-fn)
;		  (set-task! current-task-entry current-task-function)
;		  (resume-task 'resumed)))
;       (escape-to-toplevel 'yielded)))))

;(set! scheduler:yield yield)

;;; End of file.
