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

Contents of /src/code/remote.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5