scsh-0.6/scheme/rts/scheduler.scm

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.

; A parameterized scheduler.

; (run-threads event-handler) -> unspecific
;   (event-handler thread time-left event event-data) -> [thread args time]
; A bogus BLOCKED event is passed to the handler to get the initial thread.

(define (run-threads event-handler)
  (call-with-values
   (lambda ()
     (event-handler #f 0 (enum event-type blocked) '()))
   (lambda (thread time)
     (if thread
	 (let loop ((thread thread) (time time))
	   (call-with-values
	    (lambda ()
	      (run thread time))
	    (lambda (time-left event . event-data)
	      (call-with-values
	       (lambda ()
		 (event-handler thread time-left event event-data))
	       (lambda (thread time)
		 (if thread
		     (loop thread time)))))))))))
	    
; Same thing, with the addition of a housekeeping thunk that gets
; run periodically.

(define (run-threads-with-housekeeper event-handler housekeeper delay)
  (call-with-values
   (lambda ()
     (event-handler #f 0 (enum event-type blocked) '()))
   (lambda (thread time)
     (if thread
	 (let loop ((thread thread) (time time) (hk-time delay))
	   (call-with-values
	    (lambda ()
	      (run thread time))
	    (lambda (time-left event . event-data)
	      (let ((hk-time (let ((temp (- hk-time (- time time-left))))
			       (if (<= temp 0)
				   (begin
				     (housekeeper)
				     delay)
				   temp))))
		(call-with-values
		 (lambda ()
		   (event-handler thread time-left event event-data))
		 (lambda (thread time)
		   (if thread
		       (loop thread time hk-time))))))))))))

; An event-handler that does round-robin scheduling.
; Arguments:
;    runnable         ; queue of threads
;    quantum          ; number of ticks each thread gets
;    dynamic-env      ; initial dynamic environments for new threads
;    thread-count     ; counter tracking the number of threads
;    event-handler : event-type event-data -> handled?
;    upcall-handler : thread token . args -> return-values
;    wait             ; thunk returns #t if scheduling is to continue

(define (round-robin-event-handler runnable quantum dynamic-env thread-count
				   event-handler upcall-handler wait)

  (define (thread-event-handler thread time-left event event-data)
    (enum-case event-type event

      ;; the thread stops, either temporarily or permanently
      ((blocked)
       (next-thread))
      ((completed killed)
       (decrement-counter! thread-count)
       (next-thread))
      ((out-of-time)
       (enqueue-thread! runnable thread)
       (next-thread))

      ;; the thread keeps running
      ((upcall)
       (call-with-values
	(lambda ()
	  (apply upcall-handler event-data))
	(lambda results
	  (set-thread-arguments! thread results)
	  (values thread time-left))))
      (else
       (asynchronous-event-handler event event-data)
       (values thread time-left))))

  ;; We call EVENT-HANDLER first so that it can override the default behavior
  (define (asynchronous-event-handler event event-data)
    (or (event-handler event event-data)
	(enum-case event-type event
	  ((runnable)
	   (enqueue-thread! runnable (car event-data)))
	  ((spawned)
	   (increment-counter! thread-count)
	   (enqueue-thread! runnable
			    (make-thread (car event-data)
					 dynamic-env
					 (cadr event-data))))
 	  ((narrowed)
	   (handle-narrow-event quantum dynamic-env event-data))
	  ((no-event)
	   (values))
	  (else
	   (error "unhandled event"
		  (cons (enumerand->name event event-type)
			event-data)
		  event-handler)))))

  (define (next-thread)
    (if (thread-queue-empty? runnable)
	(call-with-values
	 get-next-event!
	 (lambda (event . data)
	   (cond ((not (eq? event (enum event-type no-event)))
		  (asynchronous-event-handler event data)
		  (next-thread))
		 ((wait)
		  (next-thread))
		 (else
		  (values #f 0)))))   ; scheduler quits
	(values (dequeue-thread! runnable)
		quantum)))

  thread-event-handler)

(define (handle-narrow-event quantum dynamic-env event-data)
  (let ((thread (current-thread))
	(lock (make-lock)))
    (obtain-lock lock)
    (spawn
     (lambda ()
       (let ((runnable (make-thread-queue))
	     (thread (make-thread (car event-data)
				  dynamic-env
				  (cadr event-data)))
	     (thread-count (make-counter)))
       
	 (enqueue-thread! runnable thread)
	 (increment-counter! thread-count)
       
	 (run-threads
	  (round-robin-event-handler runnable quantum dynamic-env thread-count
				     (lambda args #f)
				     (lambda (thread token args) ; upcall handler
				       (propogate-upcall thread token args))
				     (lambda ()
				       (if (positive? (counter-value thread-count))
					   (wait)
					   #f))))
	 (release-lock lock)))
     'narrowed-scheduler)
    (obtain-lock lock)))

; Simple counting cell

(define (make-counter)
  (list 0))

(define counter-value car)

(define (increment-counter! count)
  (set-car! count (+ 1 (car count))))

(define (decrement-counter! count)
  (set-car! count (- (car count) 1)))