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
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; 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 ()
(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
(get-dynamic-env)
'scheduler-initial-thread)))
(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 ((error? condition)
(display "Error 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)
(display (case (car condition)
((error) "Error")
((exception) "Exception")
((warning) "Warning")
(else (car condition)))
out)
(display ": " out)
(display (cadr condition) out)
(newline out)
(for-each (lambda (irritant)
(display " " out)
(display irritant out)
(newline out))
(cddr condition)))
; 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
(waiting-for-i/o?)
(waiting-for-sigevent?))
(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))))))
(define one-day-of-milliseconds (* (* 1000 60) (* 60 24)))
; 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 (quotient time-until-wakeup 60000)
#t))))
(structure-ref primitives wait)))
(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 (lambda (thunk)
(spawn-on-root thunk 'output-forcer))
thunks)
#t))))
(define unspecific (structure-ref primitives unspecific))
|
