-
-
Notifications
You must be signed in to change notification settings - Fork 647
/
evt.rkt
197 lines (172 loc) · 8.42 KB
/
evt.rkt
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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
#lang racket/base
(require "atomic.rkt")
(provide prop:evt
evt?
evt-poll
(rename-out [the-never-evt never-evt]
[the-always-evt always-evt]
[the-async-evt async-evt])
never-evt?
async-evt?
(struct-out wrap-evt)
(struct-out handle-evt)
(struct-out control-state-evt)
(struct-out poll-guard-evt)
(struct-out choice-evt)
(struct-out poller)
(struct-out poll-ctx)
(struct-out delayed-poll)
prop:secondary-evt
poller-evt
evt-impersonator?)
(module+ for-chaperone
(provide primary-evt? primary-evt-ref
secondary-evt? secondary-evt-ref
impersonator-prop:evt))
(define-values (prop:evt primary-evt? primary-evt-ref)
(make-struct-type-property 'evt
(lambda (v info)
(define who '|guard-for-prop:evt|)
(cond
[(poller? v) v] ; part of the internal API, not the safe API
[(evt? v) v]
[(and (procedure? v)
(procedure-arity-includes? v 1))
v]
[(exact-nonnegative-integer? v)
(define init-count (cadr info))
(unless (v . < . init-count)
(raise-arguments-error who
"index for immutable field >= initialized-field count"
"index" v
"initialized-field count" init-count))
(unless (memv v (list-ref info 5))
(raise-arguments-error who "field index not declared immutable"
"field index" v))
(selector-prop-evt-value
(make-struct-field-accessor (list-ref info 3) v))]
[else
(raise-argument-error who
"(or/c evt? (procedure-arity-includes/c 1) exact-nonnegative-integer?)"
v)]))))
(struct selector-prop-evt-value (selector)
#:authentic)
;; `prop:secondary-evt` is for primitive property types that
;; (due to histoical, bad design choices) act like `prop:evt`
;; without implying `prop:evt`. Specifically, it's used for
;; input and output ports.
(define-values (prop:secondary-evt secondary-evt? secondary-evt-ref)
(make-struct-type-property 'secondary-evt))
(define (evt? v)
(or (primary-evt? v)
(secondary-evt? v)))
;; A poller as a `prop:evt` value wraps a procedure that is called
;; in atomic mode
;; evt poll-ctx -> (values results-or-#f replacing-evt-or-#f)
;; where either a list of results is returned, indicating
;; that the event is selected, or a replacement event
;; is returned (possibly unchanged). If the replacement event
;; is a wrapper on `always-evt`, it will certainly be selected.
;; If a poller does any work that can allow some thread to
;; become unblocked, then it must tell the scheduler via
;; `schedule-info-did-work!`.
(struct poller (proc))
;; Provided to a `poller` function:
(struct poll-ctx (poll? ; whether events are being polled once (i.e., 0 timeout)
select-proc ; callback to asynchronously select the event being polled
sched-info ; instructions to the scheduler, such as timeouts
[incomplete? #:mutable])) ; #t => getting back the same event does not imply a completed poll
;; If a `poller` callback keeps `select-proc` for asynchronous use,
;; then it should return a `control-state-evt` to ensure that
;; `select-proc` is not called if the event is abandoned.
(struct never-evt ()
#:property prop:evt (poller (lambda (self poll-ctx)
(assert-atomic-mode)
(values #f self))))
(define the-never-evt (never-evt))
(struct always-evt ()
#:property prop:evt (poller (lambda (self poll-ctx)
(assert-atomic-mode)
(values (list self) #f))))
(define the-always-evt (always-evt))
;; A placeholder for an event that will be selected through a callback
;; instead of polling:
(struct async-evt ()
#:property prop:evt (poller (lambda (self poll-ctx)
(assert-atomic-mode)
(values #f self))))
(define the-async-evt (async-evt))
(struct wrap-evt (evt wrap)
#:property prop:evt (poller (lambda (self poll-ctx)
(assert-atomic-mode)
(values #f self)))
#:reflection-name 'evt)
(struct handle-evt wrap-evt ())
;; A `control-state-evt` enables (unsafe) cooperation with the
;; scheduler, normally produced by a `poller` callback. The `evt` is
;; typically a wrapper on `async-evt`. If the event is not selected,
;; the `interrupt-proc` plus `abandon-proc` will be called. If a
;; synchronization attempt is interrupted by a break signal, then
;; `interrupt-proc` is called, and then either `abandon-proc` or
;; `retry-proc` --- the latter when the synchronization attempt
;; continues, in which case a value might be ready immediately or the
;; event goes back to some waiting state. For example, a sempahore
;; uses `interrupt-proc` to get out of the semaphore's queue and
;; `rety-proc` gets back in line (or immediately returns if the
;; semaphore was meanwhile posted). As another example, a
;; `nack-guard-evt`'s result uses `abandon-proc` to post to the NACK
;; event.
;; Beware that it doesn't make sense to use `wrap-evt` around the
;; `control-state-evt` or the `evt` inside for an asynchronously
;; satisfied event (like the way that semaphores are implemented). The
;; event may be selected asynchronously before a wrapper on the inner
;; event is found, so that the result turns out to be an unwrapped
;; event. Or the `interrupt-proc`, etc., callbacks may not be found
;; early enough if the `control-state-evt` is wrapped.
(struct control-state-evt (evt
wrap-proc
interrupt-proc ; thunk for break/kill initiated or otherwise before `abandon-proc`
abandon-proc ; thunk for not selected, including break/kill complete
retry-proc) ; thunk for resume from break; return `(values _val _ready?)`
#:property prop:evt (poller (lambda (self poll-ctx) (values #f self))))
(struct poll-guard-evt (proc)
#:property prop:evt (poller (lambda (self poll-ctx) (values #f self)))
#:reflection-name 'evt)
(struct choice-evt (evts)
#:property prop:evt (poller (lambda (self poll-ctx) (values #f self)))
#:reflection-name 'evt)
(define-values (impersonator-prop:evt evt-impersonator? evt-impersonator-ref)
(make-impersonator-property 'evt-impersonator))
;; Called in atomic mode
;; Checks whether an event is ready; returns the same results
;; as a poller. If getting an event requires going out of atomic mode
;; (to call a `prop:evt` procedure) then return a `delayed-poll`
;; struct.
(define (evt-poll evt poll-ctx)
(assert-atomic-mode)
(let* ([v (cond
[(evt-impersonator? evt) (evt-impersonator-ref evt)]
[(primary-evt? evt)
(primary-evt-ref evt)]
[else
(secondary-evt-ref evt)])]
[v (if (selector-prop-evt-value? v)
((selector-prop-evt-value-selector v) evt)
v)])
(cond
[(procedure? v)
(values #f (delayed-poll
;; out of atomic mode:
(lambda ()
(let ([v (call-with-continuation-barrier (lambda () (v evt)))])
(cond
[(evt? v) v]
[(poller? v) (poller-evt v)]
[else (wrap-evt the-always-evt (lambda (v) evt))])))))]
[(poller? v) ((poller-proc v) evt poll-ctx)]
[(evt? v) (values #f v)]
[else (values #f the-never-evt)])))
;; Possible result from `evt-poll`:
(struct delayed-poll (resume))
(struct poller-evt (poller)
#:property prop:evt (struct-field-index poller))