Contract process state, and merge spawn/monitor into spawn.
This commit is contained in:
parent
83cae7075e
commit
1ffd0afe66
32
TODO
32
TODO
|
@ -1,30 +1,14 @@
|
||||||
## os.rkt and friends
|
- move from quasiquoted lists to prefab structs
|
||||||
|
- enforce user-mode restrictions? (Is this still relevant?)
|
||||||
- move from quasiquoted to prefab structs
|
|
||||||
- define a prefab struct for every evt? that we want to use
|
|
||||||
- define lowest-level drivers for each prefab struct
|
|
||||||
|
|
||||||
It feels like those lowest-level drivers are listening for *demand*
|
|
||||||
i.e. they're listening for presence and are then acting to supply such
|
|
||||||
demand. Think about the relationships between presence (both positive
|
|
||||||
and negative), and interfacing to ad-hoc sources and sinks.
|
|
||||||
|
|
||||||
### Old, possibly-still-relevant TODOs from os.rkt
|
|
||||||
|
|
||||||
- is timeout really primitive? If so, isn't presence primitive?
|
|
||||||
- what about metatimeout?
|
|
||||||
- enforce user-mode restrictions
|
|
||||||
|
|
||||||
### Abstract out UDP socket creation
|
|
||||||
|
|
||||||
### Things to consider doing to os-big-bang.rkt
|
|
||||||
|
|
||||||
- add contracts on structs used as message types e.g. to catch such
|
- add contracts on structs used as message types e.g. to catch such
|
||||||
as #(192 203 230 10) being used instead of (udp-address
|
as #(192 203 230 10) being used instead of (udp-address
|
||||||
"192.203.230.10" 53).
|
"192.203.230.10" 53).
|
||||||
|
|
||||||
- some kind of join-ish construct to make e.g. cname-expansion
|
- some kind of join-ish construct to make e.g. cname-expansion
|
||||||
prettier
|
prettier
|
||||||
|
|
||||||
- have a "terminate" kind of transition for unspawning the
|
os2:
|
||||||
transitioning process
|
|
||||||
|
- remove the "convenience" form of transitions. This will permit
|
||||||
|
unambiguous use of such horrors as the state of a process *being* a
|
||||||
|
transition, and will also remove ambiguity from spawn in cases
|
||||||
|
where the initial state of a process is to be a function.
|
||||||
|
|
153
os2.rkt
153
os2.rkt
|
@ -3,6 +3,7 @@
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
(require racket/contract)
|
||||||
(require (only-in racket/list flatten))
|
(require (only-in racket/list flatten))
|
||||||
(require "unify.rkt")
|
(require "unify.rkt")
|
||||||
|
|
||||||
|
@ -16,6 +17,8 @@
|
||||||
co-topics
|
co-topics
|
||||||
topic-union
|
topic-union
|
||||||
|
|
||||||
|
(struct-out boot-specification)
|
||||||
|
|
||||||
(struct-out handlers)
|
(struct-out handlers)
|
||||||
|
|
||||||
(except-out (struct-out transition) transition)
|
(except-out (struct-out transition) transition)
|
||||||
|
@ -56,7 +59,6 @@
|
||||||
(rename-out [at-meta-level <at-meta-level>])
|
(rename-out [at-meta-level <at-meta-level>])
|
||||||
|
|
||||||
(struct-out monitor)
|
(struct-out monitor)
|
||||||
spawn/monitor
|
|
||||||
|
|
||||||
;; Reexports from unify.rkt for convenience
|
;; Reexports from unify.rkt for convenience
|
||||||
wild
|
wild
|
||||||
|
@ -116,16 +118,28 @@
|
||||||
;; topic) in a conversation.
|
;; topic) in a conversation.
|
||||||
(struct endpoint (id topics handlers) #:transparent)
|
(struct endpoint (id topics handlers) #:transparent)
|
||||||
|
|
||||||
;; A Process is an Exists State . (process Any PID State Set<EID>
|
;; A Process is an Exists State . (process Any PID State Contract
|
||||||
;; Set<EID>), representing a VM process and its collection of active
|
;; ContractParty Set<EID> Set<EID>), representing a VM process and its
|
||||||
;; endpoints at this level and at the VM's container's level.
|
;; collection of active endpoints at this level and at the VM's
|
||||||
(struct process (name id state endpoints meta-endpoints) #:transparent)
|
;; container's level. The (responsible-party) is the party that
|
||||||
|
;; generated the (state).
|
||||||
|
(struct process (name ;; Any
|
||||||
|
id ;; PID
|
||||||
|
state ;; State
|
||||||
|
state-contract ;; Contract
|
||||||
|
responsible-party ;; ContractParty
|
||||||
|
endpoints ;; Set<EID>
|
||||||
|
meta-endpoints ;; Set<EID>
|
||||||
|
) #:transparent)
|
||||||
|
|
||||||
;; A Topic is a (topic Role Pattern Boolean), describing an Endpoint's
|
;; A Topic is a (topic Role Pattern Boolean), describing an Endpoint's
|
||||||
;; role in a conversation.
|
;; role in a conversation.
|
||||||
(struct topic (role pattern virtual?) #:prefab)
|
(struct topic (role pattern virtual?) #:prefab)
|
||||||
|
|
||||||
;; BootK = either (PID -> Transition) or Transition
|
;; BootSpecification = BootK or (boot-specification BootK Contract)
|
||||||
|
(struct boot-specification (proc contract) #:transparent)
|
||||||
|
|
||||||
|
;; BootK = (PID -> Transition) or Transition
|
||||||
;; InterruptK = State -> Transition
|
;; InterruptK = State -> Transition
|
||||||
;; TrapK<X> = X -> InterruptK
|
;; TrapK<X> = X -> InterruptK
|
||||||
|
|
||||||
|
@ -134,6 +148,8 @@
|
||||||
;; Maybe<TrapK<Topic * Message>>)
|
;; Maybe<TrapK<Topic * Message>>)
|
||||||
(struct handlers (presence absence message) #:transparent)
|
(struct handlers (presence absence message) #:transparent)
|
||||||
|
|
||||||
|
;; Transition = State or (transition State ConsTreeOf<Action>)
|
||||||
|
;;
|
||||||
;; actions is a plain old ordered ConsTreeOf<Action>, not a
|
;; actions is a plain old ordered ConsTreeOf<Action>, not a
|
||||||
;; QuasiQueue.
|
;; QuasiQueue.
|
||||||
(struct transition (state actions) #:transparent)
|
(struct transition (state actions) #:transparent)
|
||||||
|
@ -150,8 +166,8 @@
|
||||||
;; (send-message Any Role)
|
;; (send-message Any Role)
|
||||||
(struct send-message (body role) #:prefab)
|
(struct send-message (body role) #:prefab)
|
||||||
;;
|
;;
|
||||||
;; (spawn BootK Maybe<TrapK<PID>> Any)
|
;; (spawn BootSpecification Maybe<TrapK<PID>> Any)
|
||||||
(struct spawn (main k debug-name) #:prefab)
|
(struct spawn (spec k debug-name) #:prefab)
|
||||||
;;
|
;;
|
||||||
;; (kill Maybe<PID> Any)
|
;; (kill Maybe<PID> Any)
|
||||||
(struct kill (pid reason) #:prefab)
|
(struct kill (pid reason) #:prefab)
|
||||||
|
@ -161,6 +177,15 @@
|
||||||
(struct yield (k) #:prefab)
|
(struct yield (k) #:prefab)
|
||||||
(struct at-meta-level (preaction) #:prefab)
|
(struct at-meta-level (preaction) #:prefab)
|
||||||
|
|
||||||
|
;; A Monitor instance describes the presence of a whole process, as a
|
||||||
|
;; convention.
|
||||||
|
;;
|
||||||
|
;; TODO: revisit the idea of points-of-attachment. There's an
|
||||||
|
;; intermediate network between the processes and the kernel, and
|
||||||
|
;; pid-level presence could be seen as object-level presence on that
|
||||||
|
;; network somehow.
|
||||||
|
(struct monitor (pid debug-name) #:prefab)
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
;; role & yield macros
|
;; role & yield macros
|
||||||
|
|
||||||
|
@ -211,9 +236,28 @@
|
||||||
(define make-add-role add-role) ;; no special treatment required at present
|
(define make-add-role add-role) ;; no special treatment required at present
|
||||||
(define (make-delete-role pre-eid [reason #f]) (delete-role pre-eid reason))
|
(define (make-delete-role pre-eid [reason #f]) (delete-role pre-eid reason))
|
||||||
(define (make-send-message body [role 'publisher]) (send-message body role))
|
(define (make-send-message body [role 'publisher]) (send-message body role))
|
||||||
(define (make-spawn main [k #f] #:debug-name [debug-name #f]) (spawn main k debug-name))
|
|
||||||
(define (make-kill [pid #f] #:reason [reason #f]) (kill pid reason))
|
(define (make-kill [pid #f] #:reason [reason #f]) (kill pid reason))
|
||||||
|
|
||||||
|
(define (make-spawn main [k #f]
|
||||||
|
#:monitor? [monitor? #f]
|
||||||
|
#:debug-name [debug-name #f]
|
||||||
|
#:state-contract [state-contract any/c])
|
||||||
|
(define maybe-monitored-main
|
||||||
|
(if monitor?
|
||||||
|
(let ((unmonitored-main (if (procedure? main) main (lambda (self-pid) main))))
|
||||||
|
(lambda (self-pid)
|
||||||
|
(define m (monitor self-pid debug-name))
|
||||||
|
(prefix-transition (unmonitored-main self-pid)
|
||||||
|
(role (list 'canary m) (topic-publisher m) #:state state))))
|
||||||
|
main))
|
||||||
|
(define spec
|
||||||
|
(if (eq? state-contract any/c)
|
||||||
|
main
|
||||||
|
(if (boot-specification? main)
|
||||||
|
(error 'spawn "Cannot apply #:state-contract to already-contracted boot-specification")
|
||||||
|
(boot-specification main state-contract))))
|
||||||
|
(spawn spec k debug-name))
|
||||||
|
|
||||||
(define (extend-transition t . more-actions)
|
(define (extend-transition t . more-actions)
|
||||||
(match t
|
(match t
|
||||||
[(transition state actions) (transition state (list actions more-actions))]
|
[(transition state actions) (transition state (list actions more-actions))]
|
||||||
|
@ -283,24 +327,6 @@
|
||||||
(or (topic-virtual? local-topic)
|
(or (topic-virtual? local-topic)
|
||||||
(not (topic-virtual? remote-topic))))
|
(not (topic-virtual? remote-topic))))
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
|
||||||
;; Monitoring.
|
|
||||||
|
|
||||||
(struct monitor (pid debug-name) #:prefab)
|
|
||||||
|
|
||||||
(define (spawn/monitor main [k #f] #:debug-name [debug-name #f])
|
|
||||||
;; TODO: revisit the idea of points-of-attachment. There's an
|
|
||||||
;; intermediate network between the processes and the kernel, and
|
|
||||||
;; pid-level presence could be seen as object-level presence on that
|
|
||||||
;; network somehow.
|
|
||||||
(define ((monitor-transition main-fn) self-pid)
|
|
||||||
(define m (monitor self-pid debug-name))
|
|
||||||
(prefix-transition (main-fn self-pid)
|
|
||||||
(role (list 'canary m) (topic-publisher m) #:state state)))
|
|
||||||
(make-spawn (monitor-transition (if (procedure? main) main (lambda (self-pid) main)))
|
|
||||||
k
|
|
||||||
#:debug-name debug-name))
|
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
;; Core virtualizable virtual machine.
|
;; Core virtualizable virtual machine.
|
||||||
|
|
||||||
|
@ -329,7 +355,7 @@
|
||||||
[(yield k)
|
[(yield k)
|
||||||
(loop rest
|
(loop rest
|
||||||
(if (hash-has-key? (vm-processes state) pid)
|
(if (hash-has-key? (vm-processes state) pid)
|
||||||
(run-ready state pid k)
|
(run-ready state pid 'yield k)
|
||||||
state)
|
state)
|
||||||
outbound-actions)]
|
outbound-actions)]
|
||||||
[preaction
|
[preaction
|
||||||
|
@ -378,8 +404,8 @@
|
||||||
(values '() (do-unsubscribe pid pre-eid reason state))]
|
(values '() (do-unsubscribe pid pre-eid reason state))]
|
||||||
[(send-message body role)
|
[(send-message body role)
|
||||||
(values '() (route-and-deliver role body state))]
|
(values '() (route-and-deliver role body state))]
|
||||||
[(spawn main k debug-name)
|
[(spawn spec k debug-name)
|
||||||
(values '() (do-spawn pid main k debug-name state))]
|
(values '() (do-spawn pid spec k debug-name state))]
|
||||||
[(kill pid-to-kill reason)
|
[(kill pid-to-kill reason)
|
||||||
(do-kill (or pid-to-kill pid) reason state)]))
|
(do-kill (or pid-to-kill pid) reason state)]))
|
||||||
|
|
||||||
|
@ -452,10 +478,10 @@
|
||||||
(define outbound-flow (refine-topic topic flow-pattern))
|
(define outbound-flow (refine-topic topic flow-pattern))
|
||||||
(define e-presence-handler (handlers-presence (endpoint-handlers e)))
|
(define e-presence-handler (handlers-presence (endpoint-handlers e)))
|
||||||
(let* ((state (if (flow-visible? topic inbound-flow)
|
(let* ((state (if (flow-visible? topic inbound-flow)
|
||||||
(run-trapk state pid presence-handler inbound-flow)
|
(run-trapk state pid eid presence-handler inbound-flow)
|
||||||
state))
|
state))
|
||||||
(state (if (flow-visible? matching-topic outbound-flow)
|
(state (if (flow-visible? matching-topic outbound-flow)
|
||||||
(run-trapk state matching-pid e-presence-handler outbound-flow)
|
(run-trapk state matching-pid matching-eid e-presence-handler outbound-flow)
|
||||||
state)))
|
state)))
|
||||||
state)))
|
state)))
|
||||||
|
|
||||||
|
@ -483,7 +509,7 @@
|
||||||
#:when flow-pattern)
|
#:when flow-pattern)
|
||||||
(define outbound-flow (refine-topic removed-topic flow-pattern))
|
(define outbound-flow (refine-topic removed-topic flow-pattern))
|
||||||
(define absence-handler (handlers-absence (endpoint-handlers e)))
|
(define absence-handler (handlers-absence (endpoint-handlers e)))
|
||||||
(run-trapk state matching-pid absence-handler outbound-flow reason)))
|
(run-trapk state matching-pid matching-eid absence-handler outbound-flow reason)))
|
||||||
|
|
||||||
(define (route-and-deliver role body state)
|
(define (route-and-deliver role body state)
|
||||||
(define message-topic (topic role body #f))
|
(define message-topic (topic role body #f))
|
||||||
|
@ -498,27 +524,37 @@
|
||||||
e))
|
e))
|
||||||
(for/fold ([state state]) ([e (in-set endpoints)])
|
(for/fold ([state state]) ([e (in-set endpoints)])
|
||||||
(match-define (endpoint (eid pid _) _ (handlers _ _ message-handler)) e)
|
(match-define (endpoint (eid pid _) _ (handlers _ _ message-handler)) e)
|
||||||
(run-trapk state pid message-handler message-topic body)))
|
(run-trapk state pid eid message-handler message-topic body)))
|
||||||
|
|
||||||
(define (maybe-transition->transition t)
|
(define (maybe-transition->transition t)
|
||||||
(cond [(transition? t) t]
|
(cond [(transition? t) t]
|
||||||
[else (transition t '())]))
|
[else (transition t '())]))
|
||||||
|
|
||||||
(define (do-spawn spawning-pid main k debug-name state)
|
(define (do-spawn spawning-pid spec k debug-name state)
|
||||||
(define new-pid (vm-next-process-id state))
|
(define new-pid (vm-next-process-id state))
|
||||||
(define new-name (or debug-name new-pid))
|
(define new-name (or debug-name new-pid))
|
||||||
|
(define-values (main state-contract)
|
||||||
|
(match spec
|
||||||
|
[(boot-specification main state-contract) (values main state-contract)]
|
||||||
|
[main (values main any/c)]))
|
||||||
(match-define (transition initial-state initial-actions)
|
(match-define (transition initial-state initial-actions)
|
||||||
(maybe-transition->transition
|
(maybe-transition->transition
|
||||||
(cond
|
(cond
|
||||||
[(procedure? main) (send-to-user (lambda (e) (transition #f (kill #f e))) main new-pid)]
|
[(procedure? main) (send-to-user (lambda (e) (transition #f (kill #f e))) main new-pid)]
|
||||||
[(transition? main) main])))
|
[else main])))
|
||||||
(define initial-process (process new-name new-pid initial-state (set) (set)))
|
(define initial-process (process new-name
|
||||||
|
new-pid
|
||||||
|
initial-state
|
||||||
|
state-contract
|
||||||
|
(list 'spawn 'main debug-name) ;; TODO: use contract-regions
|
||||||
|
(set)
|
||||||
|
(set)))
|
||||||
(define spawned-state
|
(define spawned-state
|
||||||
(struct-copy vm (enqueue-actions state new-pid initial-actions)
|
(struct-copy vm (enqueue-actions state new-pid initial-actions)
|
||||||
[processes (hash-set (vm-processes state) new-pid initial-process)]
|
[processes (hash-set (vm-processes state) new-pid initial-process)]
|
||||||
[next-process-id (+ new-pid 1)]))
|
[next-process-id (+ new-pid 1)]))
|
||||||
(log-info (format "~a PID ~v (~a) started" (vm-name state) new-pid new-name))
|
(log-info (format "~a PID ~v (~a) started" (vm-name state) new-pid new-name))
|
||||||
(run-trapk spawned-state spawning-pid k new-pid))
|
(run-trapk spawned-state spawning-pid (list 'spawn 'k debug-name) k new-pid))
|
||||||
|
|
||||||
(define (print-kill vm-name pid-to-kill process-name reason)
|
(define (print-kill vm-name pid-to-kill process-name reason)
|
||||||
(cond
|
(cond
|
||||||
|
@ -553,21 +589,30 @@
|
||||||
(struct-copy vm state [processes (hash-remove (vm-processes state) pid-to-kill)])))]
|
(struct-copy vm state [processes (hash-remove (vm-processes state) pid-to-kill)])))]
|
||||||
[else (values '() state)]))
|
[else (values '() state)]))
|
||||||
|
|
||||||
(define (run-trapk state pid trap-k . args)
|
(define (run-trapk state pid new-party trap-k . args)
|
||||||
(if trap-k
|
(if trap-k
|
||||||
(let ((failure-proc (lambda (e) (lambda (process-state)
|
(let ((failure-proc (lambda (e) (lambda (process-state)
|
||||||
(transition process-state (kill #f e))))))
|
(transition process-state (kill #f e))))))
|
||||||
(run-ready state pid (apply send-to-user failure-proc trap-k args)))
|
(run-ready state pid new-party (apply send-to-user failure-proc trap-k args)))
|
||||||
state))
|
state))
|
||||||
|
|
||||||
(define (run-ready state pid interrupt-k)
|
(define (run-ready state pid new-party interrupt-k)
|
||||||
(define old-state (process-state (hash-ref (vm-processes state) pid)))
|
(match-define (process _ _ old-state state-contract old-party _ _)
|
||||||
|
(hash-ref (vm-processes state) pid))
|
||||||
(match-define (transition new-state actions)
|
(match-define (transition new-state actions)
|
||||||
(maybe-transition->transition
|
(maybe-transition->transition
|
||||||
(send-to-user (lambda (e) (transition old-state (kill #f e))) interrupt-k old-state)))
|
(send-to-user (lambda (e) (transition old-state (kill #f e)))
|
||||||
|
(lambda () (interrupt-k (contract state-contract
|
||||||
|
old-state
|
||||||
|
old-party
|
||||||
|
new-party
|
||||||
|
(list (vm-name state) 'pid pid 'state)
|
||||||
|
#f))))))
|
||||||
(generic-update-process (enqueue-actions state pid actions)
|
(generic-update-process (enqueue-actions state pid actions)
|
||||||
pid
|
pid
|
||||||
(lambda (p) (struct-copy process p [state new-state]))))
|
(lambda (p) (struct-copy process p
|
||||||
|
[state new-state]
|
||||||
|
[responsible-party new-party]))))
|
||||||
|
|
||||||
(define (preaction? a)
|
(define (preaction? a)
|
||||||
(or (add-role? a)
|
(or (add-role? a)
|
||||||
|
@ -595,9 +640,9 @@
|
||||||
(struct-copy vm state
|
(struct-copy vm state
|
||||||
[pending-actions (append (reverse flat-actions) (vm-pending-actions state))]))
|
[pending-actions (append (reverse flat-actions) (vm-pending-actions state))]))
|
||||||
|
|
||||||
(define (((wrap-trapk pid trapk) . args) state)
|
(define (((wrap-trapk pid new-party trapk) . args) state)
|
||||||
(if (hash-has-key? (vm-processes state) pid)
|
(if (hash-has-key? (vm-processes state) pid)
|
||||||
(run-vm (apply run-trapk state pid trapk args))
|
(run-vm (apply run-trapk state pid new-party trapk args))
|
||||||
state))
|
state))
|
||||||
|
|
||||||
(define (transform-meta-action pid preaction state)
|
(define (transform-meta-action pid preaction state)
|
||||||
|
@ -606,9 +651,9 @@
|
||||||
(define new-eid (eid pid pre-eid))
|
(define new-eid (eid pid pre-eid))
|
||||||
(values (add-role new-eid
|
(values (add-role new-eid
|
||||||
topics
|
topics
|
||||||
(handlers (wrap-trapk pid (handlers-presence hs))
|
(handlers (wrap-trapk pid new-eid (handlers-presence hs))
|
||||||
(wrap-trapk pid (handlers-absence hs))
|
(wrap-trapk pid new-eid (handlers-absence hs))
|
||||||
(wrap-trapk pid (handlers-message hs))))
|
(wrap-trapk pid new-eid (handlers-message hs))))
|
||||||
(if (hash-has-key? (vm-processes state) pid)
|
(if (hash-has-key? (vm-processes state) pid)
|
||||||
(generic-update-process state pid (add-process-meta-eid new-eid))
|
(generic-update-process state pid (add-process-meta-eid new-eid))
|
||||||
state))]
|
state))]
|
||||||
|
@ -620,13 +665,17 @@
|
||||||
state))]
|
state))]
|
||||||
[(? send-message? p)
|
[(? send-message? p)
|
||||||
(values p state)]
|
(values p state)]
|
||||||
[(spawn main k debug-name)
|
[(spawn spec k debug-name)
|
||||||
(values (spawn main (wrap-trapk pid k) debug-name) state)]
|
(values (spawn spec
|
||||||
|
(wrap-trapk pid (list 'meta-spawn 'k debug-name) k)
|
||||||
|
debug-name)
|
||||||
|
state)]
|
||||||
[(? kill? p)
|
[(? kill? p)
|
||||||
(values p state)]))
|
(values p state)]))
|
||||||
|
|
||||||
(define (nested-vm name boot)
|
(define (nested-vm name boot)
|
||||||
(lambda (self-pid) (run-vm (make-vm name boot))))
|
(boot-specification (lambda (self-pid) (run-vm (make-vm name boot)))
|
||||||
|
vm?))
|
||||||
|
|
||||||
(define (ground-vm boot)
|
(define (ground-vm boot)
|
||||||
(let loop ((state (make-vm 'ground-vm boot)))
|
(let loop ((state (make-vm 'ground-vm boot)))
|
||||||
|
|
Loading…
Reference in New Issue