Route targeted-events via actor paths
This commit is contained in:
parent
815b139e5c
commit
9b5a399383
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))]
|
||||
|
|
Loading…
Reference in New Issue