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

Contents of /src/code/remote.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5