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

Contents of /src/code/remote.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Sat Feb 15 12:50:14 1992 UTC (22 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.2: +2 -2 lines
Changed ``mach:unix-close'' to ``unix:unix-close''.
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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 wlott 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/remote.lisp,v 1.3 1992/02/15 12:50:14 wlott Exp $")
11 ram 1.2 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; This file implements a simple remote procedure call mechanism on top
15     ;;; of wire.lisp.
16     ;;;
17     ;;; Written by William Lott.
18     ;;;
19    
20     (in-package "WIRE")
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 remotly. Subforms are executed locally in the lexical
53     ;;; envionment 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 remotly). 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 "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-values 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 wlott 1.3 (unix:unix-close (wire-fd wire))
268 ram 1.1 (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     (format stream "#<Requst server for ~D>" (request-server-socket rs)))
319    
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)
327     "Create a request server on the given port. Whenevery 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))
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