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 quit-dataspace)
(struct-out transition) (struct-out transition)
(struct-out process)
(struct-out seal) (struct-out seal)
sealof sealof
@ -56,7 +58,9 @@
sequence-transitions0* sequence-transitions0*
clean-actions clean-actions
clean-transition) clean-transition
update-process-state)
(require racket/match) (require racket/match)
(require (only-in racket/list flatten)) (require (only-in racket/list flatten))
@ -90,6 +94,9 @@
(struct transition (state actions) #:transparent) (struct transition (state actions) #:transparent)
(struct quit (exn actions) #:prefab) (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 PID is a Nat.
;; A Label is a PID or 'meta. ;; A Label is a PID or 'meta.
@ -144,6 +151,9 @@
(define (clean-actions actions) (define (clean-actions actions)
(filter (lambda (x) (and (action? x) (not (patch-empty? x)))) (flatten 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) (define (make-quit #:exception [exn #f] . actions)
(quit exn actions)) (quit exn actions))

56
racket/syndicate/dataspace.rkt
View File

@ -20,18 +20,14 @@
(require "core.rkt") (require "core.rkt")
(require "protocol/standard-relay.rkt") (require "protocol/standard-relay.rkt")
;; Long-lived process data: (process-info Any Behavior)
(struct process-info (name behavior) #:transparent)
;; Sentinel ;; Sentinel
(define missing-process-info (process-info #f #f)) (define missing-process (process #f #f #f))
;; VM private states ;; VM private states
(struct dataspace (mux ;; Multiplexer (struct dataspace (mux ;; Multiplexer
pending-action-queue ;; (Queueof (Cons Label (U Action 'quit))) pending-action-queue ;; (Queueof (Cons Label (U Action 'quit)))
runnable-pids ;; (Setof PID) runnable-pids ;; (Setof PID)
process-table ;; (HashTable PID ProcessInfo) process-table ;; (HashTable PID Process)
states ;; (HashTable PID Any)
) )
#:transparent #:transparent
#:methods gen:syndicate-pretty-printable #:methods gen:syndicate-pretty-printable
@ -41,9 +37,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (send-event e pid w) (define (send-event e pid w)
(define behavior (process-info-behavior (match-define (process _ behavior old-state)
(hash-ref (dataspace-process-table w) pid missing-process-info))) (hash-ref (dataspace-process-table w) pid missing-process))
(define old-state (hash-ref (dataspace-states w) pid #f))
(if (not behavior) (if (not behavior)
w w
(begin (begin
@ -66,7 +61,12 @@
(enqueue-actions (disable-process pid exn w) pid (list 'quit))))))) (enqueue-actions (disable-process pid exn w) pid (list 'quit)))))))
(define (update-state w pid s) (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) (define (send-event/guard e pid w)
(if (patch-empty? e) (if (patch-empty? e)
@ -76,12 +76,11 @@
(define (disable-process pid exn w) (define (disable-process pid exn w)
(when exn (when exn
(log-error "Process ~v ~a died with exception:\n~a" (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)) (append (current-actor-path) (list pid))
(exn->string exn))) (exn->string exn)))
(struct-copy dataspace w (struct-copy dataspace w
[process-table (hash-remove (dataspace-process-table w) pid)] [process-table (hash-remove (dataspace-process-table w) pid)]))
[states (hash-remove (dataspace-states w) pid)]))
(define (invoke-process pid thunk k-ok k-exn) (define (invoke-process pid thunk k-ok k-exn)
(define-values (ok? result) (define-values (ok? result)
@ -116,7 +115,6 @@
(dataspace (mux) (dataspace (mux)
(list->queue (for/list ((a (in-list (clean-actions boot-actions)))) (cons 'meta a))) (list->queue (for/list ((a (in-list (clean-actions boot-actions)))) (cons 'meta a)))
(set) (set)
(hash)
(hash))) (hash)))
(define (make-spawn-dataspace #:name [name #f] boot-actions-thunk) (define (make-spawn-dataspace #:name [name #f] boot-actions-thunk)
@ -196,17 +194,19 @@
(if (not initial-transition) (if (not initial-transition)
(transition w '()) ;; Uh, ok (transition w '()) ;; Uh, ok
(let () (let ()
(define-values (postprocess initial-actions) (define-values (postprocess initial-state initial-actions)
(match (clean-transition initial-transition) (match (clean-transition initial-transition)
[(and q (<quit> exn initial-actions0)) [(and q (<quit> exn initial-actions0))
(values (lambda (w pid) (values (lambda (w pid)
(trace-process-step-result 'boot pid behavior (void) exn q) (trace-process-step-result 'boot pid behavior (void) exn q)
(disable-process pid exn w)) (disable-process pid exn w))
#f
(append initial-actions0 (list 'quit)))] (append initial-actions0 (list 'quit)))]
[(and t (transition initial-state initial-actions0)) [(and t (transition initial-state initial-actions0))
(values (lambda (w pid) (values (lambda (w pid)
(trace-process-step-result 'boot pid behavior (void) #f t) (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)])) initial-actions0)]))
(define-values (initial-patch remaining-initial-actions) (define-values (initial-patch remaining-initial-actions)
(match initial-actions (match initial-actions
@ -217,8 +217,9 @@
(let* ((w (struct-copy dataspace w (let* ((w (struct-copy dataspace w
[process-table (hash-set (dataspace-process-table w) [process-table (hash-set (dataspace-process-table w)
new-pid new-pid
(process-info name (process name
behavior))])) behavior
initial-state))]))
(w (enqueue-actions (postprocess w new-pid) new-pid remaining-initial-actions))) (w (enqueue-actions (postprocess w new-pid) new-pid remaining-initial-actions)))
(deliver-patches w new-mux new-pid delta delta-aggregate))))) (deliver-patches w new-mux new-pid delta delta-aggregate)))))
@ -241,27 +242,26 @@
'()))) '())))
(define (pretty-print-dataspace w [p (current-output-port)]) (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 "DATASPACE:\n")
(fprintf p " - ~a queued actions\n" (queue-length qs)) (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 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 " - ") (fprintf p " - ")
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p) (display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p)
(newline p) (newline p)
(for ([pid (set-union (hash-keys (mux-interest-table mux)) (hash-keys states))]) (for ([pid (set-union (hash-keys (mux-interest-table mux)) (hash-keys process-table))])
(define i (hash-ref process-table pid missing-process-info)) (define i (hash-ref process-table pid missing-process))
(fprintf p " ---- process ~a, name ~v, behavior ~v, STATE:\n" (fprintf p " ---- process ~a, name ~v, behavior ~v, STATE:\n"
pid pid
(process-info-name i) (process-name i)
(process-info-behavior i)) (process-behavior i))
(define state (hash-ref states pid #f)) (display (indented-port-output 6 (lambda (p) (syndicate-pretty-print (process-state i) p))) p)
(display (indented-port-output 6 (lambda (p) (syndicate-pretty-print state p))) p)
(newline p) (newline p)
(fprintf p " process ~a, name ~v, behavior ~v, CLAIMS:\n" (fprintf p " process ~a, name ~v, behavior ~v, CLAIMS:\n"
pid pid
(process-info-name i) (process-name i)
(process-info-behavior i)) (process-behavior i))
(display (indented-port-output 6 (lambda (p) (display (indented-port-output 6 (lambda (p)
(pretty-print-trie (mux-interests-of mux pid) p))) (pretty-print-trie (mux-interests-of mux pid) p)))
p) p)

54
racket/syndicate/ground.rkt
View File

@ -96,8 +96,8 @@
(define poll-handler (define poll-handler
(handle-evt always-evt (lambda _ #f))) (handle-evt always-evt (lambda _ #f)))
;; Boolean Behavior State AssertionSet Natural -> Void ;; Boolean Process AssertionSet Natural -> Void
(define (await-interrupt inert? beh st interests background-activity-count) (define (await-interrupt inert? proc interests background-activity-count)
;; (log-info "~a ~a GROUND INTERESTS:\n~a" ;; (log-info "~a ~a GROUND INTERESTS:\n~a"
;; inert? ;; inert?
;; background-activity-count ;; background-activity-count
@ -114,36 +114,38 @@
(extract-active-events interests)) (extract-active-events interests))
[(background-activity-signal delta) [(background-activity-signal delta)
;; (log-info "background-activity-count ~v" (+ background-activity-count 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 [e
(inject-event e beh st interests background-activity-count)]))) (inject-event e proc interests background-activity-count)])))
;; Event Behavior State AssertionSet Natural -> Void ;; Event Process AssertionSet Natural -> Void
(define (inject-event e beh st interests background-activity-count) (define (inject-event e proc interests background-activity-count)
(trace-process-step e #f beh st) (trace-process-step e #f (process-behavior proc) (process-state proc))
(define resulting-transition (clean-transition (beh e st))) (define resulting-transition (clean-transition ((process-behavior proc) e (process-state proc))))
(trace-process-step-result e #f beh st #f resulting-transition) (trace-process-step-result e #f (process-behavior proc) (process-state proc)
(process-transition resulting-transition beh st interests background-activity-count)) #f resulting-transition)
(process-transition resulting-transition proc interests background-activity-count))
;; Transition Behavior State AssertionSet Natural -> Void ;; Transition Process AssertionSet Natural -> Void
(define (process-transition resulting-transition beh st interests background-activity-count) (define (process-transition resulting-transition proc interests background-activity-count)
(match resulting-transition (match resulting-transition
[#f ;; inert [#f ;; inert
(await-interrupt #t beh st interests background-activity-count)] (await-interrupt #t proc interests background-activity-count)]
[(<quit> _ _) [(<quit> _ _)
(log-info "run-ground: Terminating by request") (log-info "run-ground: Terminating by request")
(void)] (void)]
[(transition st actions) [(transition new-state actions)
(let process-actions ((actions actions) (interests interests)) (let ((proc (update-process-state proc new-state)))
(match actions (let process-actions ((actions actions) (interests interests))
['() (await-interrupt #f beh st interests background-activity-count)] (match actions
[(cons a actions) ['() (await-interrupt #f proc interests background-activity-count)]
(match a [(cons a actions)
[(? patch? p) (match a
(process-actions actions (apply-patch interests (label-patch p (datum-tset 'root))))] [(? 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)])]))])) (log-warning "run-ground: ignoring useless meta-action ~v" a)
(process-actions actions interests)])])))]))
;; Action* -> Void ;; Action* -> Void
;; Runs a ground VM, booting the outermost Dataspace with the given Actions. ;; Runs a ground VM, booting the outermost Dataspace with the given Actions.
@ -152,5 +154,5 @@
;; Spawn -> Void ;; Spawn -> Void
(define (run-ground* s) (define (run-ground* s)
(match-define (list beh t _name) ((spawn-boot s))) (match-define (list beh t name) ((spawn-boot s)))
(process-transition t beh 'undefined-initial-ground-state trie-empty 0)) (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 outbound-parenthesis ;; OpenParenthesis/1
inbound-constructor ;; Assertion -> Assertion inbound-constructor ;; Assertion -> Assertion
inbound-parenthesis ;; OpenParenthesis/1 inbound-parenthesis ;; OpenParenthesis/1
inner-behavior ;; Behavior inner ;; Process
inner-state ;; Any
) )
#:transparent #:transparent
#:methods gen:syndicate-pretty-printable #:methods gen:syndicate-pretty-printable
@ -66,12 +65,14 @@
[(<quit> exn actions) [(<quit> exn actions)
(<quit> exn (relay-drop-actions actions r))] (<quit> exn (relay-drop-actions actions r))]
[(transition st actions) [(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?)) [(or #f (? void?))
t])) t]))
(define (relay-handle-event e r) (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 ((inject-relay-subscription r) initial-inner-state)
(define initial-patch (define initial-patch
@ -80,7 +81,8 @@
(pattern->trie '<relay> ?))) (pattern->trie '<relay> ?)))
trie-empty) trie-empty)
(sub (observe ((relay-inbound-constructor r) ?))))) (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? (define (spawn-relay outbound?
outbound-assertion outbound-assertion
@ -95,8 +97,9 @@
outbound-parenthesis outbound-parenthesis
inbound-constructor inbound-constructor
inbound-parenthesis inbound-parenthesis
inner-behavior (process name
'uninitialized:initial-inner-state)) inner-behavior
'uninitialized:initial-inner-state)))
(list relay-handle-event (list relay-handle-event
(relay-transition (transition-bind (inject-relay-subscription initial-relay-state) (relay-transition (transition-bind (inject-relay-subscription initial-relay-state)
initial-transition) initial-transition)
@ -107,4 +110,4 @@
(fprintf p "RELAY ~a/~a\n" (fprintf p "RELAY ~a/~a\n"
(open-parenthesis-type (relay-outbound-parenthesis r)) (open-parenthesis-type (relay-outbound-parenthesis r))
(open-parenthesis-type (relay-inbound-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 newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
(define interests (mux-interests-of (dataspace-mux new-w) newpid)) (define interests (mux-interests-of (dataspace-mux new-w) newpid))
(define info (hash-ref (dataspace-process-table new-w) newpid '#:missing-behavior)) (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 (with-color BRIGHT-GREEN
(output "~a ~v spawned from ~a (~a total processes now)\n" (output "~a ~v spawned from ~a (~a total processes now)\n"
newpidstr newpidstr