From c0786c86cad3b8b6abe02eee7651d1dc8bb96b53 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 30 Jul 2016 13:36:03 -0400 Subject: [PATCH] Introduce struct process. --- racket/syndicate/core.rkt | 12 ++++++- racket/syndicate/dataspace.rkt | 56 +++++++++++++++---------------- racket/syndicate/ground.rkt | 54 +++++++++++++++-------------- racket/syndicate/relay.rkt | 19 ++++++----- racket/syndicate/trace/stderr.rkt | 2 +- 5 files changed, 79 insertions(+), 64 deletions(-) diff --git a/racket/syndicate/core.rkt b/racket/syndicate/core.rkt index a27761f..f2b9a8f 100644 --- a/racket/syndicate/core.rkt +++ b/racket/syndicate/core.rkt @@ -9,6 +9,8 @@ (struct-out quit-dataspace) (struct-out transition) + (struct-out process) + (struct-out seal) sealof @@ -56,7 +58,9 @@ sequence-transitions0* clean-actions - clean-transition) + clean-transition + + update-process-state) (require racket/match) (require (only-in racket/list flatten)) @@ -90,6 +94,9 @@ (struct transition (state actions) #:transparent) (struct quit (exn actions) #:prefab) +;; A Process is per-process data: (process Any Behavior Any) +(struct process (name behavior state) #:transparent) + ;; A PID is a Nat. ;; A Label is a PID or 'meta. @@ -144,6 +151,9 @@ (define (clean-actions actions) (filter (lambda (x) (and (action? x) (not (patch-empty? x)))) (flatten actions))) +(define (update-process-state i new-state) + (struct-copy process i [state new-state])) + (define (make-quit #:exception [exn #f] . actions) (quit exn actions)) diff --git a/racket/syndicate/dataspace.rkt b/racket/syndicate/dataspace.rkt index 167a9e2..6f7248e 100644 --- a/racket/syndicate/dataspace.rkt +++ b/racket/syndicate/dataspace.rkt @@ -20,18 +20,14 @@ (require "core.rkt") (require "protocol/standard-relay.rkt") -;; Long-lived process data: (process-info Any Behavior) -(struct process-info (name behavior) #:transparent) - ;; Sentinel -(define missing-process-info (process-info #f #f)) +(define missing-process (process #f #f #f)) ;; VM private states (struct dataspace (mux ;; Multiplexer pending-action-queue ;; (Queueof (Cons Label (U Action 'quit))) runnable-pids ;; (Setof PID) - process-table ;; (HashTable PID ProcessInfo) - states ;; (HashTable PID Any) + process-table ;; (HashTable PID Process) ) #:transparent #:methods gen:syndicate-pretty-printable @@ -41,9 +37,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (send-event e pid w) - (define behavior (process-info-behavior - (hash-ref (dataspace-process-table w) pid missing-process-info))) - (define old-state (hash-ref (dataspace-states w) pid #f)) + (match-define (process _ behavior old-state) + (hash-ref (dataspace-process-table w) pid missing-process)) (if (not behavior) w (begin @@ -66,7 +61,12 @@ (enqueue-actions (disable-process pid exn w) pid (list 'quit))))))) (define (update-state w pid s) - (struct-copy dataspace w [states (hash-set (dataspace-states w) pid s)])) + (define old-pt (dataspace-process-table w)) + (define old-p (hash-ref old-pt pid #f)) + (if old-p + (struct-copy dataspace w + [process-table (hash-set old-pt pid (update-process-state old-p s))]) + w)) (define (send-event/guard e pid w) (if (patch-empty? e) @@ -76,12 +76,11 @@ (define (disable-process pid exn w) (when exn (log-error "Process ~v ~a died with exception:\n~a" - (process-info-name (hash-ref (dataspace-process-table w) pid missing-process-info)) + (process-name (hash-ref (dataspace-process-table w) pid missing-process)) (append (current-actor-path) (list pid)) (exn->string exn))) (struct-copy dataspace w - [process-table (hash-remove (dataspace-process-table w) pid)] - [states (hash-remove (dataspace-states w) pid)])) + [process-table (hash-remove (dataspace-process-table w) pid)])) (define (invoke-process pid thunk k-ok k-exn) (define-values (ok? result) @@ -116,7 +115,6 @@ (dataspace (mux) (list->queue (for/list ((a (in-list (clean-actions boot-actions)))) (cons 'meta a))) (set) - (hash) (hash))) (define (make-spawn-dataspace #:name [name #f] boot-actions-thunk) @@ -196,17 +194,19 @@ (if (not initial-transition) (transition w '()) ;; Uh, ok (let () - (define-values (postprocess initial-actions) + (define-values (postprocess initial-state initial-actions) (match (clean-transition initial-transition) [(and q ( exn initial-actions0)) (values (lambda (w pid) (trace-process-step-result 'boot pid behavior (void) exn q) (disable-process pid exn w)) + #f (append initial-actions0 (list 'quit)))] [(and t (transition initial-state initial-actions0)) (values (lambda (w pid) (trace-process-step-result 'boot pid behavior (void) #f t) - (mark-pid-runnable (update-state w pid initial-state) pid)) + (mark-pid-runnable w pid)) + initial-state initial-actions0)])) (define-values (initial-patch remaining-initial-actions) (match initial-actions @@ -217,8 +217,9 @@ (let* ((w (struct-copy dataspace w [process-table (hash-set (dataspace-process-table w) new-pid - (process-info name - behavior))])) + (process name + behavior + initial-state))])) (w (enqueue-actions (postprocess w new-pid) new-pid remaining-initial-actions))) (deliver-patches w new-mux new-pid delta delta-aggregate))))) @@ -241,27 +242,26 @@ '()))) (define (pretty-print-dataspace w [p (current-output-port)]) - (match-define (dataspace mux qs runnable process-table states) w) + (match-define (dataspace mux qs runnable process-table) w) (fprintf p "DATASPACE:\n") (fprintf p " - ~a queued actions\n" (queue-length qs)) (fprintf p " - ~a runnable pids ~a\n" (set-count runnable) (set->list runnable)) - (fprintf p " - ~a live processes\n" (hash-count states)) + (fprintf p " - ~a live processes\n" (hash-count process-table)) (fprintf p " - ") (display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p) (newline p) - (for ([pid (set-union (hash-keys (mux-interest-table mux)) (hash-keys states))]) - (define i (hash-ref process-table pid missing-process-info)) + (for ([pid (set-union (hash-keys (mux-interest-table mux)) (hash-keys process-table))]) + (define i (hash-ref process-table pid missing-process)) (fprintf p " ---- process ~a, name ~v, behavior ~v, STATE:\n" pid - (process-info-name i) - (process-info-behavior i)) - (define state (hash-ref states pid #f)) - (display (indented-port-output 6 (lambda (p) (syndicate-pretty-print state p))) p) + (process-name i) + (process-behavior i)) + (display (indented-port-output 6 (lambda (p) (syndicate-pretty-print (process-state i) p))) p) (newline p) (fprintf p " process ~a, name ~v, behavior ~v, CLAIMS:\n" pid - (process-info-name i) - (process-info-behavior i)) + (process-name i) + (process-behavior i)) (display (indented-port-output 6 (lambda (p) (pretty-print-trie (mux-interests-of mux pid) p))) p) diff --git a/racket/syndicate/ground.rkt b/racket/syndicate/ground.rkt index 16f91f8..9164d53 100644 --- a/racket/syndicate/ground.rkt +++ b/racket/syndicate/ground.rkt @@ -96,8 +96,8 @@ (define poll-handler (handle-evt always-evt (lambda _ #f))) -;; Boolean Behavior State AssertionSet Natural -> Void -(define (await-interrupt inert? beh st interests background-activity-count) +;; Boolean Process AssertionSet Natural -> Void +(define (await-interrupt inert? proc interests background-activity-count) ;; (log-info "~a ~a GROUND INTERESTS:\n~a" ;; inert? ;; background-activity-count @@ -114,36 +114,38 @@ (extract-active-events interests)) [(background-activity-signal delta) ;; (log-info "background-activity-count ~v" (+ background-activity-count delta)) - (await-interrupt inert? beh st interests (+ background-activity-count delta))] + (await-interrupt inert? proc interests (+ background-activity-count delta))] [e - (inject-event e beh st interests background-activity-count)]))) + (inject-event e proc interests background-activity-count)]))) -;; Event Behavior State AssertionSet Natural -> Void -(define (inject-event e beh st interests background-activity-count) - (trace-process-step e #f beh st) - (define resulting-transition (clean-transition (beh e st))) - (trace-process-step-result e #f beh st #f resulting-transition) - (process-transition resulting-transition beh st interests background-activity-count)) +;; Event Process AssertionSet Natural -> Void +(define (inject-event e proc interests background-activity-count) + (trace-process-step e #f (process-behavior proc) (process-state proc)) + (define resulting-transition (clean-transition ((process-behavior proc) e (process-state proc)))) + (trace-process-step-result e #f (process-behavior proc) (process-state proc) + #f resulting-transition) + (process-transition resulting-transition proc interests background-activity-count)) -;; Transition Behavior State AssertionSet Natural -> Void -(define (process-transition resulting-transition beh st interests background-activity-count) +;; Transition Process AssertionSet Natural -> Void +(define (process-transition resulting-transition proc interests background-activity-count) (match resulting-transition [#f ;; inert - (await-interrupt #t beh st interests background-activity-count)] + (await-interrupt #t proc interests background-activity-count)] [( _ _) (log-info "run-ground: Terminating by request") (void)] - [(transition st actions) - (let process-actions ((actions actions) (interests interests)) - (match actions - ['() (await-interrupt #f beh st interests background-activity-count)] - [(cons a actions) - (match a - [(? patch? p) - (process-actions actions (apply-patch interests (label-patch p (datum-tset 'root))))] - [_ - (log-warning "run-ground: ignoring useless meta-action ~v" a) - (process-actions actions interests)])]))])) + [(transition new-state actions) + (let ((proc (update-process-state proc new-state))) + (let process-actions ((actions actions) (interests interests)) + (match actions + ['() (await-interrupt #f proc interests background-activity-count)] + [(cons a actions) + (match a + [(? patch? p) + (process-actions actions (apply-patch interests (label-patch p (datum-tset 'root))))] + [_ + (log-warning "run-ground: ignoring useless meta-action ~v" a) + (process-actions actions interests)])])))])) ;; Action* -> Void ;; Runs a ground VM, booting the outermost Dataspace with the given Actions. @@ -152,5 +154,5 @@ ;; Spawn -> Void (define (run-ground* s) - (match-define (list beh t _name) ((spawn-boot s))) - (process-transition t beh 'undefined-initial-ground-state trie-empty 0)) + (match-define (list beh t name) ((spawn-boot s))) + (process-transition t (process name beh 'undefined-initial-ground-state) trie-empty 0)) diff --git a/racket/syndicate/relay.rkt b/racket/syndicate/relay.rkt index cbcbe35..09b64c7 100644 --- a/racket/syndicate/relay.rkt +++ b/racket/syndicate/relay.rkt @@ -19,8 +19,7 @@ outbound-parenthesis ;; OpenParenthesis/1 inbound-constructor ;; Assertion -> Assertion inbound-parenthesis ;; OpenParenthesis/1 - inner-behavior ;; Behavior - inner-state ;; Any + inner ;; Process ) #:transparent #:methods gen:syndicate-pretty-printable @@ -66,12 +65,14 @@ [( exn actions) ( exn (relay-drop-actions actions r))] [(transition st actions) - (transition (struct-copy relay r [inner-state st]) (relay-drop-actions actions r))] + (transition (struct-copy relay r [inner (update-process-state (relay-inner r) st)]) + (relay-drop-actions actions r))] [(or #f (? void?)) t])) (define (relay-handle-event e r) - (relay-transition ((relay-inner-behavior r) (relay-lift-event e r) (relay-inner-state r)) r)) + (define i (relay-inner r)) + (relay-transition ((process-behavior i) (relay-lift-event e r) (process-state i)) r)) (define ((inject-relay-subscription r) initial-inner-state) (define initial-patch @@ -80,7 +81,8 @@ (pattern->trie ' ?))) trie-empty) (sub (observe ((relay-inbound-constructor r) ?))))) - ((relay-inner-behavior r) initial-patch initial-inner-state)) + (define i (relay-inner r)) + ((process-behavior i) initial-patch initial-inner-state)) (define (spawn-relay outbound? outbound-assertion @@ -95,8 +97,9 @@ outbound-parenthesis inbound-constructor inbound-parenthesis - inner-behavior - 'uninitialized:initial-inner-state)) + (process name + inner-behavior + 'uninitialized:initial-inner-state))) (list relay-handle-event (relay-transition (transition-bind (inject-relay-subscription initial-relay-state) initial-transition) @@ -107,4 +110,4 @@ (fprintf p "RELAY ~a/~a\n" (open-parenthesis-type (relay-outbound-parenthesis r)) (open-parenthesis-type (relay-inbound-parenthesis r))) - (syndicate-pretty-print (relay-inner-state r) p)) + (syndicate-pretty-print (process-state (relay-inner r)) p)) diff --git a/racket/syndicate/trace/stderr.rkt b/racket/syndicate/trace/stderr.rkt index 31c77c7..4356718 100644 --- a/racket/syndicate/trace/stderr.rkt +++ b/racket/syndicate/trace/stderr.rkt @@ -212,7 +212,7 @@ (define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid (define interests (mux-interests-of (dataspace-mux new-w) newpid)) (define info (hash-ref (dataspace-process-table new-w) newpid '#:missing-behavior)) - (define state (hash-ref (dataspace-states new-w) newpid '#:missing-state)) + (define state (if (process? info) (process-state info) '#:missing-state)) (with-color BRIGHT-GREEN (output "~a ~v spawned from ~a (~a total processes now)\n" newpidstr