Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
1f98ea16
Commit
1f98ea16
authored
35 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
fa09c5d2
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/remote.lisp
+363
-0
363 additions, 0 deletions
code/remote.lisp
with
363 additions
and
0 deletions
code/remote.lisp
0 → 100644
+
363
−
0
View file @
1f98ea16
;;; -*- 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
))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment