221 lines
9.5 KiB
Racket
221 lines
9.5 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2017-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(provide read-msd)
|
|
|
|
(require (only-in racket/format ~a ~r))
|
|
(require (only-in racket/list flatten))
|
|
(require racket/match)
|
|
(require racket/set)
|
|
|
|
(require preserves)
|
|
(require preserves-schema/methods)
|
|
(require syndicate/schemas/trace)
|
|
(require (prefix-in P: syndicate/schemas/protocol))
|
|
(require "types.rkt")
|
|
|
|
(define (read-msd port #:config [config (render-config)])
|
|
(define max-lane -1)
|
|
(define logical-time 1)
|
|
(define swimlane-map (make-hash))
|
|
(define turn-map (make-hash))
|
|
(define handle-map (make-hash))
|
|
(define events-rev '())
|
|
|
|
(define (emit! e)
|
|
(when e
|
|
(set! logical-time (+ logical-time 1))
|
|
(set! events-rev (cons e events-rev))))
|
|
|
|
(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 (translate! actor-id [moment logical-time])
|
|
(define new? #f)
|
|
(define p (diagram-position (hash-ref! swimlane-map
|
|
actor-id
|
|
(lambda ()
|
|
(define lane (find-unused-lane swimlane-map))
|
|
(when (> lane max-lane) (set! max-lane lane))
|
|
(set! new? #t)
|
|
lane))
|
|
moment))
|
|
(when new? (emit! (begin-swimlane p)))
|
|
p)
|
|
|
|
(define (vacate-lane! actor-id)
|
|
(hash-remove! swimlane-map actor-id))
|
|
|
|
(define (turn-actor turn-id)
|
|
(car (hash-ref turn-map turn-id)))
|
|
|
|
(define (turn-moment turn-id)
|
|
(cdr (hash-ref turn-map turn-id)))
|
|
|
|
(define (connection* #:bidirectional? [bidirectional? #f] source-actor-id sink-actor-id)
|
|
(and source-actor-id
|
|
(connection bidirectional?
|
|
(translate! source-actor-id)
|
|
(translate! sink-actor-id))))
|
|
|
|
(define (format-turn-label actor-id turn-id turn-cause)
|
|
(define sub-label
|
|
(match turn-cause
|
|
[(TurnCause-turn other)
|
|
(emit! (connection #f
|
|
(translate! (turn-actor other) (turn-moment other))
|
|
(translate! actor-id)))
|
|
(format "caused by ~a" (~turn other))]
|
|
[(TurnCause-cleanup)
|
|
"cleanup"]
|
|
[(TurnCause-linkedTaskRelease task reason)
|
|
(format "task ~a ended: ~a" task (->preserve reason))]
|
|
[(TurnCause-periodicActivation period)
|
|
(format "timer: every ~as" period)]
|
|
[(TurnCause-delay other-turn delay-amount)
|
|
(emit! (connection* (turn-actor other-turn) actor-id))
|
|
(format "delay: ~as" delay-amount)]
|
|
[(TurnCause-external desc)
|
|
(format "external: ~a" desc)]))
|
|
(format "~a: ~a" (~turn turn-id) sub-label))
|
|
|
|
(define (~actor-id a)
|
|
(~a (ActorId-value a)))
|
|
|
|
(define (~turn t)
|
|
(format "#~a" (TurnId-value t)))
|
|
|
|
(define (~target e)
|
|
(match-define (Target actor-id facet-id oid) e)
|
|
(format "~a/~a:~a"
|
|
(~actor-id actor-id)
|
|
(FacetId-value facet-id)
|
|
(let ((oid (Oid-value oid)))
|
|
(if (number? oid)
|
|
(~r oid #:base 16 #:min-width 16 #:pad-string "0")
|
|
oid))))
|
|
|
|
(define (~handle h)
|
|
(format "H~a" (P:Handle-value h)))
|
|
|
|
(define (~adesc adesc)
|
|
(match adesc
|
|
[(AssertionDescription-value v) (preserve->string v #:encode-embedded values #:commas? #f)]
|
|
[(AssertionDescription-opaque d) (format "⌜~a⌝" d)]))
|
|
|
|
(define (~turn-event te is-action?)
|
|
(match te
|
|
[(TurnEvent-assert adesc handle)
|
|
(when is-action?
|
|
(when (hash-has-key? handle-map handle)
|
|
(log-error "Duplicate use of handle ~a" (~handle handle)))
|
|
(hash-set! handle-map handle adesc))
|
|
(format "assert ~a: ~a" (~handle handle) (~adesc adesc))]
|
|
[(TurnEvent-retract handle)
|
|
(define adesc (hash-ref handle-map handle #f))
|
|
(format "retract ~a: ~a" (~handle handle) (if adesc (~adesc adesc) "(missing)"))]
|
|
[(TurnEvent-message adesc)
|
|
(format "message ~a" (~adesc adesc))]
|
|
[(TurnEvent-sync peer)
|
|
(format "sync ~a" (~target peer))]
|
|
[(TurnEvent-breakLink source-actor-id handle)
|
|
(format "break link from ~a" (~actor-id source-actor-id))]))
|
|
|
|
(define (~targeted-turn-event tte is-action?)
|
|
(match-define (TargetedTurnEvent target detail) tte)
|
|
(format "~a <-- ~a" (~target target) (~turn-event detail is-action?)))
|
|
|
|
(define (process-action! actor-id action)
|
|
(let-values
|
|
(((variation label)
|
|
(match action
|
|
[(ActionDescription-dequeue tte)
|
|
(values 'event (~targeted-turn-event tte #f))]
|
|
[(ActionDescription-enqueue tte)
|
|
(values 'action (~targeted-turn-event tte #t))]
|
|
[(ActionDescription-dequeueInternal tte)
|
|
(values 'event (format "(internal) ~a" (~targeted-turn-event tte #f)))]
|
|
[(ActionDescription-enqueueInternal tte)
|
|
(values 'action (format "(internal) ~a" (~targeted-turn-event tte #t)))]
|
|
[(ActionDescription-spawn linked? child-actor-id)
|
|
(translate! child-actor-id) ;; allocates swimlane
|
|
(define L (annotate-swimlane (translate! actor-id)
|
|
(render-config-action-color config)
|
|
(format "spawn~a ~a" (if linked? "/link" "") (~actor-id child-actor-id))))
|
|
(define C (and (not linked?) (connection* actor-id child-actor-id)))
|
|
(emit! L)
|
|
(when C (emit! C))
|
|
(values #f #f)]
|
|
[(ActionDescription-link parent-actor-id handle-child->parent child-actor-id handle-parent->child)
|
|
(define L1 (annotate-swimlane (translate! parent-actor-id)
|
|
(render-config-action-color config)
|
|
(format "linked to ~a" (~actor-id child-actor-id))))
|
|
(define L2 (annotate-swimlane (translate! child-actor-id)
|
|
(render-config-action-color config)
|
|
(format "linked to ~a" (~actor-id parent-actor-id))))
|
|
(define C (connection* #:bidirectional? #t parent-actor-id child-actor-id))
|
|
(emit! L1)
|
|
(emit! L2)
|
|
(emit! C)
|
|
(values #f #f)]
|
|
[(ActionDescription-facetStart facet-ids)
|
|
(values 'action (format "+facet ~a" (map FacetId-value facet-ids)))]
|
|
[(ActionDescription-facetStop facet-ids reason)
|
|
(values 'action (format "-facet ~a ~a" (map FacetId-value facet-ids) (->preserve reason)))]
|
|
[(ActionDescription-linkedTaskStart name task-id)
|
|
(values 'action (format "task ~a started: ~a" task-id name))])))
|
|
(when label
|
|
(emit! (annotate-swimlane (translate! actor-id)
|
|
(match variation
|
|
['event (render-config-event-color config)]
|
|
['action (render-config-action-color config)])
|
|
label)))))
|
|
|
|
(define (process-trace-entry! entry)
|
|
(match-define (TraceEntry _timestamp actor-id activation) entry)
|
|
(match activation
|
|
[(ActorActivation-start name)
|
|
(emit! (annotate-swimlane (translate! actor-id)
|
|
(render-config-label-color config)
|
|
(match name
|
|
[(Name-anonymous) "(anonymous)"]
|
|
[(Name-named n) (preserve->string n
|
|
#:encode-embedded values
|
|
#:indent 2
|
|
#:commas? #f)])))]
|
|
[(ActorActivation-turn (TurnDescription turn-id turn-cause actions))
|
|
(emit! (activate-swimlane (translate! actor-id)))
|
|
(let ((label (format-turn-label actor-id turn-id turn-cause)))
|
|
(emit! (annotate-swimlane (translate! actor-id) (render-config-event-color config) label)))
|
|
(for [(a (in-list actions))] (process-action! actor-id a))
|
|
;; (let ((action-count (length actions)))
|
|
;; (when (positive? action-count)
|
|
;; (emit! (annotate-swimlane (translate! actor-id)
|
|
;; (render-config-action-color config)
|
|
;; (match action-count
|
|
;; [1 "1 action"]
|
|
;; [n (format "~a actions" n)])))))
|
|
(hash-set! turn-map turn-id (cons actor-id logical-time))
|
|
(emit! (deactivate-swimlane (translate! actor-id)))
|
|
]
|
|
[(ActorActivation-stop status)
|
|
(emit! (end-swimlane (translate! actor-id)))
|
|
(when (ExitStatus-Error? status)
|
|
(emit! (annotate-swimlane (translate! actor-id)
|
|
(render-config-label-color config)
|
|
(format "crashed: ~a" (->preserve status)))))
|
|
(vacate-lane! actor-id)]))
|
|
|
|
(let loop ()
|
|
(match (read-preserve port #:decode-embedded values)
|
|
[(? eof-object?)
|
|
(msd max-lane (reverse events-rev))]
|
|
[input
|
|
(match (parse-TraceEntry input)
|
|
[(? eof-object?) (error 'read-msd "Invalid trace entry: ~v" input)]
|
|
[entry (process-trace-entry! entry)])
|
|
(loop)])))
|