Revamp tracing
This commit is contained in:
Tony Garnock-Jones
parent
138bab9ba6
commit
2a6061bd97
|
|
@ -36,28 +36,34 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (send-event e pid w)
|
||||
(match-define (process _ behavior old-state)
|
||||
(define (send-event origin-pid e pid w)
|
||||
(match-define (and the-process (process process-name behavior old-state))
|
||||
(hash-ref (dataspace-process-table w) pid missing-process))
|
||||
(if (not behavior)
|
||||
w
|
||||
(begin
|
||||
(trace-process-step e pid behavior old-state)
|
||||
(when origin-pid (trace-causal-influence origin-pid pid e))
|
||||
(trace-event-consumed pid e)
|
||||
(trace-turn-begin pid the-process)
|
||||
(invoke-process pid
|
||||
(lambda () (clean-transition (ensure-transition (behavior e old-state))))
|
||||
(match-lambda
|
||||
[#f w]
|
||||
[#f
|
||||
(trace-turn-end pid the-process)
|
||||
w]
|
||||
[(and q (<quit> exn final-actions))
|
||||
(trace-process-step-result e pid behavior old-state exn q)
|
||||
(trace-turn-end pid the-process)
|
||||
(trace-actor-exit pid exn)
|
||||
(enqueue-actions (disable-process pid exn w) pid (append final-actions
|
||||
(list 'quit)))]
|
||||
[(and t (transition new-state new-actions))
|
||||
(trace-process-step-result e pid behavior old-state #f t)
|
||||
(trace-turn-end pid (process process-name behavior new-state))
|
||||
(enqueue-actions (mark-pid-runnable (update-state w pid new-state) pid)
|
||||
pid
|
||||
new-actions)])
|
||||
(lambda (exn)
|
||||
(trace-process-step-result e pid behavior old-state exn #f)
|
||||
(trace-turn-end pid the-process)
|
||||
(trace-actor-exit pid exn)
|
||||
(enqueue-actions (disable-process pid exn w) pid (list 'quit)))))))
|
||||
|
||||
(define (update-process-entry w pid f)
|
||||
|
|
@ -69,10 +75,10 @@
|
|||
(define (update-state w pid s)
|
||||
(update-process-entry w pid (lambda (p) (update-process-state p s))))
|
||||
|
||||
(define (send-event/guard e pid w)
|
||||
(define (send-event/guard origin-pid e pid w)
|
||||
(if (patch-empty? e)
|
||||
w
|
||||
(send-event e pid w)))
|
||||
(send-event origin-pid e pid w)))
|
||||
|
||||
(define (disable-process pid exn w)
|
||||
(when exn
|
||||
|
|
@ -144,9 +150,8 @@
|
|||
((entry (in-list (queue->list (dataspace-pending-action-queue w)))))
|
||||
#:break (quit? wt) ;; TODO: should a quit action be delayed until the end of the turn?
|
||||
(match-define [cons label a] entry)
|
||||
(trace-internal-action label a (transition-state wt))
|
||||
(when (or (event? a) (eq? a 'quit)) (trace-action-produced label a))
|
||||
(define wt1 (transition-bind (perform-action label a) wt))
|
||||
(trace-internal-action-result label a (transition-state wt) wt1)
|
||||
wt1))
|
||||
|
||||
(define ((perform-action label a) w)
|
||||
|
|
@ -163,7 +168,7 @@
|
|||
other)]))
|
||||
(lambda (results)
|
||||
(match-define (list behavior initial-transition name) results)
|
||||
(create-process w behavior initial-transition name))
|
||||
(create-process label w behavior initial-transition name))
|
||||
(lambda (exn)
|
||||
(log-error "Spawned process in dataspace ~a died with exception:\n~a"
|
||||
(current-actor-path)
|
||||
|
|
@ -188,12 +193,12 @@
|
|||
(append (current-actor-path) (list label))
|
||||
body))
|
||||
(define-values (affected-pids meta-affected?) (mux-route-message (dataspace-mux w) body))
|
||||
(transition (for/fold [(w w)] [(pid (in-list affected-pids))] (send-event m pid w))
|
||||
(transition (for/fold [(w w)] [(pid (in-list affected-pids))] (send-event label m pid w))
|
||||
(and meta-affected? m))]
|
||||
[(targeted-event (cons pid remaining-path) e)
|
||||
(transition (send-event/guard (target-event remaining-path e) pid w) '())]))
|
||||
(transition (send-event/guard label (target-event remaining-path e) pid w) '())]))
|
||||
|
||||
(define (create-process w behavior initial-transition name)
|
||||
(define (create-process parent-label w behavior initial-transition name)
|
||||
(if (not initial-transition)
|
||||
(transition w '()) ;; Uh, ok
|
||||
(let ()
|
||||
|
|
@ -201,13 +206,14 @@
|
|||
(match (clean-transition initial-transition)
|
||||
[(and q (<quit> exn initial-actions0))
|
||||
(values (lambda (w pid)
|
||||
(trace-process-step-result 'boot pid behavior (void) exn q)
|
||||
(trace-actor-spawn parent-label pid (process name behavior (void)))
|
||||
(trace-actor-exit pid exn)
|
||||
(disable-process pid exn w))
|
||||
#f
|
||||
(append initial-actions0 (list 'quit)))]
|
||||
[(and t (transition initial-state initial-actions0))
|
||||
(values (lambda (w pid)
|
||||
(trace-process-step-result 'boot pid behavior (void) #f t)
|
||||
(trace-actor-spawn parent-label pid (process name behavior initial-state))
|
||||
(mark-pid-runnable w pid))
|
||||
initial-state
|
||||
initial-actions0)]))
|
||||
|
|
@ -217,6 +223,7 @@
|
|||
[other (values patch-empty other)]))
|
||||
(define-values (new-mux new-pid delta delta-aggregate)
|
||||
(mux-add-stream (dataspace-mux w) initial-patch))
|
||||
(trace-action-produced new-pid initial-patch)
|
||||
(let* ((w (struct-copy dataspace w
|
||||
[process-table (hash-set (dataspace-process-table w)
|
||||
new-pid
|
||||
|
|
@ -232,7 +239,7 @@
|
|||
(transition (for/fold [(w (struct-copy dataspace w [mux new-mux]))]
|
||||
[(entry (in-list patches))]
|
||||
(match-define (cons label event) entry)
|
||||
(send-event/guard event label w))
|
||||
(send-event/guard acting-label event label w))
|
||||
(and (patch-non-empty? meta-action) meta-action)))
|
||||
|
||||
(define (step-children w)
|
||||
|
|
@ -241,7 +248,7 @@
|
|||
#f ;; dataspace is inert.
|
||||
(transition (for/fold [(w (struct-copy dataspace w [runnable-pids (set)]))]
|
||||
[(pid (in-set runnable-pids))]
|
||||
(send-event #f pid w))
|
||||
(send-event #f #f pid w))
|
||||
'())))
|
||||
|
||||
(define (pretty-print-dataspace w [p (current-output-port)])
|
||||
|
|
|
|||
|
|
@ -120,21 +120,24 @@
|
|||
|
||||
;; Event Process AssertionSet Natural -> Void
|
||||
(define (inject-event e proc interests background-activity-count)
|
||||
(trace-process-step e #f (process-behavior proc) (process-state proc))
|
||||
(trace-event-consumed #f e)
|
||||
(trace-turn-begin #f proc)
|
||||
(define resulting-transition (clean-transition ((process-behavior proc) e (process-state proc))))
|
||||
(trace-process-step-result e #f (process-behavior proc) (process-state proc)
|
||||
#f resulting-transition)
|
||||
(process-transition resulting-transition proc interests background-activity-count))
|
||||
|
||||
;; Transition Process AssertionSet Natural -> Void
|
||||
(define (process-transition resulting-transition proc interests background-activity-count)
|
||||
(match resulting-transition
|
||||
[#f ;; inert
|
||||
(trace-turn-end #f proc)
|
||||
(await-interrupt #t proc interests background-activity-count)]
|
||||
[(<quit> _ _)
|
||||
[(<quit> exn _)
|
||||
(trace-turn-end #f proc)
|
||||
(trace-actor-exit #f exn)
|
||||
(log-info "run-ground: Terminating by request")
|
||||
(void)]
|
||||
[(transition new-state actions)
|
||||
(trace-turn-end #f (process (process-name proc) (process-behavior proc) new-state))
|
||||
(let ((proc (update-process-state proc new-state)))
|
||||
(let process-actions ((actions actions) (interests interests))
|
||||
(match actions
|
||||
|
|
|
|||
|
|
@ -18,7 +18,6 @@
|
|||
(require racket/match)
|
||||
(require "trie.rkt")
|
||||
(require "patch.rkt")
|
||||
(require "trace.rkt")
|
||||
(require "tset.rkt")
|
||||
(require "pretty.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,37 +1,91 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide trace-logger
|
||||
trace-process-step
|
||||
trace-process-step-result
|
||||
trace-internal-action
|
||||
trace-internal-action-result)
|
||||
trace-turn-begin
|
||||
trace-turn-end
|
||||
trace-actor-spawn
|
||||
trace-actor-exit
|
||||
trace-action-produced
|
||||
trace-event-consumed
|
||||
trace-causal-influence
|
||||
|
||||
(struct-out trace-notification))
|
||||
|
||||
(require "hierarchy.rkt")
|
||||
(require "pretty.rkt")
|
||||
|
||||
(define trace-logger (make-logger 'minimart-trace))
|
||||
;; A NotificationType is one of
|
||||
;; -- 'turn-begin
|
||||
;; -- 'turn-end
|
||||
;; -- 'spawn
|
||||
;; -- 'exit
|
||||
;; -- 'action
|
||||
;; -- 'event
|
||||
;; -- 'influence
|
||||
;;
|
||||
;; The trace-notification-detail field is used differently for each
|
||||
;; NotificationType:
|
||||
;; -- 'turn-begin and 'turn-end --> Process
|
||||
;; -- 'spawn --> (cons PID Process), the parent's PID and the process' initial state
|
||||
;; -- 'exit --> Option Exception
|
||||
;; -- 'action --> (U Event 'quit) (notably, spawns are handled otherwise)
|
||||
;; -- 'event --> Event
|
||||
;; -- 'influence --> Event
|
||||
;;
|
||||
;; The source and sink fields both hold values of type ActorPath. They
|
||||
;; are, again, used differently for each NotificationType:
|
||||
;; -- 'turn-begin --> source is dataspace; sink the process whose turn it is
|
||||
;; -- 'turn-end --> source is dataspace; sink the process whose turn it was
|
||||
;; -- 'spawn --> source is dataspace; sink the new process
|
||||
;; -- 'exit --> source is dataspace; sink the exiting process
|
||||
;; -- 'action --> source is acting process; sink is dataspace (NB: Flipped!)
|
||||
;; -- 'event --> source is dataspace; sink is receiving process
|
||||
;; -- 'influence --> source is acting process; sink is receiving process
|
||||
;;
|
||||
;; For 'influence, when the detail event is a patch, the source field
|
||||
;; is not always the true influencing party. In the case where a
|
||||
;; process adds new observe assertions to a dataspace where matching
|
||||
;; assertions already exist, it will appear to "influence itself".
|
||||
;; Really, with patches, it's the PIDs at the leaves of each patch's
|
||||
;; tries that are the influencers.
|
||||
|
||||
(define-syntax-rule (record-trace-event name r)
|
||||
(struct trace-notification (source sink type detail) #:prefab)
|
||||
|
||||
(define trace-logger (make-logger 'syndicate-trace))
|
||||
|
||||
(define-syntax-rule (notify! src snk typ det)
|
||||
(when (log-level? trace-logger 'info)
|
||||
(log-message trace-logger 'info name "" r #f)))
|
||||
(log-message trace-logger 'info typ "" (trace-notification src snk typ det) #f)))
|
||||
|
||||
(define (cons-pid pid)
|
||||
(if pid
|
||||
(cons pid (current-actor-path-rev))
|
||||
(current-actor-path-rev)))
|
||||
|
||||
;; Event (Option PID) Process -> Void
|
||||
(define (trace-process-step e pid beh st)
|
||||
(record-trace-event 'process-step (list (cons-pid pid) e beh st)))
|
||||
;; PID Process
|
||||
(define (trace-turn-begin pid p)
|
||||
(notify! (current-actor-path-rev) (cons-pid pid) 'turn-begin p))
|
||||
|
||||
;; Event (Option PID) Process (Option Exception) (Option Transition) -> Void
|
||||
(define (trace-process-step-result e pid beh st exn t)
|
||||
(record-trace-event 'process-step-result (list (cons-pid pid) e beh st exn t)))
|
||||
;; PID Process
|
||||
(define (trace-turn-end pid p)
|
||||
(notify! (current-actor-path-rev) (cons-pid pid) 'turn-end p))
|
||||
|
||||
;; (Option PID) Action Dataspace -> Void
|
||||
(define (trace-internal-action pid a w)
|
||||
(record-trace-event 'internal-action (list (cons-pid pid) a w)))
|
||||
;; PID PID Process
|
||||
(define (trace-actor-spawn parent-pid pid p)
|
||||
(notify! (current-actor-path-rev) (cons-pid pid) 'spawn (cons (cons-pid parent-pid) p)))
|
||||
|
||||
;; (Option PID) Action Dataspace Transition -> Void
|
||||
(define (trace-internal-action-result pid a w t)
|
||||
(record-trace-event 'internal-action-result (list (cons-pid pid) a w t)))
|
||||
;; PID (Option Exception)
|
||||
(define (trace-actor-exit pid maybe-exn)
|
||||
(notify! (current-actor-path-rev) (cons-pid pid) 'exit maybe-exn))
|
||||
|
||||
;; PID Event
|
||||
(define (trace-action-produced pid e)
|
||||
(notify! (cons-pid pid) (current-actor-path-rev) 'action e))
|
||||
|
||||
;; PID Event
|
||||
(define (trace-event-consumed pid e)
|
||||
(notify! (current-actor-path-rev) (cons-pid pid) 'event e))
|
||||
|
||||
;; PID PID Event
|
||||
(define (trace-causal-influence src-pid snk-pid e)
|
||||
(notify! (cons-pid src-pid) (cons-pid snk-pid) 'influence e))
|
||||
|
|
|
|||
|
|
@ -13,6 +13,8 @@
|
|||
(require "../trace.rkt")
|
||||
(require "../mux.rkt")
|
||||
(require "../pretty.rkt")
|
||||
(require "../trie.rkt")
|
||||
(require "../tset.rkt")
|
||||
|
||||
(define (env-aref varname default alist)
|
||||
(define key (or (getenv varname) default))
|
||||
|
|
@ -22,42 +24,30 @@
|
|||
(map car alist)
|
||||
key)]))
|
||||
|
||||
(define colored-output? (env-aref "MINIMART_COLOR" "true" '(("true" #t) ("false" #f))))
|
||||
(define colored-output? (env-aref "SYNDICATE_COLOR" "true" '(("true" #t) ("false" #f))))
|
||||
|
||||
(define flags (set))
|
||||
(define show-exceptions? #f)
|
||||
(define show-patch-events? #f)
|
||||
(define show-message-events? #f)
|
||||
(define show-boot-events? #f)
|
||||
(define show-events? #f)
|
||||
(define show-process-states-pre? #f)
|
||||
(define show-process-states-post? #f)
|
||||
(define show-process-lifecycle? #f)
|
||||
(define show-patch-actions? #f)
|
||||
(define show-message-actions? #f)
|
||||
(define show-turns? #f)
|
||||
(define show-lifecycle? #f)
|
||||
(define show-actions? #f)
|
||||
(define show-routing-table? #f)
|
||||
(define dataspace-is-boring? #t)
|
||||
(define show-events? #f)
|
||||
(define show-influence? #f)
|
||||
|
||||
(define (set-stderr-trace-flags! flags-string)
|
||||
(define A-flags (set 'x 'i 'p))
|
||||
(set! flags (for/set [(c flags-string)] (string->symbol (string c))))
|
||||
(define-syntax-rule (set-flag! symbol variable)
|
||||
(set! variable (set-member? flags 'symbol)))
|
||||
(set! variable (or (and (set-member? flags 'A) (set-member? A-flags 'symbol))
|
||||
(set-member? flags 'symbol))))
|
||||
(set-flag! x show-exceptions?)
|
||||
(set-flag! r show-patch-events?)
|
||||
(set-flag! m show-message-events?)
|
||||
(set-flag! b show-boot-events?)
|
||||
(set-flag! e show-events?)
|
||||
(set-flag! s show-process-states-pre?)
|
||||
(set-flag! t show-process-states-post?)
|
||||
(set-flag! p show-process-lifecycle?)
|
||||
(set-flag! R show-patch-actions?)
|
||||
(set-flag! M show-message-actions?)
|
||||
(set-flag! t show-turns?)
|
||||
(set-flag! p show-lifecycle?)
|
||||
(set-flag! a show-actions?)
|
||||
(set-flag! g show-routing-table?)
|
||||
(set! dataspace-is-boring? (not (set-member? flags 'N))))
|
||||
(set-flag! e show-events?)
|
||||
(set-flag! i show-influence?))
|
||||
|
||||
(set-stderr-trace-flags! (or (getenv "MINIMART_TRACE") ""))
|
||||
(set-stderr-trace-flags! (or (getenv "SYNDICATE_TRACE") ""))
|
||||
|
||||
(define YELLOW-ON-RED ";1;33;41")
|
||||
(define WHITE-ON-RED ";1;37;41")
|
||||
|
|
@ -73,19 +63,19 @@
|
|||
(define BRIGHT-BLUE ";1;34")
|
||||
(define NORMAL "")
|
||||
|
||||
(define (format-pids pids)
|
||||
(match pids
|
||||
['() "ground"]
|
||||
[(cons 'meta rest) (format "context of ~a" (format-pids rest))]
|
||||
[_ (string-join (map number->string (reverse pids)) ":")]))
|
||||
(define (format-pids pids [name #f])
|
||||
(define pidstr
|
||||
(match pids
|
||||
['() "ground"]
|
||||
[(cons 'meta rest) (format "context of ~a" (format-pids rest))]
|
||||
[_ (string-join (map number->string (reverse pids)) ":")]))
|
||||
(if name
|
||||
(format "~a a.k.a ~v" pidstr name)
|
||||
pidstr))
|
||||
|
||||
(define (output fmt . args)
|
||||
(apply fprintf (current-error-port) fmt args))
|
||||
|
||||
(define (boring-state? state)
|
||||
(or (and (dataspace? state) dataspace-is-boring?)
|
||||
(void? state)))
|
||||
|
||||
(define (set-color! c) (when colored-output? (output "\e[0~am" c)))
|
||||
(define (reset-color!) (when colored-output? (output "\e[0m")))
|
||||
|
||||
|
|
@ -94,148 +84,82 @@
|
|||
(begin0 (begin expr ...)
|
||||
(reset-color!))))
|
||||
|
||||
(define (tset/set-union t s)
|
||||
(set-union (list->set (tset->list t)) s))
|
||||
|
||||
(define (extract-leaf-pids sink p)
|
||||
(match-define (patch added removed) p)
|
||||
(for/list [(pid (in-set (trie-value-fold tset/set-union
|
||||
(trie-value-fold tset/set-union (set) added)
|
||||
removed)))]
|
||||
(cons pid (cdr sink))))
|
||||
|
||||
(define (display-notification the-notification)
|
||||
(match-define (trace-notification source sink type detail) the-notification)
|
||||
(match* (type detail)
|
||||
[('turn-begin (process name _beh state))
|
||||
(when show-turns?
|
||||
(with-color BLUE
|
||||
(output "~a turn begins\n" (format-pids sink name))))]
|
||||
[('turn-end (process name _beh state))
|
||||
(when show-turns?
|
||||
(with-color BLUE
|
||||
(output "~a turn ends\n" (format-pids sink name))
|
||||
(syndicate-pretty-print state (current-error-port))))]
|
||||
[('spawn (cons parent (process name _beh state)))
|
||||
(when show-lifecycle?
|
||||
(with-color BRIGHT-GREEN
|
||||
(output "~a spawned by ~a\n" (format-pids sink name) (format-pids parent))))]
|
||||
[('exit #f)
|
||||
(when show-lifecycle?
|
||||
(with-color BRIGHT-RED
|
||||
(output "~a schedules an exit\n" (format-pids sink))))]
|
||||
[('exit exn)
|
||||
(when (or show-lifecycle? show-exceptions?)
|
||||
(with-color WHITE-ON-RED
|
||||
(output "~a raises an exception:\n~a\n" (format-pids sink) (exn->string exn))))]
|
||||
[('action (? patch? p))
|
||||
(when show-actions?
|
||||
(output "~a performs a patch:\n~a\n" (format-pids source) (patch->pretty-string p)))]
|
||||
[('action (message body))
|
||||
(when show-actions?
|
||||
(output "~a broadcasts a message:\n~a\n" (format-pids source) (pretty-format body)))]
|
||||
[('action 'quit)
|
||||
(when show-lifecycle?
|
||||
(with-color BRIGHT-RED
|
||||
(output "~a exits\n" (format-pids source))))]
|
||||
[('event (? patch? p))
|
||||
(when show-events?
|
||||
(with-color YELLOW
|
||||
(output "~a receives an event:\n~a\n" (format-pids sink) (patch->pretty-string p))))]
|
||||
[('event (message body))
|
||||
(when show-events?
|
||||
(with-color YELLOW
|
||||
(output "~a receives a message:\n~a\n" (format-pids sink) (pretty-format body))))]
|
||||
[('event #f)
|
||||
(when show-events?
|
||||
(with-color YELLOW
|
||||
(output "~a is polled\n" (format-pids sink))))]
|
||||
[('influence (? patch? p))
|
||||
(when show-influence?
|
||||
(output "~a influenced by ~a via a patch:\n~a\n"
|
||||
(format-pids sink)
|
||||
(string-join (map format-pids (extract-leaf-pids sink p)) ", ")
|
||||
(patch->pretty-string p)))]
|
||||
[('influence (message body))
|
||||
(when show-influence?
|
||||
(output "~a influences ~a with a message:\n~a\n"
|
||||
(format-pids source)
|
||||
(format-pids sink)
|
||||
(pretty-format body)))]))
|
||||
|
||||
(define (display-trace)
|
||||
(define receiver (make-log-receiver trace-logger 'info))
|
||||
(parameterize ((pretty-print-columns 100))
|
||||
(let loop ()
|
||||
(match-define (vector level message-string data event-name) (sync receiver))
|
||||
(match* (event-name data)
|
||||
[('process-step (list pids e beh st))
|
||||
(define pidstr (format-pids pids))
|
||||
(match e
|
||||
[#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
|
||||
(output "~a is receiving a patch:\n" pidstr)
|
||||
(pretty-print-patch p (current-error-port))))]
|
||||
[(message body)
|
||||
(when (or show-events? show-message-events?)
|
||||
(with-color YELLOW
|
||||
(output "~a is receiving a message:\n" pidstr)
|
||||
(pretty-write body (current-error-port))))])
|
||||
(when show-process-states-pre?
|
||||
(when (not (boring-state? st))
|
||||
(with-color YELLOW
|
||||
(output "~a's state just before the event:\n" pidstr)
|
||||
(syndicate-pretty-print st (current-error-port)))))]
|
||||
[('process-step-result (list pids e beh st exn t))
|
||||
(define pidstr (format-pids pids))
|
||||
(define relevant-exn? (and show-exceptions? exn))
|
||||
(define (exn-and-not b) (and relevant-exn? (not b)))
|
||||
(match e
|
||||
[#f
|
||||
(when (exn-and-not show-events?)
|
||||
(with-color YELLOW (output "~a was polled for changes.\n" pidstr)))]
|
||||
['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
|
||||
(output "~a received a patch:\n" pidstr)
|
||||
(pretty-print-patch p (current-error-port))))]
|
||||
[(message body)
|
||||
(when (exn-and-not (or show-events? show-message-events?))
|
||||
(with-color YELLOW
|
||||
(output "~a received a message:\n" pidstr)
|
||||
(pretty-write body (current-error-port))))])
|
||||
(when (exn-and-not (and show-process-states-pre? (not (boring-state? st))))
|
||||
(with-color YELLOW
|
||||
(output "~a's state just before the event:\n" pidstr)
|
||||
(syndicate-pretty-print st (current-error-port))))
|
||||
(when relevant-exn?
|
||||
(with-color WHITE-ON-RED
|
||||
(output "Process ~a ~v died with exception:\n~a\n"
|
||||
pidstr
|
||||
beh
|
||||
(exn->string exn))))
|
||||
(when (quit? t)
|
||||
(with-color BRIGHT-RED
|
||||
(output "Process ~a ~v exited normally.\n" pidstr beh)))
|
||||
(when (or relevant-exn? show-process-states-post?)
|
||||
(when (transition? t)
|
||||
(unless (boring-state? (transition-state t))
|
||||
(when (not (equal? st (transition-state t)))
|
||||
(with-color YELLOW
|
||||
(output "~a's state just after the event:\n" pidstr)
|
||||
(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-process-table old-w)))
|
||||
(match a
|
||||
[(? spawn?)
|
||||
;; Handle this in internal-action-result
|
||||
(void)]
|
||||
['quit
|
||||
(when (or show-process-lifecycle? show-actions?)
|
||||
(define interests (mux-interests-of (dataspace-mux old-w) (car pids)))
|
||||
(with-color BRIGHT-RED
|
||||
(output "~a exiting (~a total processes remain)\n"
|
||||
pidstr
|
||||
(- oldcount 1)))
|
||||
(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))]
|
||||
[(? patch? p)
|
||||
(when (or show-actions? show-patch-actions?)
|
||||
(output "~a performing a patch:\n" pidstr)
|
||||
(pretty-print-patch p (current-error-port)))]
|
||||
[(message body)
|
||||
(when (or show-actions? show-message-actions?)
|
||||
(output "~a sending a message:\n" pidstr)
|
||||
(pretty-write body (current-error-port)))])]
|
||||
[('internal-action-result (list pids a old-w t))
|
||||
(when (transition? t)
|
||||
(define new-w (transition-state t))
|
||||
(define pidstr (format-pids pids))
|
||||
(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 info (hash-ref (dataspace-process-table new-w) newpid '#:missing-behavior))
|
||||
(define state (if (process? info) (process-state info) '#:missing-state))
|
||||
(with-color BRIGHT-GREEN
|
||||
(output "~a ~v spawned from ~a (~a total processes now)\n"
|
||||
newpidstr
|
||||
info
|
||||
pidstr
|
||||
newcount))
|
||||
(unless (boring-state? state)
|
||||
(output "~a's initial state:\n" newpidstr)
|
||||
(syndicate-pretty-print state (current-error-port)))
|
||||
(unless (trie-empty? interests)
|
||||
(output "~a's initial interests:\n" newpidstr)
|
||||
(pretty-print-trie interests (current-error-port))))]
|
||||
[_
|
||||
;; other cases handled in internal-action
|
||||
(void)])
|
||||
(when show-routing-table?
|
||||
(define old-table (mux-routing-table (dataspace-mux old-w)))
|
||||
(define new-table (mux-routing-table (dataspace-mux new-w)))
|
||||
(when (not (equal? old-table new-table))
|
||||
(with-color BRIGHT-BLUE
|
||||
(output "~a's routing table:\n" (format-pids (cdr pids)))
|
||||
(pretty-print-trie new-table (current-error-port))))))])
|
||||
(display-notification data)
|
||||
(loop))))
|
||||
|
||||
(void (when (not (set-empty? flags))
|
||||
(void (when (not #f) ;; TODO
|
||||
(thread display-trace)))
|
||||
|
|
|
|||
|
|
@ -64,6 +64,8 @@
|
|||
trie-project/set/single
|
||||
project-assertions
|
||||
|
||||
trie-value-fold
|
||||
|
||||
pretty-print-trie
|
||||
trie->pretty-string
|
||||
trie->abstract-graph
|
||||
|
|
@ -911,6 +913,21 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (trie-value-fold kons seed m)
|
||||
(let walk ((seed seed) (m m))
|
||||
(match m
|
||||
[(? trie-empty?) seed]
|
||||
[(success v) (kons v seed)]
|
||||
[(branch os w h)
|
||||
(let* ((seed (walk seed w))
|
||||
(seed (for/fold [(seed seed)] [(entry (in-list (treap-to-alist os)))]
|
||||
(walk seed (cdr entry))))
|
||||
(seed (for/fold [(seed seed)] [(k (in-list (treap-values h)))]
|
||||
(walk seed k))))
|
||||
seed)])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; TODO: if we don't collapse the success-paths that the failure-paths
|
||||
;; are taking chunks out of, is it even worth returning the
|
||||
;; failure-paths? i.e. this function might be silly as written
|
||||
|
|
|
|||
Loading…
Reference in New Issue