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

Contents of /src/code/remote.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9.50.1 - (hide annotations)
Thu Feb 25 20:34:51 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.9: +10 -9 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

works (once the piglatin translation is added).
1 ram 1.1 ;;; -*- Log: code.log; Package: wire -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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 rtoy 1.9.50.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/remote.lisp,v 1.9.50.1 2010/02/25 20:34:51 rtoy Exp $")
9 ram 1.2 ;;;
10 ram 1.1 ;;; **********************************************************************
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 rtoy 1.9.50.1 (intl:textdomain "cmucl")
20 ram 1.1
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 rtoy 1.9.50.1 _N"AList of wire . remote-wait structs")
32 ram 1.1
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 toy 1.8 ;;; Execute the body remotely. Subforms are executed locally in the lexical
52     ;;; environment of the macro call. No values are returned.
53 ram 1.1 ;;;
54     (defmacro remote (wire-form &body forms)
55 rtoy 1.9.50.1 _N"Evaluates the given forms remotly. No values are returned, as the remote
56 ram 1.1 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 rtoy 1.9.50.1 _N"Bind VARS to the multiple values of FORM (which is executed remotely). The
76 toy 1.8 forms in BODY are only executed if the remote function returned (as apposed
77     to aborting due to a throw)."
78 ram 1.1 (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 rtoy 1.9.50.1 `(error _"Remote server unwound")))
146     _N"Execute the single form remotly. The value of the form is returned.
147 ram 1.1 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 toy 1.7 (return-1-value result values))
244 ram 1.1 (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 wlott 1.3 (unix:unix-close (wire-fd wire))
267 ram 1.1 (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 wlott 1.4 (print-unreadable-object (rs stream :type t)
318     (format stream "for ~D" (request-server-socket rs))))
319 ram 1.1
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 emarsden 1.9 (defun create-request-server (port &optional on-connect &key reuse-address)
326 rtoy 1.9.50.1 _N"Create a request server on the given port. Whenever anyone connects to it,
327 ram 1.1 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 emarsden 1.9 (let* ((socket (ext:create-inet-listener port :stream
332     :reuse-address reuse-address))
333 ram 1.1 (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 rtoy 1.9.50.1 _N"Quit accepting connections to the given request server."
349 ram 1.1 (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 rtoy 1.9.50.1 _N"Connect to a remote request server addressed with the given host and port
360 ram 1.1 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