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

Initial support for properly-recorded actor names.

This commit is contained in:
Tony Garnock-Jones 2016-06-06 16:45:42 -04:00
parent cd94df3cab
commit e74f6ae7e5
3 changed files with 58 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
racket/syndicate/actor.rkt
View File

@ -251,6 +251,10 @@
(lambda (k) (spawn-instruction linkage-kind action-fn k))))
(begin-for-syntax
(define-splicing-syntax-class name
(pattern (~seq #:name N))
(pattern (~seq) #:attr N #'#f))
(define-splicing-syntax-class init
(pattern (~seq #:init [I ...]))
(pattern (~seq) #:attr [I 1] '()))
@ -267,7 +271,7 @@
(define-syntax (state stx)
(syntax-parse stx
[(_ init:init [bs:bindings O ...] [E Oe ...] ...)
(expand-state 'call #'(init.I ...) #'(bs.id ...) #'(bs.init ...) #'(O ...) #'([E Oe ...] ...))]))
(expand-state #'#f 'call #'(init.I ...) #'(bs.id ...) #'(bs.init ...) #'(O ...) #'([E Oe ...] ...))]))
;; Sugar
(define-syntax (until stx)
@ -284,14 +288,15 @@
;; Spawn actors with 'actor linkage
(define-syntax (actor stx)
(syntax-parse stx
[(_ I ...)
(expand-state 'actor #'(I ... (return/no-link-result!)) #'() #'() #'() #'())]))
[(_ name:name I ...)
(expand-state #'name.N 'actor #'(I ... (return/no-link-result!)) #'() #'() #'() #'())]))
;; Spawn whole dataspaces
(define-syntax (dataspace stx)
(syntax-parse stx
[(_ I ...)
(expand-state 'dataspace
(expand-state #'#f
'dataspace
#'(I
...
(perform-core-action! (quit-dataspace))
@ -486,7 +491,7 @@
(pattern (~seq #:meta-level level:integer))
(pattern (~seq) #:attr level #'0))
(define (expand-state linkage-kind init-actions binding-names binding-inits ongoings edges)
(define (expand-state name-exp linkage-kind init-actions binding-names binding-inits ongoings edges)
;; ----------------------------------------
(define binding-count (length (syntax->list binding-names)))
;; ----------------------------------------
@ -781,7 +786,8 @@
subscribe-to-linkage
(maintain-assertions #f)
perform-pending-patch
run-init-actions))))))
run-init-actions)
#,name-exp)))))
;; (local-require racket/pretty)
;; (pretty-print (syntax->datum action-fn-stx))

64
racket/syndicate/core.rkt
View File

@ -104,11 +104,17 @@
;; A PID is a Nat.
;; A Label is a PID or 'meta.
;; Long-lived process data: (process-info Any Behavior)
(struct process-info (name behavior) #:transparent)
;; Sentinel
(define missing-process-info (process-info #f #f))
;; VM private states
(struct dataspace (mux ;; Multiplexer
pending-action-queue ;; (Queueof (Cons Label (U Action 'quit)))
runnable-pids ;; (Setof PID)
behaviors ;; (HashTable PID Behavior)
process-table ;; (HashTable PID ProcessInfo)
states ;; (HashTable PID Any)
)
#:transparent
@ -183,7 +189,8 @@
(filter (lambda (x) (and (action? x) (not (patch-empty? x)))) (flatten actions)))
(define (send-event e pid w)
(define behavior (hash-ref (dataspace-behaviors w) pid #f))
(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))
(if (not behavior)
w
@ -220,7 +227,7 @@
(cons pid (trace-pid-stack))
(exn->string exn)))
(struct-copy dataspace w
[behaviors (hash-remove (dataspace-behaviors 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)
@ -250,14 +257,14 @@
(syntax-rules ()
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
(spawn (lambda ()
(list (let ((name name-exp)
(beh behavior-exp))
(if name (procedure-rename beh name) beh))
(transition initial-state-exp initial-action-tree-exp))))]
(list behavior-exp
(transition initial-state-exp initial-action-tree-exp)
name-exp)))]
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
(spawn (lambda ()
(list behavior-exp
(transition initial-state-exp initial-action-tree-exp))))]))
(transition initial-state-exp initial-action-tree-exp)
#f)))]))
(define-syntax-rule (spawn/stateless behavior-exp initial-action-tree-exp)
(spawn-process (stateless-behavior-wrap behavior-exp)
@ -270,8 +277,12 @@
[(? quit? q) q]
[actions (transition state actions)]))
(define-syntax-rule (spawn-dataspace boot-action ...)
(make-spawn-dataspace (lambda () (list boot-action ...))))
(define-syntax spawn-dataspace
(syntax-rules ()
[(spawn-dataspace #:name name-exp boot-action ...)
(make-spawn-dataspace #:name name-exp (lambda () (list boot-action ...)))]
[(spawn-dataspace boot-action ...)
(make-spawn-dataspace (lambda () (list boot-action ...)))]))
(define (make-dataspace boot-actions)
(dataspace (mux)
@ -280,10 +291,11 @@
(hash)
(hash)))
(define (make-spawn-dataspace boot-actions-thunk)
(define (make-spawn-dataspace #:name [name #f] boot-actions-thunk)
(spawn (lambda ()
(list dataspace-handle-event
(transition (make-dataspace (boot-actions-thunk)) '())))))
(transition (make-dataspace (boot-actions-thunk)) '())
name))))
(define (transition-bind k t0)
(match t0
@ -348,15 +360,15 @@
(invoke-process 'booting
(lambda ()
(match (boot)
[(and results (list (? procedure?) (? general-transition?)))
[(and results (list (? procedure?) (? general-transition?) _))
results]
[other
(error 'spawn
"Spawn boot procedure must yield boot spec; received ~v"
other)]))
(lambda (results)
(match-define (list behavior initial-transition) results)
(create-process w behavior initial-transition))
(match-define (list behavior initial-transition name) results)
(create-process w behavior initial-transition name))
(lambda (exn)
(log-error "Spawned process in dataspace ~a died with exception:\n~a"
(trace-pid-stack)
@ -386,7 +398,7 @@
(send-event m pid w))
'()))]))
(define (create-process w behavior initial-transition)
(define (create-process w behavior initial-transition name)
(if (not initial-transition)
(transition w '()) ;; Uh, ok
(let ()
@ -409,9 +421,10 @@
(define-values (new-mux new-pid delta delta-aggregate)
(mux-add-stream (dataspace-mux w) initial-patch))
(let* ((w (struct-copy dataspace w
[behaviors (hash-set (dataspace-behaviors w)
new-pid
behavior)]))
[process-table (hash-set (dataspace-process-table w)
new-pid
(process-info name
behavior))]))
(w (enqueue-actions (postprocess w new-pid) new-pid remaining-initial-actions)))
(deliver-patches w new-mux new-pid delta delta-aggregate)))))
@ -434,7 +447,7 @@
'())))
(define (pretty-print-dataspace w [p (current-output-port)])
(match-define (dataspace mux qs runnable behaviors states) w)
(match-define (dataspace mux qs runnable process-table states) 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))
@ -443,11 +456,18 @@
(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))])
(fprintf p " ---- process ~a, behavior ~v, STATE:\n" pid (hash-ref behaviors pid #f))
(define i (hash-ref process-table pid missing-process-info))
(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)
(newline p)
(fprintf p " process ~a, behavior ~v, CLAIMS:\n" pid (hash-ref behaviors pid #f))
(fprintf p " process ~a, name ~v, behavior ~v, CLAIMS:\n"
pid
(process-info-name i)
(process-info-behavior i))
(display (indented-port-output 6 (lambda (p)
(pretty-print-trie (mux-interests-of mux pid) p)))
p)

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

@ -163,7 +163,7 @@
(syndicate-pretty-print (transition-state t) (current-error-port)))))))]
[('internal-action (list pids a old-w))
(define pidstr (format-pids pids))
(define oldcount (hash-count (dataspace-behaviors old-w)))
(define oldcount (hash-count (dataspace-process-table old-w)))
(match a
[(? spawn?)
;; Handle this in internal-action-result
@ -193,19 +193,19 @@
(when (transition? t)
(define new-w (transition-state t))
(define pidstr (format-pids pids))
(define newcount (hash-count (dataspace-behaviors new-w)))
(define newcount (hash-count (dataspace-process-table new-w)))
(match a
[(? spawn?)
(when (or show-process-lifecycle? show-actions?)
(define newpid (mux-next-pid (dataspace-mux old-w)))
(define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
(define interests (mux-interests-of (dataspace-mux new-w) newpid))
(define behavior (hash-ref (dataspace-behaviors 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))
(with-color BRIGHT-GREEN
(output "~a ~v spawned from ~a (~a total processes now)\n"
newpidstr
behavior
info
pidstr
newcount))
(unless (boring-state? state)