diff --git a/racket/syndicate/dataspace.rkt b/racket/syndicate/dataspace.rkt index 987265c..a2678f3 100644 --- a/racket/syndicate/dataspace.rkt +++ b/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 ( 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 [( 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 ( 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)]) diff --git a/racket/syndicate/ground.rkt b/racket/syndicate/ground.rkt index a65be30..e51b1f6 100644 --- a/racket/syndicate/ground.rkt +++ b/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)] [( 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)) diff --git a/racket/syndicate/patch.rkt b/racket/syndicate/patch.rkt index 20975ca..2b6e444 100644 --- a/racket/syndicate/patch.rkt +++ b/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. diff --git a/racket/syndicate/trace.rkt b/racket/syndicate/trace.rkt index ad829ed..077d306 100644 --- a/racket/syndicate/trace.rkt +++ b/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))) diff --git a/racket/syndicate/trace/msd.rkt b/racket/syndicate/trace/msd.rkt new file mode 100644 index 0000000..dc1afd1 --- /dev/null +++ b/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)))))) diff --git a/racket/syndicate/trace/render-msd.rkt b/racket/syndicate/trace/render-msd.rkt new file mode 100644 index 0000000..91cf951 --- /dev/null +++ b/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*)) diff --git a/racket/syndicate/trace/stderr.rkt b/racket/syndicate/trace/stderr.rkt index 21f139e..51be93a 100644 --- a/racket/syndicate/trace/stderr.rkt +++ b/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 () diff --git a/racket/syndicate/trace/util.rkt b/racket/syndicate/trace/util.rkt index 964883b..2a5c380 100644 --- a/racket/syndicate/trace/util.rkt +++ b/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) ", ")))))