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
198
199
200
|
;;; Cooperative REPL server
;; Copyright (C) 2014, 2016 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA
;;; Code:
(define-module (system repl coop-server)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 threads)
#:use-module (ice-9 q)
#:use-module (srfi srfi-9)
#:export (spawn-coop-repl-server
poll-coop-repl-server))
;; Hack to import private bindings from (system repl repl).
(define-syntax-rule (import-private module sym ...)
(begin
(define sym (@@ module sym))
...))
(import-private (system repl repl) start-repl* prompting-meta-read)
(import-private (system repl server)
run-server* add-open-socket! close-socket!
make-tcp-server-socket guard-against-http-request)
(define-record-type <coop-repl-server>
(%make-coop-repl-server mutex queue)
coop-repl-server?
(mutex coop-repl-server-mutex)
(queue coop-repl-server-queue))
(define (make-coop-repl-server)
(%make-coop-repl-server (make-mutex) (make-q)))
(define (coop-repl-server-eval coop-server opcode . args)
"Queue a new instruction with the symbolic name OPCODE and an arbitrary
number of arguments, to be processed the next time COOP-SERVER is polled."
(with-mutex (coop-repl-server-mutex coop-server)
(enq! (coop-repl-server-queue coop-server)
(cons opcode args))))
(define-record-type <coop-repl>
(%make-coop-repl mutex condvar thunk cont)
coop-repl?
(mutex coop-repl-mutex)
(condvar coop-repl-condvar) ; signaled when thunk becomes non-#f
(thunk coop-repl-read-thunk set-coop-repl-read-thunk!)
(cont coop-repl-cont set-coop-repl-cont!))
(define (make-coop-repl)
(%make-coop-repl (make-mutex) (make-condition-variable) #f #f))
(define (coop-repl-read coop-repl)
"Read an expression via the thunk stored in COOP-REPL."
(let ((thunk
(with-mutex (coop-repl-mutex coop-repl)
(unless (coop-repl-read-thunk coop-repl)
(wait-condition-variable (coop-repl-condvar coop-repl)
(coop-repl-mutex coop-repl)))
(let ((thunk (coop-repl-read-thunk coop-repl)))
(unless thunk
(error "coop-repl-read: condvar signaled, but thunk is #f!"))
(set-coop-repl-read-thunk! coop-repl #f)
thunk))))
(thunk)))
(define (store-repl-cont cont coop-repl)
"Save the partial continuation CONT within COOP-REPL."
(set-coop-repl-cont! coop-repl
(lambda (exp)
(coop-repl-prompt
(lambda () (cont exp))))))
(define (coop-repl-prompt thunk)
"Apply THUNK within a prompt for cooperative REPLs."
(call-with-prompt 'coop-repl-prompt thunk store-repl-cont))
(define (make-coop-reader coop-repl)
"Return a new procedure for reading user input from COOP-REPL. The
generated procedure passes the responsibility of reading input to
another thread and aborts the cooperative REPL prompt."
(lambda (repl)
(let ((read-thunk
;; Need to preserve the REPL stack and current module across
;; threads.
(let ((stack (fluid-ref *repl-stack*))
(module (current-module)))
(lambda ()
(with-fluids ((*repl-stack* stack))
(set-current-module module)
(prompting-meta-read repl))))))
(with-mutex (coop-repl-mutex coop-repl)
(when (coop-repl-read-thunk coop-repl)
(error "coop-reader: read-thunk is not #f!"))
(set-coop-repl-read-thunk! coop-repl read-thunk)
(signal-condition-variable (coop-repl-condvar coop-repl))))
(abort-to-prompt 'coop-repl-prompt coop-repl)))
(define (reader-loop coop-server coop-repl)
"Run an unbounded loop that reads an expression for COOP-REPL and
stores the expression within COOP-SERVER for later evaluation."
(coop-repl-server-eval coop-server 'eval coop-repl
(coop-repl-read coop-repl))
(reader-loop coop-server coop-repl))
(define (poll-coop-repl-server coop-server)
"Poll the cooperative REPL server COOP-SERVER and apply a pending
operation if there is one, such as evaluating an expression typed at the
REPL prompt. This procedure must be called from the same thread that
called spawn-coop-repl-server."
(let ((op (with-mutex (coop-repl-server-mutex coop-server)
(let ((queue (coop-repl-server-queue coop-server)))
(and (not (q-empty? queue))
(deq! queue))))))
(when op
(match op
(('new-repl client)
(start-repl-client coop-server client))
(('eval coop-repl exp)
((coop-repl-cont coop-repl) exp))))
*unspecified*))
(define (start-coop-repl coop-server)
"Start a new cooperative REPL process for COOP-SERVER."
;; Calling stop-server-and-clients! from a REPL will cause an
;; exception to be thrown when trying to read from the socket that has
;; been closed, so we catch that here.
(false-if-exception
(let ((coop-repl (make-coop-repl)))
(make-thread reader-loop coop-server coop-repl)
(start-repl* (current-language) #f (make-coop-reader coop-repl)))))
(define (run-coop-repl-server coop-server server-socket)
"Start the cooperative REPL server for COOP-SERVER using the socket
SERVER-SOCKET."
(run-server* server-socket (make-coop-client-proc coop-server)))
(define* (spawn-coop-repl-server
#:optional (server-socket (make-tcp-server-socket)))
"Create and return a new cooperative REPL server object, and spawn a
new thread to listen for connections on SERVER-SOCKET. Proper
functioning of the REPL server requires that poll-coop-repl-server be
called periodically on the returned server object."
(let ((coop-server (make-coop-repl-server)))
(make-thread run-coop-repl-server
coop-server
server-socket)
coop-server))
(define (make-coop-client-proc coop-server)
"Return a new procedure that is used to schedule the creation of a new
cooperative REPL for COOP-SERVER."
(lambda (client addr)
(coop-repl-server-eval coop-server 'new-repl client)))
(define (start-repl-client coop-server client)
"Run a cooperative REPL for COOP-SERVER within a prompt. All input
and output is sent over the socket CLIENT."
;; Add the client to the list of open sockets, with a 'force-close'
;; procedure that closes the underlying file descriptor. We do it
;; this way because we cannot close the port itself safely from
;; another thread.
(add-open-socket! client (lambda () (close-fdes (fileno client))))
(guard-against-http-request client)
(with-continuation-barrier
(lambda ()
(coop-repl-prompt
(lambda ()
(parameterize ((current-input-port client)
(current-output-port client)
(current-error-port client)
(current-warning-port client))
(with-fluids ((*repl-stack* '()))
(save-module-excursion
(lambda ()
(start-coop-repl coop-server)))))
;; This may fail if 'stop-server-and-clients!' is called,
;; because the 'force-close' procedure above closes the
;; underlying file descriptor instead of the port itself.
(false-if-exception
(close-socket! client)))))))
|
