171 lines
4.8 KiB
Scheme
171 lines
4.8 KiB
Scheme
; 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! 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! runnable (car event-data)))
|
|
((spawned)
|
|
(increment-counter! thread-count)
|
|
(enqueue! 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 (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! 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-queue))
|
|
(thread (make-thread (car event-data)
|
|
dynamic-env
|
|
(cadr event-data)))
|
|
(thread-count (make-counter)))
|
|
|
|
(enqueue! 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)))
|