1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
; 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)))
|
