114 lines
4.4 KiB
Racket
114 lines
4.4 KiB
Racket
#lang racket/base
|
|
|
|
(provide current-trace-procedures
|
|
trace-turn-begin
|
|
trace-turn-end
|
|
trace-actor-spawn
|
|
trace-actor-exit
|
|
trace-action-interpreted
|
|
trace-actions-produced
|
|
trace-event-consumed
|
|
|
|
trace-timestamp!
|
|
(struct-out spacetime)
|
|
(struct-out trace-notification))
|
|
|
|
(require "hierarchy.rkt")
|
|
(require "pretty.rkt")
|
|
(require "store.rkt")
|
|
|
|
;; A NotificationType is one of
|
|
;; -- 'turn-begin
|
|
;; -- 'turn-end
|
|
;; -- 'spawn
|
|
;; -- 'exit
|
|
;; -- 'action-interpreted
|
|
;; -- 'actions-produced
|
|
;; -- 'event
|
|
|
|
;; 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)
|
|
;;
|
|
;; A TraceDetail represents information about a specific
|
|
;; NotificationType, and so depends on the particular NotificationType
|
|
;; being used:
|
|
;; -- 'turn-begin and 'turn-end --> Process
|
|
;; -- '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 --> (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 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 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 and sink are both acting process; source = turn-end or spawn
|
|
;; -- 'event --> source is dataspace; sink is receiving process
|
|
|
|
(define current-trace-procedures (make-store #:default-box (box '())))
|
|
|
|
(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)))
|
|
(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)))
|
|
|
|
(define (trace-turn-begin source pid p)
|
|
(notify! source (trace-timestamp! (cons-pid pid)) 'turn-begin p))
|
|
|
|
(define (trace-turn-end source pid p)
|
|
(notify! source (trace-timestamp! (cons-pid pid)) 'turn-end p))
|
|
|
|
(define (trace-actor-spawn source pid p)
|
|
(notify! source (trace-timestamp! (cons-pid pid)) 'spawn p))
|
|
|
|
(define (trace-actor-exit source pid maybe-exn)
|
|
(notify! source (trace-timestamp! (cons-pid pid)) 'exit maybe-exn))
|
|
|
|
(define (trace-action-interpreted source _pid e)
|
|
(notify! source (trace-timestamp! (current-actor-path-rev)) 'action-interpreted e))
|
|
|
|
(define (trace-actions-produced source pid es)
|
|
(notify! source (trace-timestamp! (cons-pid pid)) 'actions-produced es))
|
|
|
|
(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)))
|