From e74f6ae7e50f61cc2be466c9bbe3d4d95083f1dd Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 6 Jun 2016 16:45:42 -0400 Subject: [PATCH] Initial support for properly-recorded actor names. --- racket/syndicate/actor.rkt | 18 ++++++--- racket/syndicate/core.rkt | 64 ++++++++++++++++++++----------- racket/syndicate/trace/stderr.rkt | 8 ++-- 3 files changed, 58 insertions(+), 32 deletions(-) diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt index 5ec55ac..a035095 100644 --- a/racket/syndicate/actor.rkt +++ b/racket/syndicate/actor.rkt @@ -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)) diff --git a/racket/syndicate/core.rkt b/racket/syndicate/core.rkt index 10935ab..d2648f6 100644 --- a/racket/syndicate/core.rkt +++ b/racket/syndicate/core.rkt @@ -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) diff --git a/racket/syndicate/trace/stderr.rkt b/racket/syndicate/trace/stderr.rkt index 8b615ec..9f8d413 100644 --- a/racket/syndicate/trace/stderr.rkt +++ b/racket/syndicate/trace/stderr.rkt @@ -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)