More flexible tracing of worlds

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))
-		    "#<world>"
-		    (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)
-						    "#<world>"
-						    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)

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

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)))

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 "#<world>\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)))