diff --git a/minimart/core.rkt b/minimart/core.rkt index 5ed2678..17ccd42 100644 --- a/minimart/core.rkt +++ b/minimart/core.rkt @@ -7,7 +7,7 @@ (require "route.rkt") (require "gestalt.rkt") (require "functional-queue.rkt") -(require (only-in web-server/private/util exn->string)) +(require "trace.rkt") (provide (struct-out routing-update) (struct-out message) @@ -15,6 +15,10 @@ (struct-out process) (struct-out transition) + (struct-out trigger-guard) + + (except-out (struct-out world) world) + ;; imported from route.rkt: ? wildcard? @@ -37,23 +41,12 @@ deliver-event transition-bind sequence-transitions - log-events-and-actions? routing-implementation) ;; A PID is a number uniquely identifying a Process within a World. ;; Note that PIDs are only meaningful within the context of their ;; World: they are not global Process identifiers. -;; (Parameterof (Listof PID)) -;; Path to the active leaf in the process tree. The car end is the -;; leaf; the cdr end, the root. Used for debugging purposes. -(define pid-stack (make-parameter '())) - -;; (Parameterof Boolean) -;; True when Worlds should log their internal actions for use in -;; debugging. -(define log-events-and-actions? (make-parameter #f)) - ;; TODO: support +Inf.0 as a level number ;; An Event is a communication from a World to a Process contained @@ -166,7 +159,7 @@ (gestalt-empty) (make-queue)) -1 - boot-actions))) + (clean-actions boot-actions)))) ;; Any -> Boolean; type predicates for Event and Action respectively. (define (event? x) (or (routing-update? x) (message? x))) @@ -180,8 +173,8 @@ (define (transition-bind k t0) (match-define (transition state0 actions0) t0) (match (k state0) - [(transition state1 actions1) (transition state1 (cons actions0 actions1))] - [#f t0])) + [#f t0] + [(transition state1 actions1) (transition state1 (cons actions0 actions1))])) ;; Transition (Any -> Transition)* -> Transition ;; Each step is a function from state to Transition. The state in t0 @@ -257,13 +250,12 @@ ;; ;; TODO: should step 3 occur before step 1? -;; World PID (Constreeof Action) -> World +;; World PID (Listof Action) -> World ;; Stores actions taken by PID for later interpretation. (define (enqueue-actions w pid actions) (struct-copy world w [process-actions (queue-append-list (world-process-actions w) - (filter-map (lambda (a) (and (action? a) (cons pid a))) - (flatten actions)))])) + (for/list [(a actions)] (cons pid a)))])) ;; World -> Boolean ;; True if the World has no further reductions it can take. @@ -283,27 +275,25 @@ (apply-transition pid (deliver-event e pid p) w)) ;; Event PID Process -> Transition -;; Delivers the event to the process, catching any exceptions it -;; throws and converting them to quit Actions. +;; Delivers the event to the process. (define (deliver-event e pid p) - (parameterize ((pid-stack (cons pid (pid-stack)))) - (when (and (log-events-and-actions?) e) - (log-info "EVENT ~a: ~v --> ~v ~v" - (pid-stack) - e - (process-behavior p) - (if (world? (process-state p)) - "#" - (process-state p)))) - (with-handlers ([(lambda (exn) #t) - (lambda (exn) - (log-error "Process ~a died with exception:\n~a" - (pid-stack) - (exn->string exn)) - (transition (process-state p) (list (quit))))]) - (ensure-transition (with-continuation-mark 'minimart-process - pid ;; TODO: debug-name, other user annotation - ((process-behavior p) e (process-state p))))))) + (define-values (maybe-exn t) (call-in-trace-context pid (lambda () (deliver-event* e pid p)))) + (trace-process-step e pid p maybe-exn t) + t) + +;; Event PID Process -> (Values (Option Exception) (Option Transition)) +;; Delivers the event to the process, returning its taken transition, +;; or if it throws an exception, the exception and a synthetic +;; transition forcing the process to quit. +(define (deliver-event* e pid p) + (with-handlers ([(lambda (exn) #t) + (lambda (exn) (values exn (transition (process-state p) (list (quit)))))]) + (values + #f + (clean-transition + (ensure-transition + (with-continuation-mark 'minimart-process pid + ((process-behavior p) e (process-state p)))))))) ;; Any -> (Option Transition) ;; If its argument is non-#f, non-transition, raises an exception. @@ -313,6 +303,16 @@ (raise (exn:fail:contract (format "Expected transition (or #f); got ~v" v) (current-continuation-marks))))) +;; (Option Transition) -> (Option Transition) +;; Filters and flattens action constree in argument. +(define (clean-transition t) + (and t (transition (transition-state t) (clean-actions (transition-actions t))))) + +;; (Constreeof Any) -> (Listof Action) +;; Filters and flattens its argument to a list of actions. +(define (clean-actions actions) + (filter action? (flatten actions))) + ;; World PID -> World ;; Marks the given PID as not-provably-inert. (define (mark-pid-runnable w pid) @@ -327,18 +327,7 @@ (match t [#f w] [(transition new-state new-actions) - (let* ((w (transform-process pid w - (lambda (p) - (when (and (log-events-and-actions?) - (not (null? (flatten new-actions)))) - (log-info "ACTIONS ~a: ~v <-- ~v ~v" - (cons pid (pid-stack)) - new-actions - (process-behavior p) - (if (world? new-state) - "#" - new-state))) - (struct-copy process p [state new-state]))))) + (let* ((w (transform-process pid w (lambda (p) (struct-copy process p [state new-state]))))) (enqueue-actions (mark-pid-runnable w pid) pid new-actions))])) ;; PendingEvent World -> World @@ -354,7 +343,9 @@ (for/fold ([t (transition (struct-copy world w [process-actions (make-queue)]) '())]) ((entry (in-list (queue->list (world-process-actions w))))) (match-define (cons pid a) entry) - (transition-bind (perform-action pid a) t))) + (define t1 (transition-bind (perform-action pid a) t)) + (trace-internal-step pid a (transition-state t) t1) + t1)) ;; World -> Transition ;; Interprets queued PendingEvents, delivering resulting Events to Processes. @@ -376,9 +367,6 @@ ;; Updates the World's cached copy of the union of its partial- and downward-gestalts. (define (update-full-gestalt w) (define new-full-gestalt (gestalt-union (world-partial-gestalt w) (world-downward-gestalt w))) - ;; (log-info "World ~a new full gestalt:\n~a" - ;; (pid-stack) - ;; (gestalt->pretty-string new-full-gestalt)) (struct-copy world w [full-gestalt new-full-gestalt])) ;; World Gestalt (Option PID) -> World @@ -423,19 +411,12 @@ (w (struct-copy world w [next-pid (+ new-pid 1)] [process-table (hash-set (world-process-table w) new-pid new-p)]))) - ;; (log-info "Spawned process ~a ~v ~v" - ;; (cons new-pid (pid-stack)) - ;; (process-behavior new-p) - ;; (process-state new-p)) (apply-and-issue-routing-update w (gestalt-empty) new-gestalt new-pid))] [(quit) (define pt (world-process-table w)) (define p (hash-ref pt pid (lambda () #f))) (if p (let* ((w (struct-copy world w [process-table (hash-remove pt pid)]))) - ;; (log-info "Process ~a terminating; ~a processes remain" - ;; (cons pid (pid-stack)) - ;; (hash-count (world-process-table w))) (apply-and-issue-routing-update w (process-gestalt p) (gestalt-empty) #f)) (transition w '()))] [(routing-update gestalt) diff --git a/minimart/ground.rkt b/minimart/ground.rkt index b3ae042..b98db44 100644 --- a/minimart/ground.rkt +++ b/minimart/ground.rkt @@ -7,6 +7,7 @@ (require racket/list) (require "core.rkt") (require "gestalt.rkt") +(require "trace/stderr.rkt") (provide (struct-out event) send-ground-message diff --git a/minimart/trace.rkt b/minimart/trace.rkt new file mode 100644 index 0000000..ffd0cbb --- /dev/null +++ b/minimart/trace.rkt @@ -0,0 +1,40 @@ +#lang racket/base + +(provide trace-logger + + trace-pid-stack + call-in-trace-context + + trace-process-step + trace-internal-step) + +(require (only-in web-server/private/util exn->string)) + +(define trace-logger (make-logger 'minimart-trace)) + +;; (Parameterof (Listof PID)) +;; Path to the active leaf in the process tree. The car end is the +;; leaf; the cdr end, the root. Used for debugging and tracing purposes. +(define trace-pid-stack (make-parameter '())) + +;; PID (-> Any) -> Any +;; Pushes pid on trace-pid-stack for the duration of the call to thunk. +(define (call-in-trace-context pid thunk) + (parameterize ((trace-pid-stack (cons pid (trace-pid-stack)))) + (thunk))) + +(define-syntax-rule (record-trace-event name r) + (when (log-level? trace-logger 'info) + (log-message trace-logger 'info name "" r #f))) + +;; Event PID Process (Option Exception) (Option Transition) -> Void +(define (trace-process-step e pid p exn t) + (when exn + (log-error "Process ~a died with exception:\n~a" + (cons pid (trace-pid-stack)) + (exn->string exn))) + (record-trace-event 'process-step (list (cons pid (trace-pid-stack)) e p exn t))) + +;; PID Action World Transition -> Void +(define (trace-internal-step pid a w t) + (record-trace-event 'internal-step (list (cons pid (trace-pid-stack)) a w t))) diff --git a/minimart/trace/stderr.rkt b/minimart/trace/stderr.rkt new file mode 100644 index 0000000..66554d7 --- /dev/null +++ b/minimart/trace/stderr.rkt @@ -0,0 +1,175 @@ +#lang racket/base + +(require racket/set) +(require racket/match) +(require racket/pretty) +(require (only-in racket/string string-join)) +(require (only-in web-server/private/util exn->string)) +(require "../core.rkt") +(require "../gestalt.rkt") +(require "../trace.rkt") + +(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 (for/set [(c (or (getenv "MINIMART_TRACE") "xetpag"))] (string->symbol (string c)))) + +(define show-exceptions? (set-member? flags 'x)) +(define show-events? (set-member? flags 'e)) +(define show-process-states-pre? (set-member? flags 's)) +(define show-process-states-post? (set-member? flags 't)) +(define show-process-lifecycle? (set-member? flags 'p)) +(define show-actions? (set-member? flags 'a)) +(define show-world-gestalt? (set-member? flags 'g)) + +(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 "") + +;; Drops the final "-2". +(define (format-pids pids) + (if (equal? pids '(-2)) + "Ground" + (string-join (map number->string (cdr (reverse pids))) ":"))) + +(define (output fmt . args) + (apply fprintf (current-error-port) fmt args)) + +(define (output-state state) + (cond + [(trigger-guard? state) (output-state (trigger-guard-state state))] + [(world? state) (output "#\n")] + [else (pretty-write state (current-error-port))])) + +(define (boring-state? state) + (or (world? state) + (void? state) + (and (trigger-guard? state) + (boring-state? (trigger-guard-state 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)) + (let loop () + (match-define (vector level message-string data event-name) (sync receiver)) + (match* (event-name data) + [('process-step (list pids e p exn t)) + (define pidstr (format-pids pids)) + (define relevant-exn? (and show-exceptions? exn)) + (match e + [#f + (when (or relevant-exn? show-events?) + (with-color YELLOW (output "~a was polled for changes.\n" pidstr)))] + [(routing-update g) + (when (or relevant-exn? show-events?) + (with-color YELLOW + (output "~a received a routing-update:\n" pidstr) + (pretty-print-gestalt g (current-error-port))))] + [(message body meta-level feedback?) + (when (or relevant-exn? show-events?) + (with-color YELLOW + (output "~a received ~a at metalevel ~a:\n" + pidstr + (if feedback? "feedback" "a message") + meta-level) + (pretty-write body (current-error-port))))]) + (when (or relevant-exn? show-process-states-pre?) + (when (or relevant-exn? (not (boring-state? (process-state p)))) + (with-color YELLOW + (output "~a's state just before the event:\n" pidstr) + (output-state (process-state p))))) + (when relevant-exn? + (with-color WHITE-ON-RED + (output "Process ~a died with exception:\n~a\n" + pidstr + (exn->string exn)))) + (when (or relevant-exn? show-process-states-post?) + (when t + (unless (boring-state? (transition-state t)) + (when (not (equal? (process-state p) (transition-state t))) + (with-color YELLOW + (output "~a's state just after the event:\n" pidstr) + (output-state (transition-state t)))))))] + [('internal-step (list pids a old-w t)) + (when t ;; inert worlds don't change interestingly + (define pidstr (format-pids pids)) + (define new-w (transition-state t)) + (define old-processes (world-process-table old-w)) + (define new-processes (world-process-table new-w)) + (define newcount (hash-count new-processes)) + (match a + [(process gestalt behavior state) + (when (or show-process-lifecycle? show-actions?) + (define newpid (set-first (set-subtract (hash-keys new-processes) + (hash-keys old-processes)))) + (define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid + (with-color BRIGHT-GREEN + (output "~a spawned from ~a (~a total processes now)\n" + newpidstr + pidstr + newcount)) + (output "~a's behavior: ~v\n" newpidstr behavior) + (unless (boring-state? state) + (output "~a's initial state:\n" newpidstr) + (output-state state)) + (unless (gestalt-empty? gestalt) + (output "~a's initial gestalt:\n" newpidstr) + (pretty-print-gestalt gestalt (current-error-port))))] + [(quit) + (when (or show-process-lifecycle? show-actions?) + (with-color BRIGHT-RED + (output "~a exited (~a total processes now)\n" pidstr newcount)) + (match (hash-ref old-processes (car pids) (lambda () #f)) + [#f (void)] + [(process gestalt _behavior state) + (unless (boring-state? state) + (output "~a's final state:\n" pidstr) + (output-state state)) + (unless (gestalt-empty? gestalt) + (output "~a's final gestalt:\n" pidstr) + (pretty-print-gestalt gestalt (current-error-port)))]))] + [(routing-update g) + (when show-actions? + (output "~a performed a routing-update:\n" pidstr) + (pretty-print-gestalt g (current-error-port)))] + [(message body meta-level feedback?) + (when show-actions? + (output "~a sent ~a at metalevel ~a:\n" + pidstr + (if feedback? "feedback" "a message") + meta-level) + (pretty-write body (current-error-port)))]) + (when show-world-gestalt? + (when (not (equal? (world-full-gestalt old-w) (world-full-gestalt new-w))) + (with-color BRIGHT-BLUE + (output "~a's full gestalt:\n" (format-pids (cdr pids))) + (pretty-print-gestalt (world-full-gestalt new-w) + (current-error-port))))))]) + (loop))) + +(void (when (not (set-empty? flags)) + (thread display-trace)))