From b2e2674f4406037b0a715f64644986e6af47fde7 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 13 Aug 2017 22:14:45 -0400 Subject: [PATCH] Support opening/closing the MSD trace file with SIGUSR1 --- racket/syndicate/trace/msd.rkt | 50 +++++++-- racket/syndicate/trace/render-msd.rkt | 148 +++++++++++++++----------- racket/syndicate/trace/stderr.rkt | 10 -- racket/syndicate/trace/util.rkt | 19 +++- 4 files changed, 145 insertions(+), 82 deletions(-) diff --git a/racket/syndicate/trace/msd.rkt b/racket/syndicate/trace/msd.rkt index 22fdc73..516a3c3 100644 --- a/racket/syndicate/trace/msd.rkt +++ b/racket/syndicate/trace/msd.rkt @@ -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)))))) diff --git a/racket/syndicate/trace/render-msd.rkt b/racket/syndicate/trace/render-msd.rkt index 0432a8f..12d23d2 100644 --- a/racket/syndicate/trace/render-msd.rkt +++ b/racket/syndicate/trace/render-msd.rkt @@ -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) diff --git a/racket/syndicate/trace/stderr.rkt b/racket/syndicate/trace/stderr.rkt index 6d22e6a..423f5fe 100644 --- a/racket/syndicate/trace/stderr.rkt +++ b/racket/syndicate/trace/stderr.rkt @@ -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)) diff --git a/racket/syndicate/trace/util.rkt b/racket/syndicate/trace/util.rkt index 2a5c380..22f3ff7 100644 --- a/racket/syndicate/trace/util.rkt +++ b/racket/syndicate/trace/util.rkt @@ -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)))))