diff --git a/racket/syndicate/core.rkt b/racket/syndicate/core.rkt index c3871fc..a3531b8 100644 --- a/racket/syndicate/core.rkt +++ b/racket/syndicate/core.rkt @@ -218,10 +218,10 @@ (define (update-state w pid s) (struct-copy dataspace w [states (hash-set (dataspace-states w) pid s)])) -(define (send-event/guard delta pid w) - (if (patch-empty? delta) +(define (send-event/guard e pid w) + (if (patch-empty? e) w - (send-event delta pid w))) + (send-event e pid w))) (define (disable-process pid exn w) (when exn @@ -343,6 +343,7 @@ (define ((inject-event e) w) (transition (match e [#f w] + [(? targeted-event?) (enqueue-actions w 'meta (list e))] [(? patch? delta) (enqueue-actions w 'meta (list (lift-patch delta)))] [(message body) (enqueue-actions w 'meta (list (message (at-meta body))))]) '())) @@ -399,7 +400,9 @@ (transition (for/fold [(w w)] [(pid (in-list (mux-route-message (dataspace-mux w) body)))] (send-event m pid w)) - '()))])) + '()))] + [(targeted-event (cons pid remaining-path) e) + (transition (send-event/guard (target-event remaining-path e) pid w) '())])) (define (create-process w behavior initial-transition name) (if (not initial-transition) diff --git a/racket/syndicate/ground.rkt b/racket/syndicate/ground.rkt index 110f123..fb7c4f0 100644 --- a/racket/syndicate/ground.rkt +++ b/racket/syndicate/ground.rkt @@ -6,6 +6,7 @@ (require racket/match) (require racket/list) (require "core.rkt") +(require "hierarchy.rkt") (require "trace.rkt") (require "trace/stderr.rkt") (require "tset.rkt") @@ -25,15 +26,15 @@ ;; Any -> Void ;; Sends a message at the ground-VM metalevel. -(define (send-ground-message body) - (async-channel-put (current-ground-event-async-channel) (message body))) +(define (send-ground-message body #:path [path '()]) + (async-channel-put (current-ground-event-async-channel) (target-event path (message body)))) ;; Patch -> Void ;; Injects a patch into the ground-VM metalevel. It will appear to be ;; asserted by the environment in general. The obligation is on the caller ;; to ensure that patches do not interfere between drivers. -(define (send-ground-patch p) - (async-channel-put (current-ground-event-async-channel) p)) +(define (send-ground-patch p #:path [path '()]) + (async-channel-put (current-ground-event-async-channel) (target-event path p))) ;;--------------------------------------------------------------------------- ;; Communication via RacketEvents diff --git a/racket/syndicate/hierarchy.rkt b/racket/syndicate/hierarchy.rkt index ec9d11f..acef897 100644 --- a/racket/syndicate/hierarchy.rkt +++ b/racket/syndicate/hierarchy.rkt @@ -3,13 +3,22 @@ ;; - naming specific actors in traces, or ;; - injecting events from the outside world to specific locations in the tree -(provide current-actor-path-rev +(provide (struct-out targeted-event) + target-event + current-actor-path-rev current-actor-path - call/extended-actor-path - gen:actor-hierarchy-node - actor-hierarchy-node-deliver) + call/extended-actor-path) -(require racket/generic) +;; An event destined for a particular node in the actor hierarchy. +;; Used to inject events from the outside world. +(struct targeted-event (relative-path event) #:prefab) + +;; If a non-null path is provided, wraps event in a targeted-event +;; struct. +(define (target-event relative-path event) + (if (pair? relative-path) + (targeted-event relative-path event) + event)) ;; Parameterof (Listof Any) ;; Path to the active leaf in the process tree. The car end is the @@ -17,7 +26,7 @@ (define current-actor-path-rev (make-parameter '())) ;; Retrieves current-actor-path-rev, but reversed, for use with -;; actor-hierarchy-node-deliver. +;; target-event. (define (current-actor-path) (reverse (current-actor-path-rev))) ;; Any (-> Any) -> Any @@ -25,10 +34,3 @@ (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/stderr.rkt b/racket/syndicate/trace/stderr.rkt index 5541f01..f4ee0f1 100644 --- a/racket/syndicate/trace/stderr.rkt +++ b/racket/syndicate/trace/stderr.rkt @@ -8,6 +8,7 @@ (require racket/exn) (require (only-in racket/string string-join)) (require "../core.rkt") +(require "../hierarchy.rkt") (require "../trace.rkt") (require "../mux.rkt") (require "../pretty.rkt") @@ -104,6 +105,10 @@ [#f (when show-events? (with-color YELLOW (output "~a is being polled for changes.\n" pidstr)))] + [(targeted-event relative-path e) + (when show-events? + (with-color YELLOW + (output "~a is routing an event toward ~a\n" pidstr relative-path)))] [(? patch? p) (when (or show-events? show-patch-events?) (with-color YELLOW @@ -130,6 +135,10 @@ ['boot (when (or show-events? show-boot-events?) (with-color YELLOW (output "~a was booted.\n" pidstr)))] + [(targeted-event relative-path e) + (when show-events? + (with-color YELLOW + (output "~a routed an event toward ~a\n" pidstr relative-path)))] [(? patch? p) (when (exn-and-not (or show-events? show-patch-events?)) (with-color YELLOW @@ -177,6 +186,8 @@ (unless (trie-empty? interests) (output "~a's final interests:\n" pidstr) (pretty-print-trie interests (current-error-port))))] + [(? targeted-event?) + (void)] [(quit-dataspace) (with-color BRIGHT-RED (output "Process ~a performed a quit-dataspace.\n" pidstr))]