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
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber,
; Suresh Jagannathan, Henry Ceijtin
; The root scheduler.
;
; This uses RUN-THREADS-WITH-HOUSEKEEPER from the round-robin scheduler.
; The housekeeping thread flushes output buffers and wakes any sleeping
; threads whose time has come.
(define (root-scheduler thunk quantum housekeeping-quantum)
(let ((*result* 111))
(call-with-current-continuation
(lambda (abort)
(initialize-channel-i/o!)
(run-threads-with-housekeeper (make-root-event-handler
(lambda () (set! *result* (thunk)))
quantum
abort)
(lambda ()
(zap-i/o-orphans!)
(zap-external-event-orphans!)
(spawn-output-forcers #t)
(wake-some-threads))
housekeeping-quantum)
*result*))))
; Returns a handler and a procedure for adding new threads. No events
; are handled specially. The only upcall is for aborting execution.
(define (make-root-event-handler thunk quantum abort)
(let ((runnable (make-queue))
(thread-count (make-counter))
(safe-dynamic-env (with-handler root-handler get-dynamic-env))
(thread (make-thread thunk
'scheduler-initial-thread)))
(set-thread-scheduler! thread (current-thread))
(set-thread-dynamic-env! thread (get-dynamic-env))
(increment-counter! thread-count)
(enqueue! runnable thread)
(round-robin-event-handler
runnable quantum safe-dynamic-env thread-count
(lambda args #f) ; we handle no events
(lambda (thread token args) ; upcall handler
(if (eq? token abort-token)
(abort (car args))
(propogate-upcall thread token args)))
root-wait)))
; Let the user know if anything goes wrong while running a root thread.
; Errors kill the offending thread, warnings allow it to proceed.
(define (root-handler condition next-handler)
(let ((out (current-error-port)))
(cond ((serious-condition? condition)
(display "Serious problem while running root thread, thread killed: " out)
(display (current-thread) out)
(newline out)
(cheap-display-condition condition out)
(terminate-current-thread))
((warning? condition)
(cheap-display-condition condition out)
(unspecific)) ;proceed
(else
(next-handler)))))
(define (cheap-display-condition condition out)
(call-with-values
(lambda () (decode-condition condition))
(lambda (type who message stuff)
(display (case type
((error) "Error")
((assertion-violation) "Assertion violation")
((serious) "Serious problem")
((vm-exception) "VM Exception")
((warning) "Warning")
(else type))
out)
(display ": " out)
(display " [" out)
(display who out)
(display "]" out)
(display message out)
(newline out)
(for-each (lambda (irritant)
(display " " out)
(display irritant out)
(newline out))
stuff))))
; Upcall token
(define abort-token (list 'abort-token))
(define scheme-exit-now
(lambda (status)
(upcall abort-token status)))
; Getting around to calling the VM's WAIT procedure. We disable interrupts
; to keep things from happening behind our back, and then see if there is
; any thread to run or any event pending, or if work may appear in the future.
(define (root-wait)
(set-enabled-interrupts! 0)
(let ((forcers? (spawn-output-forcers #f)))
(call-with-values
wake-some-threads
(lambda (woke-some? time-until-wakeup)
(cond ((or forcers? woke-some? (event-pending?))
(set-enabled-interrupts! all-interrupts)
#t)
((or time-until-wakeup
(> threads-not-deadlocked-count 0))
(do-some-waiting time-until-wakeup)
(set-enabled-interrupts! all-interrupts)
(root-wait))
((session-data-ref deadlock-handler)
=> (lambda (handler)
(handler)
(set-enabled-interrupts! all-interrupts)
#t))
(else
(set-enabled-interrupts! all-interrupts)
#f))))))
; A mess because a fixnum's worth of milliseconds is only a few days.
; The VM's WAIT procedure takes its maximum-wait argument in either
; milliseconds or minutes.
(define (do-some-waiting time-until-wakeup)
(call-with-values
(lambda ()
(cond ((not time-until-wakeup)
(values -1 #f))
((< time-until-wakeup one-day-of-milliseconds)
(values time-until-wakeup #f))
(else
(values (min (quotient time-until-wakeup
one-minute-of-milliseconds)
one-year-of-minutes) ; stick with fixnums
#t))))
wait))
(define one-minute-of-milliseconds (* 1000 60))
(define one-day-of-milliseconds (* one-minute-of-milliseconds
60 ; minutes in an hour
24)) ; hours in a day
(define one-year-of-minutes (* 60 24 365))
(define deadlock-handler (make-session-data-slot! #f))
(define (call-when-deadlocked! thunk)
(session-data-set! deadlock-handler thunk))
; Find any ports that need to be flushed. We get both a thunk to flush the
; port and the port itself; the port is only used for reporting problems.
(define (spawn-output-forcers others-waiting?)
(let ((thunks (output-port-forcers others-waiting?)))
(cond ((null? thunks)
#f)
(else
(for-each spawn-on-root thunks)
#t))))
|
