Improve comprehensibility of traces
This commit is contained in:
Tony Garnock-Jones
parent
df567e8793
commit
a016a967ef
|
|
@ -151,22 +151,24 @@
|
||||||
(define old-state (hash-ref (world-states w) pid #f))
|
(define old-state (hash-ref (world-states w) pid #f))
|
||||||
(if (not behavior)
|
(if (not behavior)
|
||||||
w
|
w
|
||||||
(invoke-process pid
|
(begin
|
||||||
(lambda () (clean-transition (ensure-transition (behavior e old-state))))
|
(trace-process-step e pid behavior old-state)
|
||||||
(match-lambda
|
(invoke-process pid
|
||||||
[#f w]
|
(lambda () (clean-transition (ensure-transition (behavior e old-state))))
|
||||||
[(and q (quit final-actions))
|
(match-lambda
|
||||||
(trace-process-step e pid behavior old-state #f q)
|
[#f w]
|
||||||
(enqueue-actions (disable-process pid #f w) pid (append final-actions
|
[(and q (quit final-actions))
|
||||||
(list 'quit)))]
|
(trace-process-step-result e pid behavior old-state #f q)
|
||||||
[(and t (transition new-state new-actions))
|
(enqueue-actions (disable-process pid #f w) pid (append final-actions
|
||||||
(trace-process-step e pid behavior old-state #f t)
|
(list 'quit)))]
|
||||||
(enqueue-actions (mark-pid-runnable (update-state w pid new-state) pid)
|
[(and t (transition new-state new-actions))
|
||||||
pid
|
(trace-process-step-result e pid behavior old-state #f t)
|
||||||
new-actions)])
|
(enqueue-actions (mark-pid-runnable (update-state w pid new-state) pid)
|
||||||
(lambda (exn)
|
pid
|
||||||
(trace-process-step e pid behavior old-state exn #f)
|
new-actions)])
|
||||||
(enqueue-actions (disable-process pid exn w) pid (list 'quit))))))
|
(lambda (exn)
|
||||||
|
(trace-process-step-result e pid behavior old-state exn #f)
|
||||||
|
(enqueue-actions (disable-process pid exn w) pid (list 'quit)))))))
|
||||||
|
|
||||||
(define (update-state w pid s)
|
(define (update-state w pid s)
|
||||||
(struct-copy world w [states (hash-set (world-states w) pid s)]))
|
(struct-copy world w [states (hash-set (world-states w) pid s)]))
|
||||||
|
|
@ -277,8 +279,9 @@
|
||||||
(for/fold ([wt (transition (struct-copy world w [pending-action-queue (make-queue)]) '())])
|
(for/fold ([wt (transition (struct-copy world w [pending-action-queue (make-queue)]) '())])
|
||||||
((entry (in-list (queue->list (world-pending-action-queue w)))))
|
((entry (in-list (queue->list (world-pending-action-queue w)))))
|
||||||
(match-define [cons label a] entry)
|
(match-define [cons label a] entry)
|
||||||
|
(trace-internal-action label a (transition-state wt))
|
||||||
(define wt1 (transition-bind (perform-action label a) wt))
|
(define wt1 (transition-bind (perform-action label a) wt))
|
||||||
(trace-internal-step label a (transition-state wt) wt1)
|
(trace-internal-action-result label a (transition-state wt) wt1)
|
||||||
wt1))
|
wt1))
|
||||||
|
|
||||||
(define ((perform-action label a) w)
|
(define ((perform-action label a) w)
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,9 @@
|
||||||
call-in-trace-context
|
call-in-trace-context
|
||||||
|
|
||||||
trace-process-step
|
trace-process-step
|
||||||
trace-internal-step
|
trace-process-step-result
|
||||||
|
trace-internal-action
|
||||||
|
trace-internal-action-result
|
||||||
|
|
||||||
exn->string ;; required from web-server/private/util
|
exn->string ;; required from web-server/private/util
|
||||||
string-indent
|
string-indent
|
||||||
|
|
@ -32,17 +34,25 @@
|
||||||
(when (log-level? trace-logger 'info)
|
(when (log-level? trace-logger 'info)
|
||||||
(log-message trace-logger 'info name "" r #f)))
|
(log-message trace-logger 'info name "" r #f)))
|
||||||
|
|
||||||
|
;; Event PID Process -> Void
|
||||||
|
(define (trace-process-step e pid beh st)
|
||||||
|
(record-trace-event 'process-step (list (cons pid (trace-pid-stack)) e beh st)))
|
||||||
|
|
||||||
;; Event PID Process (Option Exception) (Option Transition) -> Void
|
;; Event PID Process (Option Exception) (Option Transition) -> Void
|
||||||
(define (trace-process-step e pid beh st exn t)
|
(define (trace-process-step-result e pid beh st exn t)
|
||||||
(when exn
|
(when exn
|
||||||
(log-error "Process ~a died with exception:\n~a"
|
(log-error "Process ~a died with exception:\n~a"
|
||||||
(cons pid (trace-pid-stack))
|
(cons pid (trace-pid-stack))
|
||||||
(exn->string exn)))
|
(exn->string exn)))
|
||||||
(record-trace-event 'process-step (list (cons pid (trace-pid-stack)) e beh st exn t)))
|
(record-trace-event 'process-step-result (list (cons pid (trace-pid-stack)) e beh st exn t)))
|
||||||
|
|
||||||
|
;; PID Action World -> Void
|
||||||
|
(define (trace-internal-action pid a w)
|
||||||
|
(record-trace-event 'internal-action (list (cons pid (trace-pid-stack)) a w)))
|
||||||
|
|
||||||
;; PID Action World Transition -> Void
|
;; PID Action World Transition -> Void
|
||||||
(define (trace-internal-step pid a w t)
|
(define (trace-internal-action-result pid a w t)
|
||||||
(record-trace-event 'internal-step (list (cons pid (trace-pid-stack)) a w t)))
|
(record-trace-event 'internal-action-result (list (cons pid (trace-pid-stack)) a w t)))
|
||||||
|
|
||||||
(define (string-indent amount s)
|
(define (string-indent amount s)
|
||||||
(define pad (make-string amount #\space))
|
(define pad (make-string amount #\space))
|
||||||
|
|
|
||||||
|
|
@ -67,7 +67,7 @@
|
||||||
(define (format-pids pids)
|
(define (format-pids pids)
|
||||||
(match pids
|
(match pids
|
||||||
['() "ground"]
|
['() "ground"]
|
||||||
[(cons 'meta rest) (format "boot action of ~a" (format-pids rest))]
|
[(cons 'meta rest) (format "context of ~a" (format-pids rest))]
|
||||||
[_ (string-join (map number->string (reverse pids)) ":")]))
|
[_ (string-join (map number->string (reverse pids)) ":")]))
|
||||||
|
|
||||||
(define (output fmt . args)
|
(define (output fmt . args)
|
||||||
|
|
@ -96,34 +96,55 @@
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(match-define (vector level message-string data event-name) (sync receiver))
|
(match-define (vector level message-string data event-name) (sync receiver))
|
||||||
(match* (event-name data)
|
(match* (event-name data)
|
||||||
[('process-step (list pids e beh st exn t))
|
[('process-step (list pids e beh st))
|
||||||
(define pidstr (format-pids pids))
|
(define pidstr (format-pids pids))
|
||||||
(define relevant-exn? (and show-exceptions? exn))
|
|
||||||
(match e
|
(match e
|
||||||
[#f
|
[#f
|
||||||
(when (or relevant-exn? show-events?)
|
(when show-events?
|
||||||
|
(with-color YELLOW (output "~a is being polled for changes.\n" pidstr)))]
|
||||||
|
[(? 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)
|
||||||
|
(output-state st))))]
|
||||||
|
[('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)))]
|
(with-color YELLOW (output "~a was polled for changes.\n" pidstr)))]
|
||||||
[(? patch? p)
|
[(? patch? p)
|
||||||
(when (or relevant-exn? show-events? show-patch-events?)
|
(when (exn-and-not (or show-events? show-patch-events?))
|
||||||
(with-color YELLOW
|
(with-color YELLOW
|
||||||
(output "~a received a patch:\n" pidstr)
|
(output "~a received a patch:\n" pidstr)
|
||||||
(pretty-print-patch p (current-error-port))))]
|
(pretty-print-patch p (current-error-port))))]
|
||||||
[(message body)
|
[(message body)
|
||||||
(when (or relevant-exn? show-events? show-message-events?)
|
(when (exn-and-not (or show-events? show-message-events?))
|
||||||
(with-color YELLOW
|
(with-color YELLOW
|
||||||
(output "~a received a message:\n" pidstr)
|
(output "~a received a message:\n" pidstr)
|
||||||
(pretty-write body (current-error-port))))])
|
(pretty-write body (current-error-port))))])
|
||||||
(when (or relevant-exn? show-process-states-pre?)
|
(when (exn-and-not (and show-process-states-pre? (not (boring-state? st))))
|
||||||
(when (or relevant-exn? (not (boring-state? st)))
|
(with-color YELLOW
|
||||||
(with-color YELLOW
|
(output "~a's state just before the event:\n" pidstr)
|
||||||
(output "~a's state just before the event:\n" pidstr)
|
(output-state st)))
|
||||||
(output-state st))))
|
|
||||||
(when relevant-exn?
|
(when relevant-exn?
|
||||||
(with-color WHITE-ON-RED
|
(with-color WHITE-ON-RED
|
||||||
(output "Process ~a ~v died with exception:\n~a\n"
|
(output "Process ~a ~v died with exception:\n~a\n"
|
||||||
pidstr
|
pidstr
|
||||||
beh
|
beh
|
||||||
(exn->string exn))))
|
(exn->string exn))))
|
||||||
(when (quit? t)
|
(when (quit? t)
|
||||||
(with-color BRIGHT-RED
|
(with-color BRIGHT-RED
|
||||||
(output "Process ~a ~v exited normally.\n" pidstr beh)))
|
(output "Process ~a ~v exited normally.\n" pidstr beh)))
|
||||||
|
|
@ -132,59 +153,68 @@
|
||||||
(unless (boring-state? (transition-state t))
|
(unless (boring-state? (transition-state t))
|
||||||
(when (not (equal? st (transition-state t)))
|
(when (not (equal? st (transition-state t)))
|
||||||
(with-color YELLOW
|
(with-color YELLOW
|
||||||
(output "~a's state just after the event:\n" pidstr)
|
(output "~a's state just after the event:\n" pidstr)
|
||||||
(output-state (transition-state t)))))))]
|
(output-state (transition-state t)))))))]
|
||||||
[('internal-step (list pids a old-w t))
|
[('internal-action (list pids a old-w))
|
||||||
(when t ;; inert worlds don't change interestingly
|
(define pidstr (format-pids pids))
|
||||||
(define pidstr (format-pids pids))
|
(define oldcount (hash-count (world-behaviors old-w)))
|
||||||
(define new-w (if (transition? t) (transition-state t) old-w))
|
(match a
|
||||||
(define newcount (hash-count (world-behaviors new-w)))
|
[(? spawn?)
|
||||||
(match a
|
;; Handle this in internal-action-result
|
||||||
[(? spawn?)
|
(void)]
|
||||||
(when (or show-process-lifecycle? show-actions?)
|
['quit
|
||||||
(define newpid (set-first (set-subtract (hash-keys (world-behaviors new-w))
|
(when (or show-process-lifecycle? show-actions?)
|
||||||
(hash-keys (world-behaviors old-w)))))
|
(define interests (mux-interests-of (world-mux old-w) (car pids)))
|
||||||
(define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
|
(with-color BRIGHT-RED
|
||||||
|
(output "~a exiting (~a total processes remain)\n"
|
||||||
|
pidstr
|
||||||
|
(- oldcount 1)))
|
||||||
|
(unless (matcher-empty? interests)
|
||||||
|
(output "~a's final interests:\n" pidstr)
|
||||||
|
(pretty-print-matcher interests (current-error-port))))]
|
||||||
|
[(? 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 t
|
||||||
|
(define new-w (transition-state t))
|
||||||
|
(define pidstr (format-pids pids))
|
||||||
|
(define newcount (hash-count (world-behaviors new-w)))
|
||||||
|
(match a
|
||||||
|
[(? spawn?)
|
||||||
|
(when (or show-process-lifecycle? show-actions?)
|
||||||
|
(define newpid (mux-next-pid (world-mux old-w)))
|
||||||
|
(define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
|
||||||
(define interests (mux-interests-of (world-mux new-w) newpid))
|
(define interests (mux-interests-of (world-mux new-w) newpid))
|
||||||
(define behavior (hash-ref (world-behaviors new-w) newpid))
|
(define behavior (hash-ref (world-behaviors new-w) newpid))
|
||||||
(define state (hash-ref (world-states new-w) newpid))
|
(define state (hash-ref (world-states new-w) newpid))
|
||||||
(with-color BRIGHT-GREEN
|
(with-color BRIGHT-GREEN
|
||||||
(output "~a ~v spawned from ~a (~a total processes now)\n"
|
(output "~a ~v spawned from ~a (~a total processes now)\n"
|
||||||
newpidstr
|
newpidstr
|
||||||
behavior
|
behavior
|
||||||
pidstr
|
|
||||||
newcount))
|
|
||||||
(unless (boring-state? state)
|
|
||||||
(output "~a's initial state:\n" newpidstr)
|
|
||||||
(output-state state))
|
|
||||||
(unless (matcher-empty? interests)
|
|
||||||
(output "~a's initial interests:\n" newpidstr)
|
|
||||||
(pretty-print-matcher interests (current-error-port))))]
|
|
||||||
['quit
|
|
||||||
(when (or show-process-lifecycle? show-actions?)
|
|
||||||
(define interests (mux-interests-of (world-mux old-w) (car pids)))
|
|
||||||
(with-color BRIGHT-RED
|
|
||||||
(output "~a exited (~a total processes now)\n"
|
|
||||||
pidstr
|
pidstr
|
||||||
newcount))
|
newcount))
|
||||||
|
(unless (boring-state? state)
|
||||||
|
(output "~a's initial state:\n" newpidstr)
|
||||||
|
(output-state state))
|
||||||
(unless (matcher-empty? interests)
|
(unless (matcher-empty? interests)
|
||||||
(output "~a's final interests:\n" pidstr)
|
(output "~a's initial interests:\n" newpidstr)
|
||||||
(pretty-print-matcher interests (current-error-port))))]
|
(pretty-print-matcher interests (current-error-port))))]
|
||||||
[(? patch? p)
|
[_
|
||||||
(when (or show-actions? show-patch-actions?)
|
;; other cases handled in internal-action
|
||||||
(output "~a performed a patch:\n" pidstr)
|
(void)])
|
||||||
(pretty-print-patch p (current-error-port)))]
|
(when show-routing-table?
|
||||||
[(message body)
|
|
||||||
(when (or show-actions? show-message-actions?)
|
|
||||||
(output "~a sent a message:\n" pidstr)
|
|
||||||
(pretty-write body (current-error-port)))])
|
|
||||||
(when show-routing-table?
|
|
||||||
(define old-table (mux-routing-table (world-mux old-w)))
|
(define old-table (mux-routing-table (world-mux old-w)))
|
||||||
(define new-table (mux-routing-table (world-mux new-w)))
|
(define new-table (mux-routing-table (world-mux new-w)))
|
||||||
(when (not (equal? old-table new-table))
|
(when (not (equal? old-table new-table))
|
||||||
(with-color BRIGHT-BLUE
|
(with-color BRIGHT-BLUE
|
||||||
(output "~a's routing table:\n" (format-pids (cdr pids)))
|
(output "~a's routing table:\n" (format-pids (cdr pids)))
|
||||||
(pretty-print-matcher new-table (current-error-port))))))])
|
(pretty-print-matcher new-table (current-error-port))))))])
|
||||||
(loop))))
|
(loop))))
|
||||||
|
|
||||||
(void (when (not (set-empty? flags))
|
(void (when (not (set-empty? flags))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue