Much improved tracing
This commit is contained in:
parent
84ec153a1e
commit
09d0fb620d
|
@ -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)])
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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))))))
|
|
@ -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*))
|
|
@ -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 ()
|
||||
|
|
|
@ -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) ", ")))))
|
||||
|
|
Loading…
Reference in New Issue