syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Introduce struct process.

This commit is contained in:
Tony Garnock-Jones 2016-07-30 13:36:03 -04:00
parent 68ba2f74a6
commit c0786c86ca
5 changed files with 79 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
racket/syndicate/core.rkt
View File

@ -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))

56
racket/syndicate/dataspace.rkt
View File

@ -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 (<quit> 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)

54
racket/syndicate/ground.rkt
View File

@ -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)]
[(<quit> _ _)
(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))

19
racket/syndicate/relay.rkt
View File

@ -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 @@
[(<quit> exn actions)
(<quit> 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 '<relay> ?)))
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))

2
racket/syndicate/trace/stderr.rkt
View File

@ -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