111 lines
4.6 KiB
Racket
111 lines
4.6 KiB
Racket
#lang racket/base
|
|
|
|
(provide start-tracing!)
|
|
|
|
(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-logger syndicate/trace/msd)
|
|
|
|
(define (start-tracing! output-filename)
|
|
(when output-filename
|
|
(define names (make-hash (list (cons '() "'ground"))))
|
|
(define (open-output cause)
|
|
(log-syndicate/trace/msd-warning "~a: opening trace file ~a" cause output-filename)
|
|
(define fh (open-output-file output-filename #:exists 'replace))
|
|
(write (list #f #f 'name-summary
|
|
(for/list [((actor-path name) (in-hash names))]
|
|
(cons actor-path (format "~a" name))))
|
|
fh)
|
|
(newline fh)
|
|
fh)
|
|
(let ((fh (open-output "Startup")))
|
|
(define (write-event! . pieces)
|
|
(let ((fh fh)) ;; avoid non-atomic access; see thread below
|
|
(when fh
|
|
(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))
|
|
(hash-set! names (spacetime-space sink) name)
|
|
(write-event! source sink 'spawn (format "~a" name))]
|
|
[('exit exn-or-false)
|
|
(write-event! source sink 'exit (format "~a" 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)
|
|
(hash-remove! names (spacetime-space source))
|
|
(write-event! source sink 'quit)]
|
|
[('event (list cause (? patch? p)))
|
|
(match (spacetime-space sink)
|
|
['()
|
|
(write-event! source sink 'event
|
|
'patch
|
|
(patch->pretty-string p)
|
|
cause
|
|
(list (spacetime-space cause)))]
|
|
[(cons _ context-path)
|
|
(write-event! source sink 'event
|
|
'patch
|
|
(format-patch '#hash() context-path p)
|
|
cause
|
|
(set-map (extract-patch-pids p)
|
|
(lambda (local-pid) (cons local-pid context-path))))])]
|
|
[('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)]))
|
|
(define ch (make-channel))
|
|
;; ^ ?!?!?!! Why do I have to do this to avoid problems loading
|
|
;; the unix-signals package??? Is there a Racket-level race in
|
|
;; namespace-management code???
|
|
(thread (lambda ()
|
|
(define next-signal-evt (check-for-unix-signals-support!))
|
|
(channel-put ch (void))
|
|
(when next-signal-evt
|
|
(log-syndicate/trace/msd-info "SIGUSR1 toggles/resets trace file ~a"
|
|
output-filename)
|
|
(let loop ()
|
|
(match (sync next-signal-evt)
|
|
['SIGUSR1
|
|
(set! fh (cond
|
|
[fh
|
|
(log-syndicate/trace/msd-warning "SIGUSR1: closing trace file ~a"
|
|
output-filename)
|
|
(close-output-port fh)
|
|
#f]
|
|
[else
|
|
(open-output "SIGUSR1")]))]
|
|
[_ (void)])
|
|
(loop)))))
|
|
(channel-get ch)
|
|
(current-trace-procedures (cons msd-trace (current-trace-procedures))))))
|
|
|
|
(start-tracing! (getenv "SYNDICATE_MSD"))
|