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

64
racket/syndicate/core.rkt
View File

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

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

@ -163,7 +163,7 @@
(syndicate-pretty-print (transition-state t) (current-error-port)))))))] (syndicate-pretty-print (transition-state t) (current-error-port)))))))]
[('internal-action (list pids a old-w)) [('internal-action (list pids a old-w))
(define pidstr (format-pids pids)) (define pidstr (format-pids pids))
(define oldcount (hash-count (dataspace-behaviors old-w))) (define oldcount (hash-count (dataspace-process-table old-w)))
(match a (match a
[(? spawn?) [(? spawn?)
;; Handle this in internal-action-result ;; Handle this in internal-action-result
@ -193,19 +193,19 @@
(when (transition? t) (when (transition? t)
(define new-w (transition-state t)) (define new-w (transition-state t))
(define pidstr (format-pids pids)) (define pidstr (format-pids pids))
(define newcount (hash-count (dataspace-behaviors new-w))) (define newcount (hash-count (dataspace-process-table new-w)))
(match a (match a
[(? spawn?) [(? spawn?)
(when (or show-process-lifecycle? show-actions?) (when (or show-process-lifecycle? show-actions?)
(define newpid (mux-next-pid (dataspace-mux old-w))) (define newpid (mux-next-pid (dataspace-mux old-w)))
(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 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)) (define state (hash-ref (dataspace-states new-w) newpid '#: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
behavior info
pidstr pidstr
newcount)) newcount))
(unless (boring-state? state) (unless (boring-state? state)