Contract process state, and merge spawn/monitor into spawn.

2012-06-23 07:55:09 -04:00 · 2012-06-23 07:55:09 -04:00 · 1ffd0afe66
parent 83cae7075e
commit 1ffd0afe66
2 changed files with 109 additions and 76 deletions
--- a/32
+++ b/32
@ -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.
--- 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 <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<EID>
-;; Set<EID>), 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<EID> Set<EID>), 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<EID>
+		 meta-endpoints ;; Set<EID>
+		 ) #: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> = X -> InterruptK

@ -134,6 +148,8 @@
 ;;           Maybe<TrapK<Topic * Message>>)
 (struct handlers (presence absence message) #:transparent)

+;; Transition = State or (transition State ConsTreeOf<Action>)
+;;
 ;; actions is a plain old ordered ConsTreeOf<Action>, 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<TrapK<PID>> Any)
-(struct spawn (main k debug-name) #:prefab)
+;; (spawn BootSpecification Maybe<TrapK<PID>> Any)
+(struct spawn (spec k debug-name) #:prefab)
 ;;
 ;; (kill Maybe<PID> 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)))