From 1ffd0afe66cbf409fb27b315d7cd496fa522849c Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 23 Jun 2012 07:55:09 -0400 Subject: [PATCH] Contract process state, and merge spawn/monitor into spawn. --- TODO | 32 +++--------- os2.rkt | 153 +++++++++++++++++++++++++++++++++++++------------------- 2 files changed, 109 insertions(+), 76 deletions(-) diff --git a/TODO b/TODO index f37546a..2d5e705 100644 --- a/TODO +++ b/TODO @@ -1,30 +1,14 @@ -## os.rkt and friends - - - 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 - + - move from quasiquoted lists to prefab structs + - enforce user-mode restrictions? (Is this still relevant?) - add contracts on structs used as message types e.g. to catch such as #(192 203 230 10) being used instead of (udp-address "192.203.230.10" 53). - - some kind of join-ish construct to make e.g. cname-expansion prettier - - have a "terminate" kind of transition for unspawning the - transitioning process +os2: + + - 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. diff --git a/os2.rkt b/os2.rkt index bcdacbd..7fbb0cb 100644 --- a/os2.rkt +++ b/os2.rkt @@ -3,6 +3,7 @@ (require racket/set) (require racket/match) +(require racket/contract) (require (only-in racket/list flatten)) (require "unify.rkt") @@ -16,6 +17,8 @@ co-topics topic-union + (struct-out boot-specification) + (struct-out handlers) (except-out (struct-out transition) transition) @@ -56,7 +59,6 @@ (rename-out [at-meta-level ]) (struct-out monitor) - spawn/monitor ;; Reexports from unify.rkt for convenience wild @@ -116,16 +118,28 @@ ;; topic) in a conversation. (struct endpoint (id topics handlers) #:transparent) -;; A Process is an Exists State . (process Any PID State Set -;; Set), representing a VM process and its collection of active -;; endpoints at this level and at the VM's container's level. -(struct process (name id state endpoints meta-endpoints) #:transparent) +;; A Process is an Exists State . (process Any PID State Contract +;; ContractParty Set Set), representing a VM process and its +;; collection of active endpoints at this level and at the VM's +;; 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 + meta-endpoints ;; Set + ) #:transparent) ;; A Topic is a (topic Role Pattern Boolean), describing an Endpoint's ;; role in a conversation. (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 ;; TrapK = X -> InterruptK @@ -134,6 +148,8 @@ ;; Maybe>) (struct handlers (presence absence message) #:transparent) +;; Transition = State or (transition State ConsTreeOf) +;; ;; actions is a plain old ordered ConsTreeOf, not a ;; QuasiQueue. (struct transition (state actions) #:transparent) @@ -150,8 +166,8 @@ ;; (send-message Any Role) (struct send-message (body role) #:prefab) ;; -;; (spawn BootK Maybe> Any) -(struct spawn (main k debug-name) #:prefab) +;; (spawn BootSpecification Maybe> Any) +(struct spawn (spec k debug-name) #:prefab) ;; ;; (kill Maybe Any) (struct kill (pid reason) #:prefab) @@ -161,6 +177,15 @@ (struct yield (k) #: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 @@ -211,9 +236,28 @@ (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-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-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) (match t [(transition state actions) (transition state (list actions more-actions))] @@ -283,24 +327,6 @@ (or (topic-virtual? local-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. @@ -329,7 +355,7 @@ [(yield k) (loop rest (if (hash-has-key? (vm-processes state) pid) - (run-ready state pid k) + (run-ready state pid 'yield k) state) outbound-actions)] [preaction @@ -378,8 +404,8 @@ (values '() (do-unsubscribe pid pre-eid reason state))] [(send-message body role) (values '() (route-and-deliver role body state))] - [(spawn main k debug-name) - (values '() (do-spawn pid main k debug-name state))] + [(spawn spec k debug-name) + (values '() (do-spawn pid spec k debug-name state))] [(kill pid-to-kill reason) (do-kill (or pid-to-kill pid) reason state)])) @@ -452,10 +478,10 @@ (define outbound-flow (refine-topic topic flow-pattern)) (define e-presence-handler (handlers-presence (endpoint-handlers e))) (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 (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))) @@ -483,7 +509,7 @@ #:when flow-pattern) (define outbound-flow (refine-topic removed-topic flow-pattern)) (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 message-topic (topic role body #f)) @@ -498,27 +524,37 @@ e)) (for/fold ([state state]) ([e (in-set endpoints)]) (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) (cond [(transition? t) 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-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) (maybe-transition->transition (cond [(procedure? main) (send-to-user (lambda (e) (transition #f (kill #f e))) main new-pid)] - [(transition? main) main]))) - (define initial-process (process new-name new-pid initial-state (set) (set))) + [else main]))) + (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 (struct-copy vm (enqueue-actions state new-pid initial-actions) [processes (hash-set (vm-processes state) new-pid initial-process)] [next-process-id (+ new-pid 1)])) (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) (cond @@ -553,21 +589,30 @@ (struct-copy vm state [processes (hash-remove (vm-processes state) pid-to-kill)])))] [else (values '() state)])) -(define (run-trapk state pid trap-k . args) +(define (run-trapk state pid new-party trap-k . args) (if trap-k (let ((failure-proc (lambda (e) (lambda (process-state) (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)) -(define (run-ready state pid interrupt-k) - (define old-state (process-state (hash-ref (vm-processes state) pid))) +(define (run-ready state pid new-party interrupt-k) + (match-define (process _ _ old-state state-contract old-party _ _) + (hash-ref (vm-processes state) pid)) (match-define (transition new-state actions) (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) 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) (or (add-role? a) @@ -595,9 +640,9 @@ (struct-copy vm 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) - (run-vm (apply run-trapk state pid trapk args)) + (run-vm (apply run-trapk state pid new-party trapk args)) state)) (define (transform-meta-action pid preaction state) @@ -606,9 +651,9 @@ (define new-eid (eid pid pre-eid)) (values (add-role new-eid topics - (handlers (wrap-trapk pid (handlers-presence hs)) - (wrap-trapk pid (handlers-absence hs)) - (wrap-trapk pid (handlers-message hs)))) + (handlers (wrap-trapk pid new-eid (handlers-presence hs)) + (wrap-trapk pid new-eid (handlers-absence hs)) + (wrap-trapk pid new-eid (handlers-message hs)))) (if (hash-has-key? (vm-processes state) pid) (generic-update-process state pid (add-process-meta-eid new-eid)) state))] @@ -620,13 +665,17 @@ state))] [(? send-message? p) (values p state)] - [(spawn main k debug-name) - (values (spawn main (wrap-trapk pid k) debug-name) state)] + [(spawn spec k debug-name) + (values (spawn spec + (wrap-trapk pid (list 'meta-spawn 'k debug-name) k) + debug-name) + state)] [(? kill? p) (values p state)])) (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) (let loop ((state (make-vm 'ground-vm boot)))