Support opening/closing the MSD trace file with SIGUSR1
This commit is contained in:
Tony Garnock-Jones
parent
3db51ffda5
commit
b2e2674f44
|
|
@ -10,18 +10,26 @@
|
|||
(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 "\"")))
|
||||
(define-logger syndicate/trace/msd)
|
||||
|
||||
(let ((output-filename (getenv "SYNDICATE_MSD")))
|
||||
(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)
|
||||
(write pieces fh)
|
||||
(newline fh))
|
||||
(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)
|
||||
|
|
@ -30,6 +38,7 @@
|
|||
[('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 exn-or-false)]
|
||||
|
|
@ -45,6 +54,7 @@
|
|||
'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)
|
||||
|
|
@ -69,4 +79,28 @@
|
|||
(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))))))
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require pict)
|
||||
(require pict/color)
|
||||
(require file/convertible)
|
||||
(require (only-in "util.rkt" format-pids))
|
||||
|
||||
(struct spacetime (space time) #:prefab)
|
||||
|
||||
|
|
@ -28,78 +29,94 @@
|
|||
(define (read-msd port)
|
||||
(define max-lane -1)
|
||||
(define swimlane-map (make-hash))
|
||||
(define name-summary (hash))
|
||||
(define events-rev '())
|
||||
|
||||
(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 (emit-events . es)
|
||||
(set! events-rev (foldl cons events-rev (filter values es))))
|
||||
|
||||
(define (find-lane! point)
|
||||
(find-lane*! (spacetime-space point)))
|
||||
(define (strip-meta actor-path0)
|
||||
(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)
|
||||
(diagram-position (find-lane! point)
|
||||
(spacetime-time point)))
|
||||
(translate*! (spacetime-space 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))))
|
||||
|
||||
(let loop ()
|
||||
(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))])))
|
||||
[input
|
||||
(match input
|
||||
[(list _ _ 'name-summary names-alist)
|
||||
(set! name-summary (make-immutable-hash names-alist))]
|
||||
[(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"
|
||||
(format-pids '#hash() (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 (begin0 (end-swimlane (translate! shifted-sink))
|
||||
(when source (vacate-lane! 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 (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)
|
||||
[(labelled-cell s color u)
|
||||
(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"))))
|
||||
(vc-append
|
||||
(disk 4)
|
||||
|
|
|
|||
|
|
@ -196,16 +196,6 @@
|
|||
(current-trace-procedures (cons trace-via-logger (current-trace-procedures)))
|
||||
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 receiver (make-log-receiver logger 'info))
|
||||
(define process-names (make-hash))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
(provide env-aref
|
||||
format-pids
|
||||
format-point
|
||||
format-patch)
|
||||
format-patch
|
||||
check-for-unix-signals-support!)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
|
@ -44,3 +45,19 @@
|
|||
(patch-relabel p
|
||||
(lambda (local-pids)
|
||||
(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