Support opening/closing the MSD trace file with SIGUSR1
This commit is contained in:
parent
3db51ffda5
commit
b2e2674f44
|
@ -10,18 +10,26 @@
|
||||||
(require "../trace.rkt")
|
(require "../trace.rkt")
|
||||||
(require "util.rkt")
|
(require "util.rkt")
|
||||||
|
|
||||||
(define (escape-string x)
|
(define-logger syndicate/trace/msd)
|
||||||
(let* ((s (format "~a" x))
|
|
||||||
(s (string-replace s "\\" "\\\\"))
|
|
||||||
(s (string-replace s "\"" "\\\"")))
|
|
||||||
(string-append "\"" s "\"")))
|
|
||||||
|
|
||||||
(let ((output-filename (getenv "SYNDICATE_MSD")))
|
(let ((output-filename (getenv "SYNDICATE_MSD")))
|
||||||
(when output-filename
|
(when output-filename
|
||||||
(let ((fh (open-output-file output-filename #:exists 'replace)))
|
(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)
|
(define (write-event! . pieces)
|
||||||
(write pieces fh)
|
(let ((fh fh)) ;; avoid non-atomic access; see thread below
|
||||||
(newline fh))
|
(when fh
|
||||||
|
(write pieces fh)
|
||||||
|
(newline fh))))
|
||||||
(define (msd-trace n)
|
(define (msd-trace n)
|
||||||
(match-define (trace-notification source sink type detail) n)
|
(match-define (trace-notification source sink type detail) n)
|
||||||
(match* (type detail)
|
(match* (type detail)
|
||||||
|
@ -30,6 +38,7 @@
|
||||||
[('turn-end _process)
|
[('turn-end _process)
|
||||||
(write-event! source sink 'turn-end)]
|
(write-event! source sink 'turn-end)]
|
||||||
[('spawn (process name _beh _state))
|
[('spawn (process name _beh _state))
|
||||||
|
(hash-set! names (spacetime-space sink) name)
|
||||||
(write-event! source sink 'spawn (format "~a" name))]
|
(write-event! source sink 'spawn (format "~a" name))]
|
||||||
[('exit exn-or-false)
|
[('exit exn-or-false)
|
||||||
(write-event! source sink 'exit exn-or-false)]
|
(write-event! source sink 'exit exn-or-false)]
|
||||||
|
@ -45,6 +54,7 @@
|
||||||
'message
|
'message
|
||||||
(pretty-format body))]
|
(pretty-format body))]
|
||||||
[('action-interpreted 'quit)
|
[('action-interpreted 'quit)
|
||||||
|
(hash-remove! names (spacetime-space source))
|
||||||
(write-event! source sink 'quit)]
|
(write-event! source sink 'quit)]
|
||||||
[('event (list cause (? patch? p)))
|
[('event (list cause (? patch? p)))
|
||||||
(match (spacetime-space sink)
|
(match (spacetime-space sink)
|
||||||
|
@ -69,4 +79,28 @@
|
||||||
(list (spacetime-space cause)))]
|
(list (spacetime-space cause)))]
|
||||||
[('event (list _cause #f)) ;; cause will be #f
|
[('event (list _cause #f)) ;; cause will be #f
|
||||||
(void)]))
|
(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))))))
|
(current-trace-procedures (cons msd-trace (current-trace-procedures))))))
|
||||||
|
|
|
@ -3,6 +3,7 @@
|
||||||
(require pict)
|
(require pict)
|
||||||
(require pict/color)
|
(require pict/color)
|
||||||
(require file/convertible)
|
(require file/convertible)
|
||||||
|
(require (only-in "util.rkt" format-pids))
|
||||||
|
|
||||||
(struct spacetime (space time) #:prefab)
|
(struct spacetime (space time) #:prefab)
|
||||||
|
|
||||||
|
@ -28,78 +29,94 @@
|
||||||
(define (read-msd port)
|
(define (read-msd port)
|
||||||
(define max-lane -1)
|
(define max-lane -1)
|
||||||
(define swimlane-map (make-hash))
|
(define swimlane-map (make-hash))
|
||||||
|
(define name-summary (hash))
|
||||||
|
(define events-rev '())
|
||||||
|
|
||||||
(define (find-lane*! actor-path)
|
(define (emit-events . es)
|
||||||
(hash-ref! swimlane-map
|
(set! events-rev (foldl cons events-rev (filter values es))))
|
||||||
(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)
|
(define (strip-meta actor-path0)
|
||||||
(find-lane*! (spacetime-space point)))
|
(match actor-path0 [(list* 'meta p) p] [p p]))
|
||||||
|
|
||||||
|
(define (translate*! actor-path0 moment)
|
||||||
|
(define actor-path (strip-meta actor-path0))
|
||||||
|
(diagram-position (hash-ref! swimlane-map
|
||||||
|
actor-path
|
||||||
|
(lambda ()
|
||||||
|
(define lane (find-unused-lane swimlane-map))
|
||||||
|
(when (> lane max-lane) (set! max-lane lane))
|
||||||
|
(match (hash-ref name-summary actor-path #f)
|
||||||
|
[#f (void)]
|
||||||
|
[n (emit-events
|
||||||
|
(begin-swimlane (diagram-position lane (- moment 1/2))
|
||||||
|
(format "~a =\n~a"
|
||||||
|
(format-pids '#hash() actor-path)
|
||||||
|
n)))])
|
||||||
|
lane))
|
||||||
|
moment))
|
||||||
|
|
||||||
|
(define (vacate-lane! point)
|
||||||
|
(define actor-path (strip-meta (spacetime-space point)))
|
||||||
|
(hash-remove! swimlane-map
|
||||||
|
(match actor-path
|
||||||
|
[(list* 'meta p) p]
|
||||||
|
[_ actor-path])))
|
||||||
|
|
||||||
(define (translate! point)
|
(define (translate! point)
|
||||||
(diagram-position (find-lane! point)
|
(translate*! (spacetime-space point) (spacetime-time point)))
|
||||||
(spacetime-time point)))
|
|
||||||
|
|
||||||
(define (connection* source sink)
|
(define (connection* source sink)
|
||||||
(and source (connection (translate! source) (translate! sink))))
|
(and source (connection (translate! source) (translate! sink))))
|
||||||
|
|
||||||
(let loop ((events-rev
|
(let loop ()
|
||||||
(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)
|
(match (read port)
|
||||||
[(? eof-object?) (msd max-lane (reverse events-rev))]
|
[(? eof-object?) (msd max-lane (reverse events-rev))]
|
||||||
[(list source sink 'turn-begin)
|
[input
|
||||||
(emit-events (activate-swimlane (translate! sink)))]
|
(match input
|
||||||
[(list source sink 'turn-end)
|
[(list _ _ 'name-summary names-alist)
|
||||||
(emit-events (deactivate-swimlane (translate! sink)))]
|
(set! name-summary (make-immutable-hash names-alist))]
|
||||||
[(list source sink 'spawn name)
|
[(list source sink 'turn-begin)
|
||||||
(emit-events (begin-swimlane (translate! sink)
|
(emit-events (activate-swimlane (translate! sink)))]
|
||||||
(format "~a =\n~a"
|
[(list source sink 'turn-end)
|
||||||
(spacetime-space sink)
|
(emit-events (deactivate-swimlane (translate! sink)))]
|
||||||
name))
|
[(list source sink 'spawn name)
|
||||||
(connection* source sink))]
|
(emit-events (begin-swimlane (translate! sink)
|
||||||
[(list source sink 'exit _exn-or-false)
|
(format "~a =\n~a"
|
||||||
(emit-events (schedule-end-swimlane (translate! sink)))]
|
(format-pids '#hash() (spacetime-space sink))
|
||||||
[(list source sink 'actions-produced count)
|
name))
|
||||||
(emit-events (annotate-swimlane (translate! sink)
|
(connection* source sink))]
|
||||||
ACTION-COLOR
|
[(list source sink 'exit _exn-or-false)
|
||||||
(match count
|
(emit-events (schedule-end-swimlane (translate! sink)))]
|
||||||
[1 "1 action"]
|
[(list source sink 'actions-produced count)
|
||||||
[n (format "~a actions" n)])))]
|
(emit-events (annotate-swimlane (translate! sink)
|
||||||
[(list source sink 'action-interpreted _ desc)
|
ACTION-COLOR
|
||||||
(define shifted-sink
|
(match count
|
||||||
(if source
|
[1 "1 action"]
|
||||||
(spacetime (spacetime-space source) (spacetime-time sink))
|
[n (format "~a actions" n)])))]
|
||||||
sink))
|
[(list source sink 'action-interpreted _ desc)
|
||||||
(emit-events (annotate-swimlane (translate! shifted-sink) ACTION-COLOR desc)
|
(define shifted-sink
|
||||||
(connection* source shifted-sink))]
|
(if source
|
||||||
[(list source sink 'quit)
|
(spacetime (spacetime-space source) (spacetime-time sink))
|
||||||
(define shifted-sink
|
sink))
|
||||||
(if source
|
(emit-events (annotate-swimlane (translate! shifted-sink) ACTION-COLOR desc)
|
||||||
(spacetime (spacetime-space source) (spacetime-time sink))
|
(connection* source shifted-sink))]
|
||||||
sink))
|
[(list source sink 'quit)
|
||||||
(emit-events (end-swimlane (translate! shifted-sink)))]
|
(define shifted-sink
|
||||||
[(list direct-cause recipient 'event _ desc indirect-cause doubly-indirect-paths)
|
(if source
|
||||||
(apply emit-events
|
(spacetime (spacetime-space source) (spacetime-time sink))
|
||||||
(annotate-swimlane (translate! recipient) EVENT-COLOR desc)
|
sink))
|
||||||
;; (connection* direct-cause recipient)
|
(emit-events (begin0 (end-swimlane (translate! shifted-sink))
|
||||||
;; (connection* indirect-cause recipient)
|
(when source (vacate-lane! shifted-sink))))]
|
||||||
(map (lambda (doubly-indirect-path)
|
[(list direct-cause recipient 'event _ desc indirect-cause doubly-indirect-paths)
|
||||||
(connection (diagram-position (find-lane*! doubly-indirect-path)
|
(apply emit-events
|
||||||
(spacetime-time direct-cause))
|
(annotate-swimlane (translate! recipient) EVENT-COLOR desc)
|
||||||
(translate! recipient)))
|
;; (connection* direct-cause recipient)
|
||||||
doubly-indirect-paths))])))
|
;; (connection* indirect-cause recipient)
|
||||||
|
(map (lambda (doubly-indirect-path)
|
||||||
|
(connection (translate*! doubly-indirect-path (spacetime-time direct-cause))
|
||||||
|
(translate! recipient)))
|
||||||
|
doubly-indirect-paths))])
|
||||||
|
(loop)])))
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -228,7 +245,12 @@
|
||||||
(match (hash-ref current-row lane #f)
|
(match (hash-ref current-row lane #f)
|
||||||
[(labelled-cell s color u)
|
[(labelled-cell s color u)
|
||||||
(define para (apply vl-append 0
|
(define para (apply vl-append 0
|
||||||
(map (lambda (s) (text s 'modern))
|
(map (lambda (s)
|
||||||
|
(define limit 200)
|
||||||
|
(text (if (> (string-length s) limit)
|
||||||
|
(string-append (substring s 0 limit) "...")
|
||||||
|
s)
|
||||||
|
'modern))
|
||||||
(string-split s "\n"))))
|
(string-split s "\n"))))
|
||||||
(vc-append
|
(vc-append
|
||||||
(disk 4)
|
(disk 4)
|
||||||
|
|
|
@ -196,16 +196,6 @@
|
||||||
(current-trace-procedures (cons trace-via-logger (current-trace-procedures)))
|
(current-trace-procedures (cons trace-via-logger (current-trace-procedures)))
|
||||||
logger)
|
logger)
|
||||||
|
|
||||||
(define (check-for-unix-signals-support!)
|
|
||||||
(define capture-signal! (with-handlers [(void (lambda _ #f))]
|
|
||||||
(dynamic-require 'unix-signals 'capture-signal!)))
|
|
||||||
(and capture-signal!
|
|
||||||
(begin (capture-signal! 'SIGUSR1)
|
|
||||||
(capture-signal! 'SIGUSR2)
|
|
||||||
(let ((lookup-signal-name (dynamic-require 'unix-signals 'lookup-signal-name)))
|
|
||||||
(handle-evt (dynamic-require 'unix-signals 'next-signal-evt)
|
|
||||||
lookup-signal-name)))))
|
|
||||||
|
|
||||||
(define ((display-trace logger))
|
(define ((display-trace logger))
|
||||||
(define receiver (make-log-receiver logger 'info))
|
(define receiver (make-log-receiver logger 'info))
|
||||||
(define process-names (make-hash))
|
(define process-names (make-hash))
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
(provide env-aref
|
(provide env-aref
|
||||||
format-pids
|
format-pids
|
||||||
format-point
|
format-point
|
||||||
format-patch)
|
format-patch
|
||||||
|
check-for-unix-signals-support!)
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
@ -44,3 +45,19 @@
|
||||||
(patch-relabel p
|
(patch-relabel p
|
||||||
(lambda (local-pids)
|
(lambda (local-pids)
|
||||||
(string-join (set-map (treap-keys local-pids) format-pid) ", ")))))
|
(string-join (set-map (treap-keys local-pids) format-pid) ", ")))))
|
||||||
|
|
||||||
|
(define (check-for-unix-signals-support!)
|
||||||
|
(define capture-signal!
|
||||||
|
(with-handlers [(void
|
||||||
|
(lambda (e)
|
||||||
|
(log-error "Error signalled during unix-signals check:\n~v\n" e)
|
||||||
|
#f))]
|
||||||
|
(dynamic-require 'unix-signals 'capture-signal!)))
|
||||||
|
(when (not capture-signal!)
|
||||||
|
(log-warning "Cannot load Racket unix-signals package. Signals not available."))
|
||||||
|
(and capture-signal!
|
||||||
|
(begin (capture-signal! 'SIGUSR1)
|
||||||
|
(capture-signal! 'SIGUSR2)
|
||||||
|
(let ((lookup-signal-name (dynamic-require 'unix-signals 'lookup-signal-name)))
|
||||||
|
(handle-evt (dynamic-require 'unix-signals 'next-signal-evt)
|
||||||
|
lookup-signal-name)))))
|
||||||
|
|
Loading…
Reference in New Issue