diff --git a/racket/syndicate/core.rkt b/racket/syndicate/core.rkt index d940f66..c3871fc 100644 --- a/racket/syndicate/core.rkt +++ b/racket/syndicate/core.rkt @@ -71,6 +71,7 @@ (require "functional-queue.rkt") (require "trie.rkt") (require "patch.rkt") +(require "hierarchy.rkt") (require "trace.rkt") (require "mux.rkt") (require "pretty.rkt") @@ -226,7 +227,7 @@ (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)) - (cons pid (trace-pid-stack)) + (append (current-actor-path) (list pid)) (exn->string exn))) (struct-copy dataspace w [process-table (hash-remove (dataspace-process-table w) pid)] @@ -234,7 +235,7 @@ (define (invoke-process pid thunk k-ok k-exn) (define-values (ok? result) - (call-in-trace-context + (call/extended-actor-path pid (lambda () (with-handlers ([(lambda (exn) #t) (lambda (exn) (values #f exn))]) @@ -373,7 +374,7 @@ (create-process w behavior initial-transition name)) (lambda (exn) (log-error "Spawned process in dataspace ~a died with exception:\n~a" - (trace-pid-stack) + (current-actor-path) (exn->string exn)) (transition w '())))] ['quit @@ -390,7 +391,7 @@ [(and m (message body)) (when (observe? body) (log-warning "Stream ~a sent message containing query ~v" - (cons label (trace-pid-stack)) + (append (current-actor-path) (list label)) body)) (if (and (not (meta-label? label)) ;; it's from a local process, not envt (at-meta? body)) ;; it relates to envt, not local diff --git a/racket/syndicate/hierarchy.rkt b/racket/syndicate/hierarchy.rkt new file mode 100644 index 0000000..ec9d11f --- /dev/null +++ b/racket/syndicate/hierarchy.rkt @@ -0,0 +1,34 @@ +#lang racket/base +;; Keep track of actor hierarchy, e.g. for +;; - naming specific actors in traces, or +;; - injecting events from the outside world to specific locations in the tree + +(provide current-actor-path-rev + current-actor-path + call/extended-actor-path + gen:actor-hierarchy-node + actor-hierarchy-node-deliver) + +(require racket/generic) + +;; Parameterof (Listof Any) +;; Path to the active leaf in the process tree. The car end is the +;; leaf; the cdr end, the root. +(define current-actor-path-rev (make-parameter '())) + +;; Retrieves current-actor-path-rev, but reversed, for use with +;; actor-hierarchy-node-deliver. +(define (current-actor-path) (reverse (current-actor-path-rev))) + +;; Any (-> Any) -> Any +;; Pushes pid on current-actor-path for the duration of the call to thunk. +(define (call/extended-actor-path pid thunk) + (parameterize ((current-actor-path-rev (cons pid (current-actor-path-rev)))) + (thunk))) + +;; Generic interface for non-leaf nodes in the hierarchy. +(define-generics actor-hierarchy-node + ;; Deliver an event to a specific node in the hierarchy. + (actor-hierarchy-node-deliver actor-hierarchy-node + relative-path + event)) diff --git a/racket/syndicate/trace.rkt b/racket/syndicate/trace.rkt index 470a74e..8429a83 100644 --- a/racket/syndicate/trace.rkt +++ b/racket/syndicate/trace.rkt @@ -1,38 +1,24 @@ #lang racket/base (provide trace-logger - - trace-pid-stack - call-in-trace-context - trace-process-step trace-process-step-result trace-internal-action trace-internal-action-result) +(require "hierarchy.rkt") (require "pretty.rkt") (define trace-logger (make-logger 'minimart-trace)) -;; (Parameterof (Listof PID)) -;; Path to the active leaf in the process tree. The car end is the -;; leaf; the cdr end, the root. Used for debugging and tracing purposes. -(define trace-pid-stack (make-parameter '())) - -;; PID (-> Any) -> Any -;; Pushes pid on trace-pid-stack for the duration of the call to thunk. -(define (call-in-trace-context pid thunk) - (parameterize ((trace-pid-stack (cons pid (trace-pid-stack)))) - (thunk))) - (define-syntax-rule (record-trace-event name r) (when (log-level? trace-logger 'info) (log-message trace-logger 'info name "" r #f))) (define (cons-pid pid) (if pid - (cons pid (trace-pid-stack)) - (trace-pid-stack))) + (cons pid (current-actor-path-rev)) + (current-actor-path-rev))) ;; Event (Option PID) Process -> Void (define (trace-process-step e pid beh st)