Much improved tracing

racket/syndicate/dataspace.rkt

@@ -5,7 +5,6 @@
          make-dataspace
          dataspace-actor
          make-dataspace-actor
-         dataspace-handle-event
          pretty-print-dataspace)
 
 (require racket/set)
@@ -30,7 +29,7 @@
 
 ;; VM private states
 (struct dataspace (mux ;; Multiplexer
-                   pending-action-queue ;; (Queueof (Cons Label (U Action 'quit)))
+                   pending-action-queue ;; (Queueof (Vector Label (U Action 'quit) SpaceTime))
                    runnable-pids ;; (Setof PID)
                    process-table ;; (HashTable PID Process)
                    )
@@ -41,35 +40,46 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (send-event origin-pid e pid w)
+(define (send-event interpreted-point produced-point 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
-        (when origin-pid (trace-causal-influence origin-pid pid e))
-        (trace-event-consumed pid e)
-        (trace-turn-begin pid the-process)
+      (let ((turn-begin-point (trace-turn-begin (trace-event-consumed interpreted-point
+                                                                      produced-point
+                                                                      pid
+                                                                      e)
+                                                pid
+                                                the-process)))
         (invoke-process pid
                         (lambda () (clean-transition (ensure-transition (behavior e old-state))))
                         (match-lambda
                           [#f
-                           (trace-turn-end pid the-process)
+                           (trace-turn-end turn-begin-point pid the-process)
                            w]
                           [(and q (<quit> exn final-actions))
-                           (trace-turn-end pid the-process)
-                           (trace-actor-exit pid exn)
-                           (enqueue-actions (disable-process pid exn w) pid (append final-actions
-                                                                                    (list 'quit)))]
+                           (define turn-end-point (trace-turn-end turn-begin-point pid the-process))
+                           (trace-actor-exit turn-end-point pid exn)
+                           (enqueue-actions turn-end-point
+                                            (disable-process pid exn w)
+                                            pid
+                                            (append final-actions (list 'quit)))]
                           [(and t (transition new-state new-actions))
-                           (trace-turn-end pid (process process-name behavior new-state))
-                           (enqueue-actions (mark-pid-runnable (update-state w pid new-state) pid)
+                           (enqueue-actions (trace-turn-end turn-begin-point
+                                                            pid
+                                                            (process process-name
+                                                                     behavior
+                                                                     new-state))
+                                            (mark-pid-runnable (update-state w pid new-state) pid)
                                             pid
                                             new-actions)])
                         (lambda (exn)
-                          (trace-turn-end pid the-process)
-                          (trace-actor-exit pid exn)
-                          (enqueue-actions (disable-process pid exn w) pid (list 'quit)))))))
+                          (define turn-end-point (trace-turn-end turn-begin-point pid the-process))
+                          (trace-actor-exit turn-end-point pid exn)
+                          (enqueue-actions turn-end-point
+                                           (disable-process pid exn w)
+                                           pid
+                                           (list 'quit)))))))
 
 (define (update-process-entry w pid f)
   (define old-pt (dataspace-process-table w))
@@ -80,10 +90,10 @@
 (define (update-state w pid s)
   (update-process-entry w pid (lambda (p) (update-process-state p s))))
 
-(define (send-event/guard origin-pid e pid w)
+(define (send-event/guard interpreted-point produced-point e pid w)
   (if (patch-empty? e)
       w
-      (send-event origin-pid e pid w)))
+      (send-event interpreted-point produced-point e pid w)))
 
 (define (disable-process pid exn w)
   (when exn
@@ -108,12 +118,12 @@
 (define (mark-pid-runnable w pid)
   (struct-copy dataspace w [runnable-pids (set-add (dataspace-runnable-pids w) pid)]))
 
-(define (enqueue-actions w label actions)
-  (trace-actions-produced label actions)
+(define (enqueue-actions turn-end-point w label actions)
+  (define produced-point (trace-actions-produced turn-end-point label actions))
   (struct-copy dataspace w
     [pending-action-queue
      (queue-append-list (dataspace-pending-action-queue w)
-                        (for/list [(a actions)] (cons label a)))]))
+                        (for/list [(a actions)] (vector label a produced-point)))]))
 
 (define-syntax (dataspace-actor stx)
   (syntax-parse stx
@@ -123,7 +133,8 @@
 
 (define (make-dataspace boot-actions)
   (dataspace (mux)
-             (list->queue (for/list ((a (in-list (clean-actions boot-actions)))) (cons 'meta a)))
+             (list->queue (for/list ((a (in-list (clean-actions boot-actions))))
+                            (vector 'meta a #f)))
              (set)
              (hash)))
 
@@ -147,18 +158,21 @@
       (step-children w)))
 
 (define ((inject-event e) w)
-  (transition (if (not e) w (enqueue-actions w 'meta (list e))) '()))
+  ;; TODO: What is the best way of getting something sensible to
+  ;; supply to `enqueue-actions` as `turn-end-point`? Similar applies
+  ;; to use of #f in `make-dataspace` for the boot actions and to
+  ;; relaying of `targeted-event`s.
+  (transition (if (not e) w (enqueue-actions #f w 'meta (list e))) '()))
 
 (define (perform-actions w)
   (for/fold ([wt (transition (struct-copy dataspace w [pending-action-queue (make-queue)]) '())])
       ((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)
-    (when (or (event? a) (eq? a 'quit)) (trace-action-interpreted label a))
-    (define wt1 (transition-bind (perform-action label a) wt))
+    (match-define (vector label a produced-point) entry)
+    (define wt1 (transition-bind (perform-action produced-point label a) wt))
     wt1))
 
-(define ((perform-action label a) w)
+(define ((perform-action produced-point label a) w)
   (match a
     [(<actor> boot initial-assertions)
      (invoke-process (mux-next-pid (dataspace-mux w)) ;; anticipate pid allocation
@@ -172,82 +186,109 @@
                                  other)]))
                      (lambda (results)
                        (match-define (list behavior initial-transition name) results)
-                       (create-process label w behavior initial-transition initial-assertions name))
+                       (create-process produced-point
+                                       w
+                                       behavior
+                                       initial-transition
+                                       initial-assertions
+                                       name))
                      (lambda (exn)
                        (log-error "Spawned process in dataspace ~a died with exception:\n~a"
                                   (current-actor-path)
                                   (exn->string exn))
                        (transition w '())))]
     ['quit
+     (define interpreted-point (trace-action-interpreted produced-point label a))
      (define-values (new-mux _label delta delta-aggregate)
        (mux-remove-stream (dataspace-mux w) label))
      ;; Clean up the "tombstone" left for us by disable-process
      (let ((w (struct-copy dataspace w
                            [process-table (hash-remove (dataspace-process-table w) label)])))
-       (deliver-patches w new-mux label delta delta-aggregate))]
+       (deliver-patches interpreted-point produced-point w new-mux label delta delta-aggregate))]
     [(quit-dataspace)
      (quit)]
     [(? patch? delta-orig)
      (define-values (new-mux _label delta delta-aggregate)
        (mux-update-stream (dataspace-mux w) label delta-orig))
-     (deliver-patches w new-mux label delta delta-aggregate)]
+     (define interpreted-point (trace-action-interpreted produced-point label delta))
+     (deliver-patches interpreted-point produced-point w new-mux label delta delta-aggregate)]
     [(and m (message body))
+     (define interpreted-point (trace-action-interpreted produced-point label a))
      (when (observe? body)
        (log-warning "Stream ~a sent message containing query ~v"
                     (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 label m pid w))
+     (transition (for/fold [(w w)] [(pid (in-list affected-pids))]
+                   (send-event interpreted-point produced-point m pid w))
                  (and meta-affected? m))]
     [(targeted-event (cons pid remaining-path) e)
-     (transition (send-event/guard label (target-event remaining-path e) pid w) '())]))
+     (transition (send-event/guard #f #f (target-event remaining-path e) pid w) '())]))
 
-(define (create-process parent-label w behavior initial-transition initial-assertions name)
+(define (create-process produced-point w behavior initial-transition initial-assertions name)
   (define initial-assertions? (not (trie-empty? initial-assertions)))
   (define initial-patch (patch initial-assertions trie-empty))
+  (define (trace-spawn/initial-patch pid state0)
+    (define spawn-point (trace-actor-spawn produced-point pid (process name behavior state0)))
+    (cons spawn-point
+          (and initial-assertions? (trace-actions-produced spawn-point pid (list initial-patch)))))
   (define-values (postprocess initial-state initial-actions)
     (match (clean-transition initial-transition)
       [#f
        (values (lambda (w pid)
-                 (trace-actor-spawn parent-label pid (process name behavior (void)))
-                 (when initial-assertions? (trace-actions-produced pid (list initial-patch)))
-                 w)
+                 (values (trace-spawn/initial-patch pid (void))
+                         w))
                #f
                '())]
       [(and q (<quit> exn initial-actions0))
        (values (lambda (w pid)
-                 (trace-actor-spawn parent-label pid (process name behavior (void)))
-                 (when initial-assertions? (trace-actions-produced pid (list initial-patch)))
-                 (trace-actor-exit pid exn)
-                 (disable-process pid exn w))
+                 (define points (trace-spawn/initial-patch pid (void)))
+                 (match-define (cons spawn-point _) points)
+                 (trace-actor-exit spawn-point pid exn)
+                 (values points (disable-process pid exn w)))
                #f
                (append initial-actions0 (list 'quit)))]
       [(and t (transition initial-state initial-actions0))
        (values (lambda (w pid)
-                 (trace-actor-spawn parent-label pid (process name behavior initial-state))
-                 (when initial-assertions? (trace-actions-produced pid (list initial-patch)))
-                 (mark-pid-runnable w pid))
+                 (values (trace-spawn/initial-patch pid initial-state)
+                         (mark-pid-runnable w pid)))
                initial-state
                initial-actions0)]))
   (define-values (new-mux new-pid delta delta-aggregate)
     (mux-add-stream (dataspace-mux w) initial-patch))
-  (let* ((w (struct-copy dataspace w
-              [process-table (hash-set (dataspace-process-table w)
-                                       new-pid
-                                       (process name
-                                                behavior
-                                                initial-state))]))
-         (w (enqueue-actions (postprocess w new-pid) new-pid initial-actions)))
-    (when initial-assertions? (trace-action-interpreted new-pid initial-patch))
-    (deliver-patches w new-mux new-pid delta delta-aggregate)))
+  (let ((w (struct-copy dataspace w
+             [process-table (hash-set (dataspace-process-table w)
+                                      new-pid
+                                      (process name
+                                               behavior
+                                               initial-state))])))
+    (let-values (((points w) (postprocess w new-pid)))
+      (match-define (cons spawn-point initial-patch-produced-point) points)
+      (let ((w (enqueue-actions spawn-point w new-pid initial-actions)))
+        (deliver-patches (and initial-assertions?
+                              (trace-action-interpreted initial-patch-produced-point
+                                                        new-pid
+                                                        delta))
+                         initial-patch-produced-point
+                         w
+                         new-mux
+                         new-pid
+                         delta
+                         delta-aggregate)))))
 
-(define (deliver-patches w new-mux acting-label delta delta-aggregate)
+(define (deliver-patches interpreted-point
+                         produced-point
+                         w
+                         new-mux
+                         acting-label
+                         delta
+                         delta-aggregate)
   (define-values (patches meta-action)
     (compute-patches (dataspace-mux w) new-mux acting-label delta delta-aggregate))
   (transition (for/fold [(w (struct-copy dataspace w [mux new-mux]))]
                         [(entry (in-list patches))]
                 (match-define (cons label event) entry)
-                (send-event/guard acting-label event label w))
+                (send-event/guard interpreted-point produced-point event label w))
               (and (patch-non-empty? meta-action) meta-action)))
 
 (define (step-children w)
@@ -256,7 +297,7 @@
       #f ;; dataspace is inert.
       (transition (for/fold [(w (struct-copy dataspace w [runnable-pids (set)]))]
                             [(pid (in-set runnable-pids))]
-                    (send-event #f #f pid w))
+                    (send-event #f #f #f pid w))
 		  '())))
 
 (define (pretty-print-dataspace w [p (current-output-port)])

racket/syndicate/ground.rkt

@@ -10,6 +10,7 @@
 (require "hierarchy.rkt")
 (require "trace.rkt")
 (require "trace/stderr.rkt")
+(require "trace/msd.rkt")
 (require "tset.rkt")
 (require "protocol/standard-relay.rkt")
 (require "trie.rkt")
@@ -130,10 +131,10 @@
 ;; Event Process AssertionSet Natural -> AssertionSet
 ;; Returns the final set of active assertions at groundmost level.
 (define (inject-event e proc interests background-activity-count)
-  (trace-event-consumed #f e)
-  (trace-turn-begin #f proc)
+  (define cause (trace-timestamp! '()))
+  (define begin-point (trace-turn-begin (trace-event-consumed cause cause #f e) #f proc))
   (define resulting-transition (clean-transition ((process-behavior proc) e (process-state proc))))
-  (process-transition resulting-transition proc interests background-activity-count))
+  (process-transition begin-point resulting-transition proc interests background-activity-count))
 
 ;; (Listof Action) AssertionSet -> AssertionSet
 ;; Incorporates patches into the given assertion set.
@@ -148,20 +149,23 @@
         (log-syndicate/ground-warning "run-ground: ignoring useless meta-action ~v" a)
         (process-actions actions interests)])]))
 
-;; Transition Process AssertionSet Natural -> AssertionSet
+;; SpaceTime Transition Process AssertionSet Natural -> AssertionSet
 ;; Returns the final set of active assertions at groundmost level.
-(define (process-transition resulting-transition proc interests background-activity-count)
+(define (process-transition begin-point
+                            resulting-transition
+                            proc
+                            interests
+                            background-activity-count)
   (match resulting-transition
     [#f ;; inert
-     (trace-turn-end #f proc)
+     (trace-turn-end begin-point #f proc)
      (await-interrupt #t proc interests background-activity-count)]
     [(<quit> exn actions)
-     (trace-turn-end #f proc)
-     (trace-actor-exit #f exn)
+     (trace-actor-exit (trace-turn-end begin-point #f proc) #f exn)
      (log-syndicate/ground-debug "run-ground: Terminating by request")
      (process-actions actions interests)]
     [(transition new-state actions)
-     (trace-turn-end #f (process (process-name proc) (process-behavior proc) new-state))
+     (trace-turn-end begin-point #f (process (process-name proc) (process-behavior proc) new-state))
      (let ((proc (update-process-state proc new-state))
            (new-interests (process-actions actions interests)))
        (await-interrupt #f proc new-interests background-activity-count))]))
@@ -176,4 +180,4 @@
 ;; Returns the final set of active assertions at groundmost level.
 (define (run-ground* s)
   (define-values (proc t initial-assertions) (actor->process+transition/assertions s))
-  (process-transition t proc initial-assertions 0))
+  (process-transition #f t proc initial-assertions 0))

racket/syndicate/patch.rkt

@@ -10,6 +10,7 @@
          patch/added?
          patch/removed?
          label-patch
+         patch-relabel
          limit-patch
          patch-step
          patch-step*
@@ -81,6 +82,10 @@
   (patch (label-interests (patch-added p) label)
          (label-interests (patch-removed p) label)))
 
+(define (patch-relabel p f)
+  (patch (trie-relabel (patch-added p) f)
+         (trie-relabel (patch-removed p) f)))
+
 ;; When given a set-labelled p and bound, assumes that the label sets
 ;; only ever contain one element, thereby acting as if given a
 ;; #t-labelled p and bound.

racket/syndicate/trace.rkt

@@ -8,8 +8,9 @@
          trace-action-interpreted
          trace-actions-produced
          trace-event-consumed
-         trace-causal-influence
 
+         trace-timestamp!
+         (struct-out spacetime)
          (struct-out trace-notification))
 
 (require "hierarchy.rkt")
@@ -24,79 +25,89 @@
 ;; -- 'action-interpreted
 ;; -- 'actions-produced
 ;; -- 'event
-;; -- 'influence
+
+;; A Moment is a Natural representing an abstract increasing counter,
+;; unique for a Racket VM instance. It names a specific moment in the
+;; interpretation of a Syndicate configuration.
+
+;; A SpaceTime is either a (spacetime ActorPath Moment) or #f. When
+;; non-#f, it names a specific point in the actor hierarchy ("space")
+;; along with a point in time ("time"). When #f, it signifies
+;; "unknown".
+(struct spacetime (space time) #:prefab)
+
+;; A TraceNotification is a (trace-notification SpaceTime SpaceTime NotificationType TraceDetail).
+;; It represents an event in a Syndicate hierarchy.
+(struct trace-notification (source sink type detail) #:prefab)
 ;;
-;; The trace-notification-detail field is used differently for each
-;; NotificationType:
+;; A TraceDetail represents information about a specific
+;; NotificationType, and so depends on the particular NotificationType
+;; being used:
 ;; -- 'turn-begin and 'turn-end --> Process
-;; -- 'spawn --> (list PID Process), the parent's PID and the process' initial state
+;; -- 'spawn --> Process, the new process' initial state
 ;; -- 'exit --> Option Exception
 ;; -- 'action-interpreted --> (U Event 'quit) (notably, spawns are handled otherwise)
 ;; -- 'actions-produced --> (Listof (U Action 'quit)) (spawns included!)
-;; -- 'event --> Event
-;; -- 'influence --> Event
+;; -- 'event --> (list SpaceTime Event) ;; point describes action that led to this event,
+;;                                      ;; thus capturing the information of the former
+;;                                      ;; "causal influence" NotificationType.
 ;;
-;; The source and sink fields both hold values of type ActorPath. They
+;; The source and sink fields both hold values of type SpaceTime. 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
+;; -- 'spawn --> source is parent process; sink the new process
 ;; -- 'exit --> source is dataspace; sink the exiting process
 ;; -- 'action-interpreted --> source is acting process; sink is dataspace (NB: Flipped!)
-;; -- 'actions-produced --> source is acting process; sink is dataspace (NB: Flipped!)
+;; -- 'actions-produced --> source and sink are both acting process; source = turn-end or spawn
 ;; -- '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.
-
-(struct trace-notification (source sink type detail) #:prefab)
 
 (define current-trace-procedures (make-store #:default-box (box '())))
 
-(define-syntax-rule (notify! src snk typ det)
+(define *current-moment* 0)
+(define (moment!)
+  (local-require ffi/unsafe/atomic)
+  (call-as-atomic (lambda ()
+                    (begin0 *current-moment*
+                      (set! *current-moment* (+ *current-moment* 1))))))
+
+(define (trace-timestamp! actor-path)
+  (spacetime actor-path (moment!)))
+
+(define-syntax-rule (notify! SRC SNK TYP DET)
   (let ((trace-procedures (current-trace-procedures)))
-    (when (pair? trace-procedures)
-      (define n (trace-notification src snk typ det))
-      (for-each (lambda (procedure) (procedure n)) trace-procedures))))
+    (cond [(pair? trace-procedures)
+           (define snk SNK)
+           (define n (trace-notification SRC snk TYP DET))
+           (for-each (lambda (procedure) (procedure n)) trace-procedures)
+           snk]
+          [else 'trace-collection-disabled])))
 
 (define (cons-pid pid)
   (if pid
       (cons pid (current-actor-path-rev))
       (current-actor-path-rev)))
 
-;; PID Process
-(define (trace-turn-begin pid p)
-  (notify! (current-actor-path-rev) (cons-pid pid) 'turn-begin p))
+(define (trace-turn-begin source pid p)
+  (notify! source (trace-timestamp! (cons-pid pid)) 'turn-begin p))
 
-;; PID Process
-(define (trace-turn-end pid p)
-  (notify! (current-actor-path-rev) (cons-pid pid) 'turn-end p))
+(define (trace-turn-end source pid p)
+  (notify! source (trace-timestamp! (cons-pid pid)) 'turn-end p))
 
-;; PID PID Process
-(define (trace-actor-spawn parent-pid pid p)
-  (notify! (current-actor-path-rev) (cons-pid pid) 'spawn (list (cons-pid parent-pid) p)))
+(define (trace-actor-spawn source pid p)
+  (notify! source (trace-timestamp! (cons-pid pid)) 'spawn p))
 
-;; PID (Option Exception)
-(define (trace-actor-exit pid maybe-exn)
-  (notify! (current-actor-path-rev) (cons-pid pid) 'exit maybe-exn))
+(define (trace-actor-exit source pid maybe-exn)
+  (notify! source (trace-timestamp! (cons-pid pid)) 'exit maybe-exn))
 
-;; PID Event
-(define (trace-action-interpreted pid e)
-  (notify! (cons-pid pid) (current-actor-path-rev) 'action-interpreted e))
+(define (trace-action-interpreted source _pid e)
+  (notify! source (trace-timestamp! (current-actor-path-rev)) 'action-interpreted e))
 
-;; PID (Listof Event)
-(define (trace-actions-produced pid es)
-  (notify! (cons-pid pid) (current-actor-path-rev) 'actions-produced es))
+(define (trace-actions-produced source pid es)
+  (notify! source (trace-timestamp! (cons-pid pid)) 'actions-produced es))
 
-;; 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))
+(define (trace-event-consumed interpreted-point ;; direct cause
+                              produced-point    ;; one-step indirect cause
+                              pid               ;; recipient
+                              e)
+  (notify! interpreted-point (trace-timestamp! (cons-pid pid)) 'event (list produced-point e)))

racket/syndicate/trace/msd.rkt

@@ -0,0 +1,69 @@
+#lang racket/base
+
+(require racket/match)
+(require racket/set)
+(require racket/string)
+(require racket/pretty)
+(require "../core.rkt")
+(require "../tset.rkt")
+(require "../patch.rkt")
+(require "../trace.rkt")
+(require "util.rkt")
+
+(define (escape-string x)
+  (let* ((s (format "~a" x))
+         (s (string-replace s "\\" "\\\\"))
+         (s (string-replace s "\"" "\\\"")))
+    (string-append "\"" s "\"")))
+
+(let ((output-filename (getenv "SYNDICATE_MSD")))
+  (when output-filename
+    (let ((fh (open-output-file output-filename #:exists 'replace)))
+      ;; (fprintf fh "digraph Syndicate {\n")
+      ;; (plumber-add-flush! (current-plumber) (lambda (_handle)
+      ;;                                         (fprintf fh "}\n")
+      ;;                                         (close-output-port fh)))
+      (define (write-event! . pieces)
+        (write pieces fh)
+        (newline fh))
+      (define (msd-trace n)
+        (match-define (trace-notification source sink type detail) n)
+        (match* (type detail)
+          [('turn-begin _process)
+           (write-event! source sink 'turn-begin)]
+          [('turn-end _process)
+           (write-event! source sink 'turn-end)]
+          [('spawn (process name _beh _state))
+           (write-event! source sink 'spawn (format "~a" name))]
+          [('exit exn-or-false)
+           (write-event! source sink 'exit exn-or-false)]
+          [('actions-produced actions)
+           (when (positive? (length actions))
+             (write-event! source sink 'actions-produced (length actions)))]
+          [('action-interpreted (? patch? p))
+           (write-event! source sink 'action-interpreted
+                         'patch
+                         (patch->pretty-string (label-patch p #t)))]
+          [('action-interpreted (message body))
+           (write-event! source sink 'action-interpreted
+                         'message
+                         (pretty-format body))]
+          [('action-interpreted 'quit)
+           (write-event! source sink 'quit)]
+          [('event (list cause (? patch? p)))
+           (write-event! source sink 'event
+                         'patch
+                         (format-patch '#hash() (cdr (spacetime-space sink)) p)
+                         cause
+                         (set-map (extract-patch-pids p)
+                                  (lambda (local-pid)
+                                    (cons local-pid (cdr (spacetime-space sink))))))]
+          [('event (list cause (message body)))
+           (write-event! source sink 'event
+                         'message
+                         (pretty-format body)
+                         cause
+                         (list (spacetime-space cause)))]
+          [('event (list _cause #f)) ;; cause will be #f
+           (void)]))
+      (current-trace-procedures (cons msd-trace (current-trace-procedures))))))

racket/syndicate/trace/render-msd.rkt

@@ -0,0 +1,336 @@
+#lang racket
+
+(require pict)
+(require pict/color)
+(require file/convertible)
+
+(struct spacetime (space time) #:prefab)
+
+(struct diagram-position (lane row) #:prefab)
+
+(struct begin-swimlane (pos name) #:prefab)
+(struct activate-swimlane (pos) #:prefab)
+(struct deactivate-swimlane (pos) #:prefab)
+(struct schedule-end-swimlane (pos) #:prefab)
+(struct end-swimlane (pos) #:prefab)
+(struct annotate-swimlane (pos color annotation) #:prefab)
+(struct connection (from-pos to-pos) #:prefab)
+
+(struct msd (max-lane events) #:prefab)
+
+;;---------------------------------------------------------------------------
+
+(define (find-unused-lane swimlane-map)
+  (let ((used-lanes (list->set (hash-values swimlane-map))))
+    (do ((i 0 (+ i 1)))
+        ((not (set-member? used-lanes i)) i))))
+
+(define (read-msd port)
+  (define max-lane -1)
+  (define swimlane-map (make-hash))
+
+  (define (find-lane*! actor-path)
+    (hash-ref! swimlane-map
+               (match actor-path
+                 [(list* 'meta p) p]
+                 [_ actor-path])
+               (lambda ()
+                 (define lane (find-unused-lane swimlane-map))
+                 (when (> lane max-lane) (set! max-lane lane))
+                 lane)))
+
+  (define (find-lane! point)
+    (find-lane*! (spacetime-space point)))
+
+  (define (translate! point)
+    (diagram-position (find-lane! point)
+                      (spacetime-time point)))
+
+  (define (connection* source sink)
+    (and source (connection (translate! source) (translate! sink))))
+
+  (let loop ((events-rev
+              (reverse
+               (list ;; (begin-swimlane (translate! (spacetime '(meta) -2)) "External")
+                     (begin-swimlane (translate! (spacetime '() -1)) "Ground VM")))))
+
+    (define (emit-events . es)
+      (loop (foldl cons events-rev (filter values es))))
+
+    (match (read port)
+      [(? eof-object?) (msd max-lane (reverse events-rev))]
+      [(list source sink 'turn-begin)
+       (emit-events (activate-swimlane (translate! sink)))]
+      [(list source sink 'turn-end)
+       (emit-events (deactivate-swimlane (translate! sink)))]
+      [(list source sink 'spawn name)
+       (emit-events (begin-swimlane (translate! sink)
+                                    (format "~a =\n~a"
+                                            (spacetime-space sink)
+                                            name))
+                    (connection* source sink))]
+      [(list source sink 'exit _exn-or-false)
+       (emit-events (schedule-end-swimlane (translate! sink)))]
+      [(list source sink 'actions-produced count)
+       (emit-events (annotate-swimlane (translate! sink)
+                                       ACTION-COLOR
+                                       (match count
+                                         [1 "1 action"]
+                                         [n (format "~a actions" n)])))]
+      [(list source sink 'action-interpreted _ desc)
+       (define shifted-sink
+         (if source
+             (spacetime (spacetime-space source) (spacetime-time sink))
+             sink))
+       (emit-events (annotate-swimlane (translate! shifted-sink) ACTION-COLOR desc)
+                    (connection* source shifted-sink))]
+      [(list source sink 'quit)
+       (define shifted-sink
+         (if source
+             (spacetime (spacetime-space source) (spacetime-time sink))
+             sink))
+       (emit-events (end-swimlane (translate! shifted-sink)))]
+      [(list direct-cause recipient 'event _ desc indirect-cause doubly-indirect-paths)
+       (apply emit-events
+              (annotate-swimlane (translate! recipient) EVENT-COLOR desc)
+              ;; (connection* direct-cause recipient)
+              ;; (connection* indirect-cause recipient)
+              (map (lambda (doubly-indirect-path)
+                     (connection (diagram-position (find-lane*! doubly-indirect-path)
+                                                   (spacetime-time direct-cause))
+                                 (translate! recipient)))
+                   doubly-indirect-paths))])))
+
+;;---------------------------------------------------------------------------
+
+(define N (* pi 1/2))
+(define S (* pi -1/2))
+(define E (* pi 0))
+(define W (* pi 1))
+
+(define NE (* pi 1/4))
+(define SE (* pi -1/4))
+(define NW (* pi 3/4))
+(define SW (* pi -3/4))
+
+(define ENE (* pi 1/8))
+(define ESE (* pi -1/8))
+(define WNW (* pi 7/8))
+(define WSW (* pi -7/8))
+
+;; A SwimlaneState is
+;; - a (labelled-cell String ColorString SwimlaneState), representing
+;;   a fresh annotation on a possibly-new swimlane
+;; - 'inactive, an occupied but inactive lane
+;; - 'active, an occupied and active lane
+;; - 'terminating, an occupied but soon-to-be-free lane
+;; - #f, an unoccupied lane
+
+(struct labelled-cell (label color underlying-state) #:prefab)
+
+(define (hash-set-or-remove h k v)
+  (if v
+      (hash-set h k v)
+      (hash-remove h k)))
+
+(define (reset-label v)
+  (match v
+    [(labelled-cell _ _ underlying-state) underlying-state]
+    [_ v]))
+
+(define (reset-statemap statemap)
+  (for/hash [((k v) (in-hash statemap))]
+    (values k (reset-label v))))
+
+(define (update-statemap statemaps pos new-state)
+  (match-define (list previous-row table) statemaps)
+  (match-define (diagram-position lane row) pos)
+
+  (define old-statemap
+    (hash-ref table row (lambda () (reset-statemap (hash-ref table previous-row hash)))))
+
+  (define new-statemap
+    (hash-set-or-remove old-statemap
+                        lane
+                        (match new-state
+                          [(list color annotation)
+                           (labelled-cell annotation color (hash-ref old-statemap lane 'inactive))]
+                          [_ new-state])))
+
+  (list row
+        (hash-set-or-remove table
+                            row
+                            (if (hash-empty? new-statemap) #f new-statemap))))
+
+(define (update-swimlane event statemaps)
+  (match event
+    [(begin-swimlane pos name)
+     (update-statemap statemaps pos (list LABEL-COLOR name))]
+    [(activate-swimlane pos)
+     (update-statemap statemaps pos 'active)]
+    [(deactivate-swimlane pos)
+     (update-statemap statemaps pos 'inactive)]
+    [(schedule-end-swimlane pos)
+     (update-statemap statemaps pos 'terminating)]
+    [(end-swimlane pos)
+     (update-statemap statemaps pos #f)]
+    [(annotate-swimlane pos color annotation)
+     (update-statemap statemaps pos (list color annotation))]))
+
+(define WIDTH 50)
+(define HEIGHT 20)
+(define GAP 20)
+(define ACTIVE-WIDTH 10)
+
+(define ACTION-COLOR "white")
+(define EVENT-COLOR "orange")
+(define LABEL-COLOR "palegreen")
+
+(define (fill-out height p)
+  (ct-superimpose (blank WIDTH height)
+                  (if p
+                      (inset p (* -1/2 (pict-width p)) 0)
+                      (blank 0))))
+
+(define (transpose xs)
+  (apply map list xs))
+
+(define (render-underlay max-lane prev-row current-row next-row height)
+  (for/list [(lane (+ max-lane 1))]
+    (fill-out height
+              (match (match (hash-ref current-row lane #f)
+                       [(labelled-cell s _ u) u]
+                       [u u])
+                ['inactive (filled-rectangle #:color "gray"
+                                             #:draw-border? #f
+                                             (/ ACTIVE-WIDTH 2)
+                                             height)]
+                ['active
+                 (define prev-state (hash-ref prev-row lane #f))
+                 (define next-state (hash-ref next-row lane #f))
+                 (define (trunk height)
+                   (hb-append 0
+                              (vline 1 height)
+                              (blank (- ACTIVE-WIDTH 2) height)
+                              (vline 1 height)))
+                 (define bar (hline (- ACTIVE-WIDTH 1) 1))
+                 (match* (prev-state next-state)
+                   [('active 'active) (trunk height)]
+                   [('active _) (vl-append 0 (trunk (- height 1)) bar)]
+                   [(_ 'active) (vl-append 0 bar (trunk (- height 1)))]
+                   [(_ _) (vl-append 0 bar (trunk (- height 2)) bar)])]
+                ['terminating (vline 1 height #:segment 2)]
+                [#f (blank 0)]))))
+
+(define (render-overlay max-lane current-row)
+  (for/list [(lane (+ max-lane 1))]
+    (fill-out HEIGHT
+              (match (hash-ref current-row lane #f)
+                [(labelled-cell s color u)
+                 (define para (apply vl-append 0
+                                     (map (lambda (s) (text s 'modern))
+                                          (string-split s "\n"))))
+                 (vc-append
+                  (disk 4)
+                  (frame
+                   (cc-superimpose
+                    (filled-rectangle #:color color
+                                      #:draw-border? #f
+                                      (+ (pict-width para) 8)
+                                      (+ (pict-height para) 8))
+                    para)))]
+                [_ #f]))))
+
+(define (msd->pict m)
+  (match-define (msd max-lane all-events) m)
+  (define-values (connections events) (partition connection? all-events))
+  (match-define (list _row-count statemaps) (foldl update-swimlane (list 0 (hash)) events))
+  (define rows (sort (hash->list statemaps) < #:key car))
+  (define dummy-initial-row (cons (- (car (car rows)) 1) (hash)))
+  (define dummy-final-row (match (last rows)
+                            [(cons final-row final-statemap)
+                             (cons (+ final-row 1) (reset-statemap final-statemap))]))
+  (define row-triples
+    (map (lambda (a b c)
+           (list (car b)
+                 (reset-statemap (cdr a))
+                 (cdr b)
+                 (reset-statemap (cdr c))))
+         (cons dummy-initial-row rows)
+         (append rows (list dummy-final-row))
+         (append (cdr rows) (list dummy-final-row dummy-final-row))))
+  (define over-and-unders
+    (map (match-lambda
+           [(list row-number prev-row current-row next-row)
+            (define overlay (render-overlay max-lane current-row))
+            (define height (+ GAP (apply max (map pict-height overlay))))
+            (define underlay (render-underlay max-lane prev-row current-row next-row height))
+            (list row-number underlay overlay)])
+         row-triples))
+  (define overlay-index (for/hash [(entry over-and-unders)]
+                          (values (car entry) (caddr entry))))
+  (define base-pict
+    (apply vl-append 0
+           (map (lambda (over-and-under)
+                  (ct-superimpose (apply hb-append 4 (cadr over-and-under))
+                                  (apply hb-append 4 (caddr over-and-under))))
+                over-and-unders)))
+  (for/fold [(base-pict base-pict)]
+            [(c connections)]
+    (match-define (connection (diagram-position from-lane from-row)
+                              (diagram-position to-lane to-row))
+      c)
+    (if (and (hash-has-key? overlay-index from-row)
+             (hash-has-key? overlay-index to-row))
+        (pin-arrow-line 10 base-pict
+                        (list-ref (hash-ref overlay-index from-row) from-lane)
+                        cb-find
+                        (list-ref (hash-ref overlay-index to-row) to-lane)
+                        ct-find
+                        #:start-angle (if (>= to-lane from-lane) SE SW)
+                        #:start-pull 1/10
+                        #:end-angle (if (<= to-lane from-lane) SW SE)
+                        #:end-pull 1/10)
+        base-pict)))
+
+(define (render p #:target [target (string->symbol (or (getenv "VM_PICTURES_TARGET") "eps"))])
+  (define (final-border) 1)
+  (define final-pict (cc-superimpose (blank (+ (pict-width p) (* 2 (final-border)))
+					    (+ (pict-height p) (* 2 (final-border))))
+				     (panorama p)))
+  (case target
+    [(screen)
+     ;; FFS. This connects to the display even if you don't use it.
+     (local-require racket/gui/base)
+     (show-pict final-pict 800 600)
+     ;; (log-error "You need to uncomment a couple of lines in vm-pictures.rkt")
+     (void)]
+    [(png)
+     (display (convert final-pict 'png-bytes))]
+    [(png@2x)
+     (display (convert final-pict 'png@2x-bytes))]
+    [(svg)
+     (display (convert final-pict 'svg-bytes))]
+    [(eps)
+     (display (convert final-pict 'eps-bytes))]
+    [(pdf)
+     (display (convert final-pict 'pdf-bytes))]))
+
+(module+ main
+  (require racket/cmdline)
+  (define *scale* 1)
+  (define *target* 'screen)
+  (define filename
+    (command-line
+     #:once-each
+     [("-s" "--scale") scale "Rescales output; 1 = 100%"
+      (set! *scale* (string->number scale))]
+     [("-t" "--target") target "Choose target: screen, png, png@2x, svg, eps, pdf"
+      (set! *target* (string->symbol target))]
+     #:args (filename)
+     filename))
+  (render (scale (msd->pict (if (equal? filename "-")
+                                (read-msd (current-input-port))
+                                (call-with-input-file filename read-msd)))
+                 *scale*)
+          #:target *target*))

racket/syndicate/trace/stderr.rkt

@@ -21,7 +21,7 @@
 (define show-lifecycle? #f)
 (define show-actions? #f)
 (define show-events? #f)
-(define show-influence? #f)
+(define show-events/polls? #f)
 
 (define (set-stderr-trace-flags! flags+module-string)
   (define-values (flags-string module-string)
@@ -29,7 +29,7 @@
       [(regexp #px"^([^:]*):(.*)$" (list _ fs m)) (values fs m)]
       [_ (values flags+module-string "")]))
 
-  (define A-flags (set 'x 'i 'p))
+  (define A-flags (set 'x 'e 'p))
   (set! flags (for/set [(c flags-string)] (string->symbol (string c))))
   (define-syntax-rule (set-flag! symbol variable)
     (set! variable (or (and (set-member? flags 'A) (set-member? A-flags 'symbol))
@@ -40,7 +40,7 @@
   (set-flag! p show-lifecycle?)
   (set-flag! a show-actions?)
   (set-flag! e show-events?)
-  (set-flag! i show-influence?)
+  (set-flag! E show-events/polls?)
 
   (let ((port (open-input-string module-string)))
     (let loop ()
@@ -77,7 +77,8 @@
 	 (begin0 (begin expr ...)
 	   (reset-color!))))
 
-(define (ensure-process-named! process-names pids expected-name)
+(define (ensure-process-named! process-names point expected-name)
+  (define pids (spacetime-space point))
   (define current-name (hash-ref process-names pids #f))
   (when (not (equal? current-name expected-name))
     (with-color WHITE-ON-RED
@@ -86,103 +87,101 @@
               expected-name
               current-name))))
 
-(define (name-process! process-names pids name)
-  (hash-set! process-names pids name))
+(define (name-process! process-names point name)
+  (hash-set! process-names (spacetime-space point) name))
 
-(define (forget-process! process-names pids)
-  (hash-remove! process-names pids))
+(define (forget-process! process-names point)
+  (hash-remove! process-names (spacetime-space point)))
 
 (define (display-notification the-notification process-names ground-state-box)
   (match-define (trace-notification source sink type detail) the-notification)
+  ;; (with-color NORMAL (output "~a\n" the-notification))
   (match* (type detail)
     [('turn-begin (process name _beh state))
      (ensure-process-named! process-names sink name)
      (when (or show-turns? show-turns/state?)
        (with-color BLUE
-         (output "~a turn begins\n" (format-pids process-names sink))))]
+         (output "~a turn begins\n" (format-point process-names sink))))]
     [('turn-end (process name _beh state))
      (ensure-process-named! process-names sink name)
-     (when (null? sink) (set-box! ground-state-box state))
+     (when (null? (spacetime-space sink)) (set-box! ground-state-box state))
      (when (or show-turns? show-turns/state?)
        (with-color BLUE
-         (output "~a turn ends\n" (format-pids process-names sink))
+         (output "~a turn ends\n" (format-point process-names sink))
          (when show-turns/state?
            (syndicate-pretty-print state (current-error-port)))))]
-    [('spawn (list parent (process name _beh state)))
+    [('spawn (process name _beh state))
      (name-process! process-names sink name)
      (when show-lifecycle?
        (with-color BRIGHT-GREEN
          (output "~a spawned by ~a\n"
-                 (format-pids process-names sink)
-                 (format-pids process-names parent))))]
+                 (format-point process-names sink)
+                 (format-point process-names source))))]
     [('exit #f)
      (when show-lifecycle?
        (with-color BRIGHT-RED
-         (output "~a schedules an exit\n" (format-pids process-names sink))))]
+         (output "~a schedules an exit\n" (format-point process-names sink))))]
     [('exit exn)
      (when (or show-lifecycle? show-exceptions?)
        (with-color WHITE-ON-RED
          (output "~a raises an exception:\n~a\n"
-                 (format-pids process-names sink)
+                 (format-point process-names sink)
                  (exn->string exn))))]
     [('actions-produced actions)
-     ;; (when show-actions?
-     ;;   (for [(a actions)]
-     ;;     (match a
-     ;;       [(? patch? p)
-     ;;        (output "~a enqueues a patch\n" (format-pids process-names source))]
-     ;;       [(message body)
-     ;;        (output "~a enqueues a message\n" (format-pids process-names source))]
-     ;;       ['quit
-     ;;        (output "~a schedules a cleanup\n")]
-     ;;       [(? actor? _)
-     ;;        (output "~a enqueues a spawn\n" (format-pids process-names source))])))
-     (void)]
+     (when (or show-events? show-actions?)
+       (when (positive? (length actions))
+         (output "~a enqueues ~a actions as a result of ~a.\n"
+                 (format-point process-names sink)
+                 (length actions)
+                 (format-point process-names source))))]
     [('action-interpreted (? patch? p))
-     (when show-actions?
-       (output "~a performs a patch:\n~a\n"
-               (format-pids process-names source)
-               (patch->pretty-string (label-patch p #t))))]
+     (cond
+       [show-actions?
+        (output "~a interprets patch from ~a:\n~a\n"
+                (format-point process-names sink)
+                (format-point process-names source)
+                (patch->pretty-string (label-patch p #t)))]
+       [show-events?
+        (output "~a interprets patch from ~a.\n"
+                (format-point process-names sink)
+                (format-point process-names source))]
+       [else (void)])]
     [('action-interpreted (message body))
-     (when show-actions?
-       (output "~a broadcasts a message:\n~a\n"
-               (format-pids process-names source)
-               (pretty-format body)))]
+     (cond
+       [show-actions?
+        (output "~a delivers broadcast message from ~a:\n~a\n"
+                (format-point process-names sink)
+                (format-point process-names source)
+                (pretty-format body))]
+       [show-events?
+        (output "~a delivers broadcast message from ~a.\n"
+                (format-point process-names sink)
+                (format-point process-names source))])]
     [('action-interpreted 'quit)
      (when show-lifecycle?
        (with-color BRIGHT-RED
-         (output "~a exits\n" (format-pids process-names source))))
+         (output "~a exits\n" (format-point process-names source))))
      (forget-process! process-names source)]
-    [('event (? patch? p))
+    [('event (list cause (? patch? p)))
      (when show-events?
        (with-color YELLOW
-         (output "~a receives an event:\n~a\n"
-                 (format-pids process-names sink)
-                 (patch->pretty-string (label-patch p #t)))))]
-    [('event (message body))
+         (output "~a receives a patch event (direct cause ~a, indirect cause ~a):\n~a\n"
+                 (format-point process-names sink)
+                 (format-point process-names source)
+                 (format-point process-names cause)
+                 (format-patch process-names (cdr (spacetime-space sink)) p))))]
+    [('event (list cause (message body)))
      (when show-events?
        (with-color YELLOW
-         (output "~a receives a message:\n~a\n"
-                 (format-pids process-names sink)
+         (output "~a receives a message event (direct cause ~a, indirect cause ~a):\n~a\n"
+                 (format-point process-names sink)
+                 (format-point process-names source)
+                 (format-point process-names cause)
                  (pretty-format body))))]
-    [('event #f)
-     (when show-events?
+    [('event (list _cause #f)) ;; cause will be #f
+     (when show-events/polls?
        (with-color YELLOW
-         (output "~a is polled\n" (format-pids process-names sink))))]
-    [('influence (? patch? p))
-     (when show-influence?
-       (output "~a influenced by ~a via a patch:\n~a\n"
-               (format-pids process-names sink)
-               (string-join (map (lambda (p) (format-pids process-names p))
-                                 (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 process-names source)
-               (format-pids process-names sink)
-               (pretty-format body)))]))
+         (output "~a is polled\n" (format-point process-names sink))))]))
 
 (define (summarise-ground-state state)
   (syndicate-pretty-print state (current-error-port)))
@@ -208,7 +207,7 @@
   (define receiver (make-log-receiver logger 'info))
   (define process-names (make-hash))
   (define ground-state-box (box #f))
-  (name-process! process-names '() 'ground) ;; by convention
+  (name-process! process-names (spacetime '() #f) 'ground) ;; by convention
   (define next-signal-evt (check-for-unix-signals-support!))
   (parameterize ((pretty-print-columns 100))
     (let loop ()

racket/syndicate/trace/util.rkt

@@ -2,12 +2,17 @@
 
 (provide env-aref
          format-pids
-         extract-leaf-pids)
+         format-point
+         format-patch)
 
 (require racket/set)
 (require racket/match)
 (require (only-in racket/string string-join))
+(require "../trie.rkt")
 (require "../patch.rkt")
+(require "../trace.rkt")
+(require "../treap.rkt")
+(require "../tset.rkt")
 
 (define (env-aref varname default alist)
   (define key (or (getenv varname) default))
@@ -27,6 +32,15 @@
     [#f pidstr]
     [name (format "~a a.k.a ~v" pidstr name)]))
 
-(define (extract-leaf-pids sink p)
-  (for/list [(pid (in-set (extract-patch-pids p)))]
-    (cons pid (cdr sink))))
+(define (format-point process-names point)
+  (match-define (spacetime pids moment) (or point (spacetime #f #f)))
+  (string-append (if pids (format-pids process-names pids) "?")
+                 (if moment (format " @@~a" moment) "")))
+
+(define (format-patch process-names dataspace-actor-path p)
+  (define (expand-pid local-pid) (cons local-pid dataspace-actor-path))
+  (define (format-pid local-pid) (format-pids process-names (expand-pid local-pid)))
+  (patch->pretty-string
+   (patch-relabel p
+                  (lambda (local-pids)
+                    (string-join (set-map (treap-keys local-pids) format-pid) ", ")))))