2015-03-05 14:54:12 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
|
|
|
(provide set-stderr-trace-flags!)
|
|
|
|
|
|
|
|
(require racket/set)
|
|
|
|
(require racket/match)
|
|
|
|
(require racket/pretty)
|
|
|
|
(require (only-in racket/string string-join))
|
2015-05-23 15:41:43 +00:00
|
|
|
(require "../exn-util.rkt")
|
2015-03-05 14:54:12 +00:00
|
|
|
(require "../core.rkt")
|
|
|
|
(require "../trace.rkt")
|
2015-03-16 14:38:32 +00:00
|
|
|
(require "../mux.rkt")
|
2015-05-11 22:25:21 +00:00
|
|
|
(require "../endpoint.rkt")
|
|
|
|
(require "../pretty.rkt")
|
2015-03-05 14:54:12 +00:00
|
|
|
|
|
|
|
(define (env-aref varname default alist)
|
|
|
|
(define key (or (getenv varname) default))
|
|
|
|
(cond [(assoc key alist) => cadr]
|
|
|
|
[else (error 'env-aref
|
|
|
|
"Expected environment variable ~a to contain one of ~v; got ~v"
|
|
|
|
(map car alist)
|
|
|
|
key)]))
|
|
|
|
|
|
|
|
(define colored-output? (env-aref "MINIMART_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-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-actions? #f)
|
|
|
|
(define show-routing-table? #f)
|
2015-03-21 21:30:48 +00:00
|
|
|
(define world-is-boring? #t)
|
2015-03-05 14:54:12 +00:00
|
|
|
|
|
|
|
(define (set-stderr-trace-flags! flags-string)
|
|
|
|
(set! flags (for/set [(c flags-string)] (string->symbol (string c))))
|
|
|
|
(set! show-exceptions? (set-member? flags 'x))
|
|
|
|
(set! show-patch-events? (set-member? flags 'r))
|
|
|
|
(set! show-message-events? (set-member? flags 'm))
|
|
|
|
(set! show-events? (set-member? flags 'e))
|
|
|
|
(set! show-process-states-pre? (set-member? flags 's))
|
|
|
|
(set! show-process-states-post? (set-member? flags 't))
|
|
|
|
(set! show-process-lifecycle? (set-member? flags 'p))
|
|
|
|
(set! show-patch-actions? (set-member? flags 'R))
|
|
|
|
(set! show-message-actions? (set-member? flags 'M))
|
|
|
|
(set! show-actions? (set-member? flags 'a))
|
2015-03-21 21:30:48 +00:00
|
|
|
(set! show-routing-table? (set-member? flags 'g))
|
|
|
|
(set! world-is-boring? (not (set-member? flags 'W))))
|
2015-03-05 14:54:12 +00:00
|
|
|
|
|
|
|
(set-stderr-trace-flags! (or (getenv "MINIMART_TRACE") ""))
|
|
|
|
|
|
|
|
(define YELLOW-ON-RED ";1;33;41")
|
|
|
|
(define WHITE-ON-RED ";1;37;41")
|
|
|
|
(define WHITE-ON-GREEN ";1;37;42")
|
|
|
|
(define GREY-ON-RED ";37;41")
|
|
|
|
(define GREY-ON-GREEN ";37;42")
|
|
|
|
(define RED ";31")
|
|
|
|
(define BRIGHT-RED ";1;31")
|
|
|
|
(define GREEN ";32")
|
|
|
|
(define BRIGHT-GREEN ";1;32")
|
|
|
|
(define YELLOW ";33")
|
|
|
|
(define BLUE ";34")
|
|
|
|
(define BRIGHT-BLUE ";1;34")
|
|
|
|
(define NORMAL "")
|
|
|
|
|
|
|
|
(define (format-pids pids)
|
|
|
|
(match pids
|
|
|
|
['() "ground"]
|
2015-03-21 16:30:10 +00:00
|
|
|
[(cons 'meta rest) (format "context of ~a" (format-pids rest))]
|
2015-03-05 14:54:12 +00:00
|
|
|
[_ (string-join (map number->string (reverse pids)) ":")]))
|
|
|
|
|
|
|
|
(define (output fmt . args)
|
|
|
|
(apply fprintf (current-error-port) fmt args))
|
|
|
|
|
|
|
|
(define (boring-state? state)
|
2015-03-21 21:30:48 +00:00
|
|
|
(or (and (world? state) world-is-boring?)
|
2015-03-05 14:54:12 +00:00
|
|
|
(void? state)))
|
|
|
|
|
|
|
|
(define (set-color! c) (when colored-output? (output "\e[0~am" c)))
|
|
|
|
(define (reset-color!) (when colored-output? (output "\e[0m")))
|
|
|
|
|
|
|
|
(define-syntax-rule (with-color c expr ...)
|
|
|
|
(begin (set-color! c)
|
|
|
|
(begin0 (begin expr ...)
|
|
|
|
(reset-color!))))
|
|
|
|
|
|
|
|
(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)
|
2015-03-21 16:30:10 +00:00
|
|
|
[('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)))]
|
|
|
|
[(? 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)
|
2015-05-11 22:25:21 +00:00
|
|
|
(prospect-pretty-print st (current-error-port)))))]
|
2015-03-21 16:30:10 +00:00
|
|
|
[('process-step-result (list pids e beh st exn t))
|
2015-03-05 14:54:12 +00:00
|
|
|
(define pidstr (format-pids pids))
|
|
|
|
(define relevant-exn? (and show-exceptions? exn))
|
2015-03-21 16:30:10 +00:00
|
|
|
(define (exn-and-not b) (and relevant-exn? (not b)))
|
2015-03-05 14:54:12 +00:00
|
|
|
(match e
|
|
|
|
[#f
|
2015-03-21 16:30:10 +00:00
|
|
|
(when (exn-and-not show-events?)
|
2015-03-05 14:54:12 +00:00
|
|
|
(with-color YELLOW (output "~a was polled for changes.\n" pidstr)))]
|
|
|
|
[(? patch? p)
|
2015-03-21 16:30:10 +00:00
|
|
|
(when (exn-and-not (or show-events? show-patch-events?))
|
2015-03-05 14:54:12 +00:00
|
|
|
(with-color YELLOW
|
2015-03-21 16:30:10 +00:00
|
|
|
(output "~a received a patch:\n" pidstr)
|
|
|
|
(pretty-print-patch p (current-error-port))))]
|
2015-03-05 14:54:12 +00:00
|
|
|
[(message body)
|
2015-03-21 16:30:10 +00:00
|
|
|
(when (exn-and-not (or show-events? show-message-events?))
|
2015-03-05 14:54:12 +00:00
|
|
|
(with-color YELLOW
|
2015-03-21 16:30:10 +00:00
|
|
|
(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)
|
2015-05-11 22:25:21 +00:00
|
|
|
(prospect-pretty-print st (current-error-port))))
|
2015-03-05 14:54:12 +00:00
|
|
|
(when relevant-exn?
|
|
|
|
(with-color WHITE-ON-RED
|
2015-03-21 16:30:10 +00:00
|
|
|
(output "Process ~a ~v died with exception:\n~a\n"
|
|
|
|
pidstr
|
|
|
|
beh
|
|
|
|
(exn->string exn))))
|
2015-03-06 11:21:50 +00:00
|
|
|
(when (quit? t)
|
|
|
|
(with-color BRIGHT-RED
|
2015-03-16 14:38:32 +00:00
|
|
|
(output "Process ~a ~v exited normally.\n" pidstr beh)))
|
2015-03-05 14:54:12 +00:00
|
|
|
(when (or relevant-exn? show-process-states-post?)
|
2015-03-06 11:21:50 +00:00
|
|
|
(when (transition? t)
|
2015-03-05 14:54:12 +00:00
|
|
|
(unless (boring-state? (transition-state t))
|
2015-03-16 14:38:32 +00:00
|
|
|
(when (not (equal? st (transition-state t)))
|
2015-03-05 14:54:12 +00:00
|
|
|
(with-color YELLOW
|
2015-03-21 16:30:10 +00:00
|
|
|
(output "~a's state just after the event:\n" pidstr)
|
2015-05-11 22:25:21 +00:00
|
|
|
(prospect-pretty-print (transition-state t) (current-error-port)))))))]
|
2015-03-21 16:30:10 +00:00
|
|
|
[('internal-action (list pids a old-w))
|
|
|
|
(define pidstr (format-pids pids))
|
|
|
|
(define oldcount (hash-count (world-behaviors 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 (world-mux old-w) (car pids)))
|
|
|
|
(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))))]
|
2015-10-23 23:49:30 +00:00
|
|
|
[(quit-world)
|
|
|
|
(with-color BRIGHT-RED
|
|
|
|
(output "Process ~a performed a quit-world.\n" pidstr))]
|
2015-03-21 16:30:10 +00:00
|
|
|
[(? 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))
|
2015-10-23 23:49:30 +00:00
|
|
|
(when (transition? t)
|
2015-03-21 16:30:10 +00:00
|
|
|
(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
|
2015-03-16 14:38:32 +00:00
|
|
|
(define interests (mux-interests-of (world-mux new-w) newpid))
|
|
|
|
(define behavior (hash-ref (world-behaviors new-w) newpid))
|
|
|
|
(define state (hash-ref (world-states new-w) newpid))
|
2015-03-21 16:30:10 +00:00
|
|
|
(with-color BRIGHT-GREEN
|
|
|
|
(output "~a ~v spawned from ~a (~a total processes now)\n"
|
|
|
|
newpidstr
|
|
|
|
behavior
|
2015-03-16 14:38:32 +00:00
|
|
|
pidstr
|
|
|
|
newcount))
|
2015-03-21 16:30:10 +00:00
|
|
|
(unless (boring-state? state)
|
|
|
|
(output "~a's initial state:\n" newpidstr)
|
2015-05-11 22:25:21 +00:00
|
|
|
(prospect-pretty-print state (current-error-port)))
|
2015-03-16 14:38:32 +00:00
|
|
|
(unless (matcher-empty? interests)
|
2015-03-21 16:30:10 +00:00
|
|
|
(output "~a's initial interests:\n" newpidstr)
|
2015-03-16 14:38:32 +00:00
|
|
|
(pretty-print-matcher interests (current-error-port))))]
|
2015-03-21 16:30:10 +00:00
|
|
|
[_
|
|
|
|
;; other cases handled in internal-action
|
|
|
|
(void)])
|
|
|
|
(when show-routing-table?
|
2015-03-16 14:38:32 +00:00
|
|
|
(define old-table (mux-routing-table (world-mux old-w)))
|
|
|
|
(define new-table (mux-routing-table (world-mux new-w)))
|
2015-03-21 16:30:10 +00:00
|
|
|
(when (not (equal? old-table new-table))
|
|
|
|
(with-color BRIGHT-BLUE
|
|
|
|
(output "~a's routing table:\n" (format-pids (cdr pids)))
|
|
|
|
(pretty-print-matcher new-table (current-error-port))))))])
|
2015-03-05 14:54:12 +00:00
|
|
|
(loop))))
|
|
|
|
|
|
|
|
(void (when (not (set-empty? flags))
|
|
|
|
(thread display-trace)))
|