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