Newer
Older
;;; -*- Log: code.log; Package: wire -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/remote.lisp,v 1.3 1992/02/15 12:50:14 wlott Exp $")
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
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
;;; **********************************************************************
;;;
;;; This file implements a simple remote procedure call mechanism on top
;;; of wire.lisp.
;;;
;;; Written by William Lott.
;;;
(in-package "WIRE")
(export '(remote remote-value remote-value-bind create-request-server
destroy-request-server connect-to-remote-server))
(defstruct remote-wait
value1 value2 value3 value4 value5
abort
finished)
(defvar *pending-returns* nil
"AList of wire . remote-wait structs")
;;; MAYBE-NUKE-REMOTE-WAIT -- internal
;;;
;;; If the remote wait has finished, remove the external translation.
;;; Otherwise, mark the remote wait as finished so the next call to
;;; MAYBE-NUKE-REMOTE-WAIT will really nuke it.
;;;
(defun maybe-nuke-remote-wait (remote)
(cond ((remote-wait-finished remote)
(forget-remote-translation remote)
t)
(t
(setf (remote-wait-finished remote)
t)
nil)))
;;; REMOTE -- public
;;;
;;; Execute the body remotly. Subforms are executed locally in the lexical
;;; envionment of the macro call. No values are returned.
;;;
(defmacro remote (wire-form &body forms)
"Evaluates the given forms remotly. No values are returned, as the remote
evaluation is asyncronus."
(let ((wire (gensym)))
`(let ((,wire ,wire-form))
,@(mapcar #'(lambda (form)
`(wire-output-funcall ,wire
',(car form)
,@(cdr form)))
forms)
(values))))
;;; REMOTE-VALUE-BIND -- public
;;;
;;; Send to remote forms. First, a call to the correct dispatch routine based
;;; on the number of args, then the actual call. The dispatch routine will get
;;; the second funcall and fill in the correct number of arguments.
;;; Note: if there are no arguments, we don't even wait for the function to
;;; return, cause we can kind of guess at what the currect results would be.
;;;
(defmacro remote-value-bind (wire-form vars form &rest body)
"Bind vars to the multiple values of form (which is executed remotly). The
forms in body are only executed if the remote function returned as apposed
to aborting due to a throw."
(cond
((null vars)
`(progn
(remote ,wire-form ,form)
,@body))
(t
(let ((remote (gensym))
(wire (gensym)))
`(let* ((,remote (make-remote-wait))
(,wire ,wire-form)
(*pending-returns* (cons (cons ,wire ,remote)
*pending-returns*)))
(unwind-protect
(let ,vars
(remote ,wire
(,(case (length vars)
(1 'do-1-value-call)
(2 'do-2-value-call)
(3 'do-3-value-call)
(4 'do-4-value-call)
(5 'do-5-value-call)
(t 'do-n-value-call))
(make-remote-object ,remote))
,form)
(wire-force-output ,wire)
(loop
(system:serve-all-events)
(when (remote-wait-finished ,remote)
(return)))
(unless (remote-wait-abort ,remote)
,(case (length vars)
(1 `(setf ,(first vars) (remote-wait-value1 ,remote)))
(2 `(setf ,(first vars) (remote-wait-value1 ,remote)
,(second vars) (remote-wait-value2 ,remote)))
(3 `(setf ,(first vars) (remote-wait-value1 ,remote)
,(second vars) (remote-wait-value2 ,remote)
,(third vars) (remote-wait-value3 ,remote)))
(4 `(setf ,(first vars) (remote-wait-value1 ,remote)
,(second vars) (remote-wait-value2 ,remote)
,(third vars) (remote-wait-value3 ,remote)
,(fourth vars) (remote-wait-value4 ,remote)))
(5 `(setf ,(first vars) (remote-wait-value1 ,remote)
,(second vars) (remote-wait-value2 ,remote)
,(third vars) (remote-wait-value3 ,remote)
,(fourth vars) (remote-wait-value4 ,remote)
,(fifth vars) (remote-wait-value5 ,remote)))
(t
(do ((remaining-vars vars (cdr remaining-vars))
(form (list 'setf)
(nconc form
(list (car remaining-vars)
`(pop values)))))
((null remaining-vars)
`(let ((values (remote-wait-value1 ,remote)))
,form)))))
,@body))
(maybe-nuke-remote-wait ,remote)))))))
;;; REMOTE-VALUE -- public
;;;
;;; Alternate interface to getting the single return value of a remote
;;; function. Works pretty much just the same, except the single value is
;;; returned.
;;;
(defmacro remote-value (wire-form form &optional
(on-server-unwind
`(error "Remote server unwound")))
"Execute the single form remotly. The value of the form is returned.
The optional form on-server-unwind is only evaluated if the server unwinds
instead of returning."
(let ((remote (gensym))
(wire (gensym)))
`(let* ((,remote (make-remote-wait))
(,wire ,wire-form)
(*pending-returns* (cons (cons ,wire ,remote)
*pending-returns*)))
(unwind-protect
(progn
(remote ,wire
(do-1-value-call (make-remote-object ,remote))
,form)
(wire-force-output ,wire)
(loop
(system:serve-all-events)
(when (remote-wait-finished ,remote)
(return))))
(maybe-nuke-remote-wait ,remote))
(if (remote-wait-abort ,remote)
,on-server-unwind
(remote-wait-value1 ,remote)))))
;;; DEFINE-FUNCTIONS -- internal
;;;
;;; Defines two functions, one that the client runs in the server, and one
;;; that the server runs in the client:
;;;
;;; DO-n-VALUE-CALL -- internal
;;;
;;; Executed by the remote process. Reads the next object off the wire and
;;; sends the value back. Unwind-protect is used to make sure we send something
;;; back so the requestor doesn't hang.
;;;
;;; RETURN-n-VALUE -- internal
;;;
;;; The remote procedure returned the given value, so fill it in the
;;; remote-wait structure. Note, if the requestor has aborted, just throw
;;; the value away.
;;;
(defmacro define-functions (values)
(let ((do-call (intern (format nil "~:@(do-~D-value-call~)" values)))
(return-values (intern (format nil "~:@(return-~D-value~:P~)" values)))
(vars nil))
(dotimes (i values)
(push (gensym) vars))
(setf vars (nreverse vars))
`(progn
(defun ,do-call (result)
(let (worked ,@vars)
(unwind-protect
(progn
(multiple-value-setq ,vars
(wire-get-object *current-wire*))
(setf worked t))
(if worked
(remote *current-wire*
(,return-values result ,@vars))
(remote *current-wire*
(remote-return-abort result)))
(wire-force-output *current-wire*))))
(defun ,return-values (remote ,@vars)
(let ((result (remote-object-value remote)))
(unless (maybe-nuke-remote-wait result)
,@(let ((setf-forms nil))
(dotimes (i values)
(push `(setf (,(intern (format nil
"~:@(remote-wait-value~D~)"
(1+ i)))
result)
,(nth i vars))
setf-forms))
(nreverse setf-forms))))
nil))))
(define-functions 1)
(define-functions 2)
(define-functions 3)
(define-functions 4)
(define-functions 5)
;;; DO-N-VALUE-CALL -- internal
;;;
;;; For more values then 5, all the values are rolled into a list and passed
;;; back as the first value, so we use RETURN-1-VALUE to return it.
;;;
(defun do-n-value-call (result)
(let (worked values)
(unwind-protect
(progn
(setf values
(multiple-value-list (wire-get-object *current-wire*)))
(setf worked t))
(if worked
(remote *current-wire*
(return-1-values result values))
(remote *current-wire*
(remote-return-abort result)))
(wire-force-output *current-wire*))))
;;; REMOTE-RETURN-ABORT -- internal
;;;
;;; The remote call aborted instead of returned.
;;;
(defun remote-return-abort (result)
(setf result (remote-object-value result))
(unless (maybe-nuke-remote-wait result)
(setf (remote-wait-abort result) t)))
;;; SERVE-REQUESTS -- internal
;;;
;;; Serve all pending requests on the given wire.
;;;
(defun serve-requests (wire on-death)
(handler-bind
((wire-eof #'(lambda (condition)
(declare (ignore condition))
(system:invalidate-descriptor (wire-fd wire))
(unix:unix-close (wire-fd wire))
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
(dolist (pending *pending-returns*)
(when (eq (car pending)
wire)
(unless (maybe-nuke-remote-wait (cdr pending))
(setf (remote-wait-abort (cdr pending))
t))))
(when on-death
(funcall on-death))
(return-from serve-requests (values))))
(wire-error #'(lambda (condition)
(declare (ignore condition))
(system:invalidate-descriptor (wire-fd wire)))))
(loop
(unless (wire-listen wire)
(return))
(wire-get-object wire)))
(values))
;;; NEW-CONNECTION -- internal
;;;
;;; Maybe build a new wire and add it to the servers list of fds. If the user
;;; Supplied a function, close the socket if it returns NIL. Otherwise, install
;;; the wire.
;;;
(defun new-connection (socket addr on-connect)
(let ((wire (make-wire socket))
(on-death nil))
(if (or (null on-connect)
(multiple-value-bind (okay death-fn)
(funcall on-connect wire addr)
(setf on-death death-fn)
okay))
(system:add-fd-handler socket :input
#'(lambda (socket)
(declare (ignore socket))
(serve-requests wire on-death)))
(ext:close-socket socket))))
;;; REQUEST-SERVER structure
;;;
;;; Just a simple handle on the socket and system:serve-event handler that make
;;; up a request server.
;;;
(defstruct (request-server
(:print-function %print-request-server))
socket
handler)
(defun %print-request-server (rs stream depth)
(declare (ignore depth))
(format stream "#<Requst server for ~D>" (request-server-socket rs)))
;;; CREATE-REQUEST-SERVER -- Public.
;;;
;;; Create a TCP/IP listener on the given port. If anyone tries to connect to
;;; it, call NEW-CONNECTION to do the connecting.
;;;
(defun create-request-server (port &optional on-connect)
"Create a request server on the given port. Whenevery anyone connects to it
call the given function with the newly created wire and the address of the
connector. If the function returns NIL, the connection is destroyed;
otherwise, it is accepted. This returns a manifestation of the server that
DESTROY-REQUEST-SERVER accepts to kill the request server."
(let* ((socket (ext:create-inet-listener port))
(handler (system:add-fd-handler socket :input
#'(lambda (socket)
(multiple-value-bind
(newconn addr)
(ext:accept-tcp-connection socket)
(new-connection newconn addr on-connect))))))
(make-request-server :socket socket
:handler handler)))
;;; DESTROY-REQUEST-SERVER -- Public.
;;;
;;; Removes the request server from SERVER's list of file descriptors and
;;; closes the socket behind it.
;;;
(defun destroy-request-server (server)
"Quit accepting connections to the given request server."
(system:remove-fd-handler (request-server-handler server))
(ext:close-socket (request-server-socket server))
nil)
;;; CONNECT-TO-REMOTE-SERVER -- Public.
;;;
;;; Just like the doc string says, connect to a remote server. A handler is
;;; installed to handle return values, etc.
;;;
(defun connect-to-remote-server (hostname port &optional on-death)
"Connect to a remote request server addressed with the given host and port
pair. This returns the created wire."
(let* ((socket (ext:connect-to-inet-socket hostname port))
(wire (make-wire socket)))
(system:add-fd-handler socket :input
#'(lambda (socket)
(declare (ignore socket))
(serve-requests wire on-death)))
wire))