diff --git a/code/remote.lisp b/code/remote.lisp new file mode 100644 index 0000000000000000000000000000000000000000..fe1cb60608e2952381b3715c95a2bc3ca71cc01a --- /dev/null +++ b/code/remote.lisp @@ -0,0 +1,363 @@ +;;; -*- Log: code.log; Package: wire -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file implements a simple remote procedure call mechanism on top +;;; of wire.lisp. +;;; +;;; Written by William Lott. +;;; + +(in-package "WIRE") + +(export '(remote remote-value remote-value-bind create-request-server + destroy-request-server connect-to-remote-server)) + + +(defstruct remote-wait + value1 value2 value3 value4 value5 + abort + finished) + +(defvar *pending-returns* nil + "AList of wire . remote-wait structs") + + +;;; MAYBE-NUKE-REMOTE-WAIT -- internal +;;; +;;; If the remote wait has finished, remove the external translation. +;;; Otherwise, mark the remote wait as finished so the next call to +;;; MAYBE-NUKE-REMOTE-WAIT will really nuke it. +;;; +(defun maybe-nuke-remote-wait (remote) + (cond ((remote-wait-finished remote) + (forget-remote-translation remote) + t) + (t + (setf (remote-wait-finished remote) + t) + nil))) + +;;; REMOTE -- public +;;; +;;; Execute the body remotly. Subforms are executed locally in the lexical +;;; envionment of the macro call. No values are returned. +;;; +(defmacro remote (wire-form &body forms) + "Evaluates the given forms remotly. No values are returned, as the remote +evaluation is asyncronus." + (let ((wire (gensym))) + `(let ((,wire ,wire-form)) + ,@(mapcar #'(lambda (form) + `(wire-output-funcall ,wire + ',(car form) + ,@(cdr form))) + forms) + (values)))) + +;;; REMOTE-VALUE-BIND -- public +;;; +;;; Send to remote forms. First, a call to the correct dispatch routine based +;;; on the number of args, then the actual call. The dispatch routine will get +;;; the second funcall and fill in the correct number of arguments. +;;; Note: if there are no arguments, we don't even wait for the function to +;;; return, cause we can kind of guess at what the currect results would be. +;;; +(defmacro remote-value-bind (wire-form vars form &rest body) + "Bind vars to the multiple values of form (which is executed remotly). The +forms in body are only executed if the remote function returned as apposed +to aborting due to a throw." + (cond + ((null vars) + `(progn + (remote ,wire-form ,form) + ,@body)) + (t + (let ((remote (gensym)) + (wire (gensym))) + `(let* ((,remote (make-remote-wait)) + (,wire ,wire-form) + (*pending-returns* (cons (cons ,wire ,remote) + *pending-returns*))) + (unwind-protect + (let ,vars + (remote ,wire + (,(case (length vars) + (1 'do-1-value-call) + (2 'do-2-value-call) + (3 'do-3-value-call) + (4 'do-4-value-call) + (5 'do-5-value-call) + (t 'do-n-value-call)) + (make-remote-object ,remote)) + ,form) + (wire-force-output ,wire) + (loop + (system:serve-all-events) + (when (remote-wait-finished ,remote) + (return))) + (unless (remote-wait-abort ,remote) + ,(case (length vars) + (1 `(setf ,(first vars) (remote-wait-value1 ,remote))) + (2 `(setf ,(first vars) (remote-wait-value1 ,remote) + ,(second vars) (remote-wait-value2 ,remote))) + (3 `(setf ,(first vars) (remote-wait-value1 ,remote) + ,(second vars) (remote-wait-value2 ,remote) + ,(third vars) (remote-wait-value3 ,remote))) + (4 `(setf ,(first vars) (remote-wait-value1 ,remote) + ,(second vars) (remote-wait-value2 ,remote) + ,(third vars) (remote-wait-value3 ,remote) + ,(fourth vars) (remote-wait-value4 ,remote))) + (5 `(setf ,(first vars) (remote-wait-value1 ,remote) + ,(second vars) (remote-wait-value2 ,remote) + ,(third vars) (remote-wait-value3 ,remote) + ,(fourth vars) (remote-wait-value4 ,remote) + ,(fifth vars) (remote-wait-value5 ,remote))) + (t + (do ((remaining-vars vars (cdr remaining-vars)) + (form (list 'setf) + (nconc form + (list (car remaining-vars) + `(pop values))))) + ((null remaining-vars) + `(let ((values (remote-wait-value1 ,remote))) + ,form))))) + ,@body)) + (maybe-nuke-remote-wait ,remote))))))) + + +;;; REMOTE-VALUE -- public +;;; +;;; Alternate interface to getting the single return value of a remote +;;; function. Works pretty much just the same, except the single value is +;;; returned. +;;; +(defmacro remote-value (wire-form form &optional + (on-server-unwind + `(error "Remote server unwound"))) + "Execute the single form remotly. The value of the form is returned. + The optional form on-server-unwind is only evaluated if the server unwinds + instead of returning." + (let ((remote (gensym)) + (wire (gensym))) + `(let* ((,remote (make-remote-wait)) + (,wire ,wire-form) + (*pending-returns* (cons (cons ,wire ,remote) + *pending-returns*))) + (unwind-protect + (progn + (remote ,wire + (do-1-value-call (make-remote-object ,remote)) + ,form) + (wire-force-output ,wire) + (loop + (system:serve-all-events) + (when (remote-wait-finished ,remote) + (return)))) + (maybe-nuke-remote-wait ,remote)) + (if (remote-wait-abort ,remote) + ,on-server-unwind + (remote-wait-value1 ,remote))))) + +;;; DEFINE-FUNCTIONS -- internal +;;; +;;; Defines two functions, one that the client runs in the server, and one +;;; that the server runs in the client: +;;; +;;; DO-n-VALUE-CALL -- internal +;;; +;;; Executed by the remote process. Reads the next object off the wire and +;;; sends the value back. Unwind-protect is used to make sure we send something +;;; back so the requestor doesn't hang. +;;; +;;; RETURN-n-VALUE -- internal +;;; +;;; The remote procedure returned the given value, so fill it in the +;;; remote-wait structure. Note, if the requestor has aborted, just throw +;;; the value away. +;;; +(defmacro define-functions (values) + (let ((do-call (intern (format nil "~:@(do-~D-value-call~)" values))) + (return-values (intern (format nil "~:@(return-~D-value~:P~)" values))) + (vars nil)) + (dotimes (i values) + (push (gensym) vars)) + (setf vars (nreverse vars)) + `(progn + (defun ,do-call (result) + (let (worked ,@vars) + (unwind-protect + (progn + (multiple-value-setq ,vars + (wire-get-object *current-wire*)) + (setf worked t)) + (if worked + (remote *current-wire* + (,return-values result ,@vars)) + (remote *current-wire* + (remote-return-abort result))) + (wire-force-output *current-wire*)))) + (defun ,return-values (remote ,@vars) + (let ((result (remote-object-value remote))) + (unless (maybe-nuke-remote-wait result) + ,@(let ((setf-forms nil)) + (dotimes (i values) + (push `(setf (,(intern (format nil + "~:@(remote-wait-value~D~)" + (1+ i))) + result) + ,(nth i vars)) + setf-forms)) + (nreverse setf-forms)))) + nil)))) + +(define-functions 1) +(define-functions 2) +(define-functions 3) +(define-functions 4) +(define-functions 5) + + +;;; DO-N-VALUE-CALL -- internal +;;; +;;; For more values then 5, all the values are rolled into a list and passed +;;; back as the first value, so we use RETURN-1-VALUE to return it. +;;; +(defun do-n-value-call (result) + (let (worked values) + (unwind-protect + (progn + (setf values + (multiple-value-list (wire-get-object *current-wire*))) + (setf worked t)) + (if worked + (remote *current-wire* + (return-1-values result values)) + (remote *current-wire* + (remote-return-abort result))) + (wire-force-output *current-wire*)))) + +;;; REMOTE-RETURN-ABORT -- internal +;;; +;;; The remote call aborted instead of returned. +;;; +(defun remote-return-abort (result) + (setf result (remote-object-value result)) + (unless (maybe-nuke-remote-wait result) + (setf (remote-wait-abort result) t))) + +;;; SERVE-REQUESTS -- internal +;;; +;;; Serve all pending requests on the given wire. +;;; +(defun serve-requests (wire on-death) + (handler-bind + ((wire-eof #'(lambda (condition) + (declare (ignore condition)) + (system:invalidate-descriptor (wire-fd wire)) + (mach:unix-close (wire-fd wire)) + (dolist (pending *pending-returns*) + (when (eq (car pending) + wire) + (unless (maybe-nuke-remote-wait (cdr pending)) + (setf (remote-wait-abort (cdr pending)) + t)))) + (when on-death + (funcall on-death)) + (return-from serve-requests (values)))) + (wire-error #'(lambda (condition) + (declare (ignore condition)) + (system:invalidate-descriptor (wire-fd wire))))) + (loop + (unless (wire-listen wire) + (return)) + (wire-get-object wire))) + (values)) + +;;; NEW-CONNECTION -- internal +;;; +;;; Maybe build a new wire and add it to the servers list of fds. If the user +;;; Supplied a function, close the socket if it returns NIL. Otherwise, install +;;; the wire. +;;; +(defun new-connection (socket addr on-connect) + (let ((wire (make-wire socket)) + (on-death nil)) + (if (or (null on-connect) + (multiple-value-bind (okay death-fn) + (funcall on-connect wire addr) + (setf on-death death-fn) + okay)) + (system:add-fd-handler socket :input + #'(lambda (socket) + (declare (ignore socket)) + (serve-requests wire on-death))) + (ext:close-socket socket)))) + +;;; REQUEST-SERVER structure +;;; +;;; Just a simple handle on the socket and system:serve-event handler that make +;;; up a request server. +;;; +(defstruct (request-server + (:print-function %print-request-server)) + socket + handler) + +(defun %print-request-server (rs stream depth) + (declare (ignore depth)) + (format stream "#<Requst server for ~D>" (request-server-socket rs))) + + +;;; CREATE-REQUEST-SERVER -- Public. +;;; +;;; Create a TCP/IP listener on the given port. If anyone tries to connect to +;;; it, call NEW-CONNECTION to do the connecting. +;;; +(defun create-request-server (port &optional on-connect) + "Create a request server on the given port. Whenevery anyone connects to it + call the given function with the newly created wire and the address of the + connector. If the function returns NIL, the connection is destroyed; + otherwise, it is accepted. This returns a manifestation of the server that + DESTROY-REQUEST-SERVER accepts to kill the request server." + (let* ((socket (ext:create-inet-listener port)) + (handler (system:add-fd-handler socket :input + #'(lambda (socket) + (multiple-value-bind + (newconn addr) + (ext:accept-tcp-connection socket) + (new-connection newconn addr on-connect)))))) + (make-request-server :socket socket + :handler handler))) + +;;; DESTROY-REQUEST-SERVER -- Public. +;;; +;;; Removes the request server from SERVER's list of file descriptors and +;;; closes the socket behind it. +;;; +(defun destroy-request-server (server) + "Quit accepting connections to the given request server." + (system:remove-fd-handler (request-server-handler server)) + (ext:close-socket (request-server-socket server)) + nil) + +;;; CONNECT-TO-REMOTE-SERVER -- Public. +;;; +;;; Just like the doc string says, connect to a remote server. A handler is +;;; installed to handle return values, etc. +;;; +(defun connect-to-remote-server (hostname port &optional on-death) + "Connect to a remote request server addressed with the given host and port + pair. This returns the created wire." + (let* ((socket (ext:connect-to-inet-socket hostname port)) + (wire (make-wire socket))) + (system:add-fd-handler socket :input + #'(lambda (socket) + (declare (ignore socket)) + (serve-requests wire on-death))) + wire))