/[cmucl]/src/code/remote.lisp
ViewVC logotype

Contents of /src/code/remote.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Mon Oct 7 14:31:05 2002 UTC (11 years, 6 months ago) by toy
Branch: MAIN
Changes since 1.6: +2 -2 lines
o Correct some spelling mistakes
o Fix a few typos in code.
o Delete a few unused symbols from various places
o Use something better than %%RWSEQ-EOF%% for the eof marker.
o Add target-foreign-linkage vars for the PPC and HPPA ports to aid
  cross-compilation.  (The values are very likely wrong, but they're
  not used yet.)

Based on a larger patch from Eric Marsden.
1 ;;; -*- Log: code.log; Package: wire -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/remote.lisp,v 1.7 2002/10/07 14:31:05 toy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file implements a simple remote procedure call mechanism on top
13 ;;; of wire.lisp.
14 ;;;
15 ;;; Written by William Lott.
16 ;;;
17
18 (in-package "WIRE")
19
20 (export '(remote remote-value remote-value-bind create-request-server
21 destroy-request-server connect-to-remote-server))
22
23
24 (defstruct remote-wait
25 value1 value2 value3 value4 value5
26 abort
27 finished)
28
29 (defvar *pending-returns* nil
30 "AList of wire . remote-wait structs")
31
32
33 ;;; MAYBE-NUKE-REMOTE-WAIT -- internal
34 ;;;
35 ;;; If the remote wait has finished, remove the external translation.
36 ;;; Otherwise, mark the remote wait as finished so the next call to
37 ;;; MAYBE-NUKE-REMOTE-WAIT will really nuke it.
38 ;;;
39 (defun maybe-nuke-remote-wait (remote)
40 (cond ((remote-wait-finished remote)
41 (forget-remote-translation remote)
42 t)
43 (t
44 (setf (remote-wait-finished remote)
45 t)
46 nil)))
47
48 ;;; REMOTE -- public
49 ;;;
50 ;;; Execute the body remotly. Subforms are executed locally in the lexical
51 ;;; envionment of the macro call. No values are returned.
52 ;;;
53 (defmacro remote (wire-form &body forms)
54 "Evaluates the given forms remotly. No values are returned, as the remote
55 evaluation is asyncronus."
56 (let ((wire (gensym)))
57 `(let ((,wire ,wire-form))
58 ,@(mapcar #'(lambda (form)
59 `(wire-output-funcall ,wire
60 ',(car form)
61 ,@(cdr form)))
62 forms)
63 (values))))
64
65 ;;; REMOTE-VALUE-BIND -- public
66 ;;;
67 ;;; Send to remote forms. First, a call to the correct dispatch routine based
68 ;;; on the number of args, then the actual call. The dispatch routine will get
69 ;;; the second funcall and fill in the correct number of arguments.
70 ;;; Note: if there are no arguments, we don't even wait for the function to
71 ;;; return, cause we can kind of guess at what the currect results would be.
72 ;;;
73 (defmacro remote-value-bind (wire-form vars form &rest body)
74 "Bind vars to the multiple values of form (which is executed remotly). The
75 forms in body are only executed if the remote function returned as apposed
76 to aborting due to a throw."
77 (cond
78 ((null vars)
79 `(progn
80 (remote ,wire-form ,form)
81 ,@body))
82 (t
83 (let ((remote (gensym))
84 (wire (gensym)))
85 `(let* ((,remote (make-remote-wait))
86 (,wire ,wire-form)
87 (*pending-returns* (cons (cons ,wire ,remote)
88 *pending-returns*)))
89 (unwind-protect
90 (let ,vars
91 (remote ,wire
92 (,(case (length vars)
93 (1 'do-1-value-call)
94 (2 'do-2-value-call)
95 (3 'do-3-value-call)
96 (4 'do-4-value-call)
97 (5 'do-5-value-call)
98 (t 'do-n-value-call))
99 (make-remote-object ,remote))
100 ,form)
101 (wire-force-output ,wire)
102 (loop
103 (system:serve-all-events)
104 (when (remote-wait-finished ,remote)
105 (return)))
106 (unless (remote-wait-abort ,remote)
107 ,(case (length vars)
108 (1 `(setf ,(first vars) (remote-wait-value1 ,remote)))
109 (2 `(setf ,(first vars) (remote-wait-value1 ,remote)
110 ,(second vars) (remote-wait-value2 ,remote)))
111 (3 `(setf ,(first vars) (remote-wait-value1 ,remote)
112 ,(second vars) (remote-wait-value2 ,remote)
113 ,(third vars) (remote-wait-value3 ,remote)))
114 (4 `(setf ,(first vars) (remote-wait-value1 ,remote)
115 ,(second vars) (remote-wait-value2 ,remote)
116 ,(third vars) (remote-wait-value3 ,remote)
117 ,(fourth vars) (remote-wait-value4 ,remote)))
118 (5 `(setf ,(first vars) (remote-wait-value1 ,remote)
119 ,(second vars) (remote-wait-value2 ,remote)
120 ,(third vars) (remote-wait-value3 ,remote)
121 ,(fourth vars) (remote-wait-value4 ,remote)
122 ,(fifth vars) (remote-wait-value5 ,remote)))
123 (t
124 (do ((remaining-vars vars (cdr remaining-vars))
125 (form (list 'setf)
126 (nconc form
127 (list (car remaining-vars)
128 `(pop values)))))
129 ((null remaining-vars)
130 `(let ((values (remote-wait-value1 ,remote)))
131 ,form)))))
132 ,@body))
133 (maybe-nuke-remote-wait ,remote)))))))
134
135
136 ;;; REMOTE-VALUE -- public
137 ;;;
138 ;;; Alternate interface to getting the single return value of a remote
139 ;;; function. Works pretty much just the same, except the single value is
140 ;;; returned.
141 ;;;
142 (defmacro remote-value (wire-form form &optional
143 (on-server-unwind
144 `(error "Remote server unwound")))
145 "Execute the single form remotly. The value of the form is returned.
146 The optional form on-server-unwind is only evaluated if the server unwinds
147 instead of returning."
148 (let ((remote (gensym))
149 (wire (gensym)))
150 `(let* ((,remote (make-remote-wait))
151 (,wire ,wire-form)
152 (*pending-returns* (cons (cons ,wire ,remote)
153 *pending-returns*)))
154 (unwind-protect
155 (progn
156 (remote ,wire
157 (do-1-value-call (make-remote-object ,remote))
158 ,form)
159 (wire-force-output ,wire)
160 (loop
161 (system:serve-all-events)
162 (when (remote-wait-finished ,remote)
163 (return))))
164 (maybe-nuke-remote-wait ,remote))
165 (if (remote-wait-abort ,remote)
166 ,on-server-unwind
167 (remote-wait-value1 ,remote)))))
168
169 ;;; DEFINE-FUNCTIONS -- internal
170 ;;;
171 ;;; Defines two functions, one that the client runs in the server, and one
172 ;;; that the server runs in the client:
173 ;;;
174 ;;; DO-n-VALUE-CALL -- internal
175 ;;;
176 ;;; Executed by the remote process. Reads the next object off the wire and
177 ;;; sends the value back. Unwind-protect is used to make sure we send something
178 ;;; back so the requestor doesn't hang.
179 ;;;
180 ;;; RETURN-n-VALUE -- internal
181 ;;;
182 ;;; The remote procedure returned the given value, so fill it in the
183 ;;; remote-wait structure. Note, if the requestor has aborted, just throw
184 ;;; the value away.
185 ;;;
186 (defmacro define-functions (values)
187 (let ((do-call (intern (format nil "~:@(do-~D-value-call~)" values)))
188 (return-values (intern (format nil "~:@(return-~D-value~:P~)" values)))
189 (vars nil))
190 (dotimes (i values)
191 (push (gensym) vars))
192 (setf vars (nreverse vars))
193 `(progn
194 (defun ,do-call (result)
195 (let (worked ,@vars)
196 (unwind-protect
197 (progn
198 (multiple-value-setq ,vars
199 (wire-get-object *current-wire*))
200 (setf worked t))
201 (if worked
202 (remote *current-wire*
203 (,return-values result ,@vars))
204 (remote *current-wire*
205 (remote-return-abort result)))
206 (wire-force-output *current-wire*))))
207 (defun ,return-values (remote ,@vars)
208 (let ((result (remote-object-value remote)))
209 (unless (maybe-nuke-remote-wait result)
210 ,@(let ((setf-forms nil))
211 (dotimes (i values)
212 (push `(setf (,(intern (format nil
213 "~:@(remote-wait-value~D~)"
214 (1+ i)))
215 result)
216 ,(nth i vars))
217 setf-forms))
218 (nreverse setf-forms))))
219 nil))))
220
221 (define-functions 1)
222 (define-functions 2)
223 (define-functions 3)
224 (define-functions 4)
225 (define-functions 5)
226
227
228 ;;; DO-N-VALUE-CALL -- internal
229 ;;;
230 ;;; For more values then 5, all the values are rolled into a list and passed
231 ;;; back as the first value, so we use RETURN-1-VALUE to return it.
232 ;;;
233 (defun do-n-value-call (result)
234 (let (worked values)
235 (unwind-protect
236 (progn
237 (setf values
238 (multiple-value-list (wire-get-object *current-wire*)))
239 (setf worked t))
240 (if worked
241 (remote *current-wire*
242 (return-1-value result values))
243 (remote *current-wire*
244 (remote-return-abort result)))
245 (wire-force-output *current-wire*))))
246
247 ;;; REMOTE-RETURN-ABORT -- internal
248 ;;;
249 ;;; The remote call aborted instead of returned.
250 ;;;
251 (defun remote-return-abort (result)
252 (setf result (remote-object-value result))
253 (unless (maybe-nuke-remote-wait result)
254 (setf (remote-wait-abort result) t)))
255
256 ;;; SERVE-REQUESTS -- internal
257 ;;;
258 ;;; Serve all pending requests on the given wire.
259 ;;;
260 (defun serve-requests (wire on-death)
261 (handler-bind
262 ((wire-eof #'(lambda (condition)
263 (declare (ignore condition))
264 (system:invalidate-descriptor (wire-fd wire))
265 (unix:unix-close (wire-fd wire))
266 (dolist (pending *pending-returns*)
267 (when (eq (car pending)
268 wire)
269 (unless (maybe-nuke-remote-wait (cdr pending))
270 (setf (remote-wait-abort (cdr pending))
271 t))))
272 (when on-death
273 (funcall on-death))
274 (return-from serve-requests (values))))
275 (wire-error #'(lambda (condition)
276 (declare (ignore condition))
277 (system:invalidate-descriptor (wire-fd wire)))))
278 (loop
279 (unless (wire-listen wire)
280 (return))
281 (wire-get-object wire)))
282 (values))
283
284 ;;; NEW-CONNECTION -- internal
285 ;;;
286 ;;; Maybe build a new wire and add it to the servers list of fds. If the user
287 ;;; Supplied a function, close the socket if it returns NIL. Otherwise, install
288 ;;; the wire.
289 ;;;
290 (defun new-connection (socket addr on-connect)
291 (let ((wire (make-wire socket))
292 (on-death nil))
293 (if (or (null on-connect)
294 (multiple-value-bind (okay death-fn)
295 (funcall on-connect wire addr)
296 (setf on-death death-fn)
297 okay))
298 (system:add-fd-handler socket :input
299 #'(lambda (socket)
300 (declare (ignore socket))
301 (serve-requests wire on-death)))
302 (ext:close-socket socket))))
303
304 ;;; REQUEST-SERVER structure
305 ;;;
306 ;;; Just a simple handle on the socket and system:serve-event handler that make
307 ;;; up a request server.
308 ;;;
309 (defstruct (request-server
310 (:print-function %print-request-server))
311 socket
312 handler)
313
314 (defun %print-request-server (rs stream depth)
315 (declare (ignore depth))
316 (print-unreadable-object (rs stream :type t)
317 (format stream "for ~D" (request-server-socket rs))))
318
319 ;;; CREATE-REQUEST-SERVER -- Public.
320 ;;;
321 ;;; Create a TCP/IP listener on the given port. If anyone tries to connect to
322 ;;; it, call NEW-CONNECTION to do the connecting.
323 ;;;
324 (defun create-request-server (port &optional on-connect)
325 "Create a request server on the given port. Whenever anyone connects to it,
326 call the given function with the newly created wire and the address of the
327 connector. If the function returns NIL, the connection is destroyed;
328 otherwise, it is accepted. This returns a manifestation of the server that
329 DESTROY-REQUEST-SERVER accepts to kill the request server."
330 (let* ((socket (ext:create-inet-listener port))
331 (handler (system:add-fd-handler socket :input
332 #'(lambda (socket)
333 (multiple-value-bind
334 (newconn addr)
335 (ext:accept-tcp-connection socket)
336 (new-connection newconn addr on-connect))))))
337 (make-request-server :socket socket
338 :handler handler)))
339
340 ;;; DESTROY-REQUEST-SERVER -- Public.
341 ;;;
342 ;;; Removes the request server from SERVER's list of file descriptors and
343 ;;; closes the socket behind it.
344 ;;;
345 (defun destroy-request-server (server)
346 "Quit accepting connections to the given request server."
347 (system:remove-fd-handler (request-server-handler server))
348 (ext:close-socket (request-server-socket server))
349 nil)
350
351 ;;; CONNECT-TO-REMOTE-SERVER -- Public.
352 ;;;
353 ;;; Just like the doc string says, connect to a remote server. A handler is
354 ;;; installed to handle return values, etc.
355 ;;;
356 (defun connect-to-remote-server (hostname port &optional on-death)
357 "Connect to a remote request server addressed with the given host and port
358 pair. This returns the created wire."
359 (let* ((socket (ext:connect-to-inet-socket hostname port))
360 (wire (make-wire socket)))
361 (system:add-fd-handler socket :input
362 #'(lambda (socket)
363 (declare (ignore socket))
364 (serve-requests wire on-death)))
365 wire))

  ViewVC Help
Powered by ViewVC 1.1.5