From d442f4890f8deda787630fa59200cb8c2f47296d Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 31 Oct 2016 13:46:53 -0400 Subject: [PATCH] summarise-ground-state with SIGUSR2 --- racket/syndicate/trace/stderr.rkt | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/racket/syndicate/trace/stderr.rkt b/racket/syndicate/trace/stderr.rkt index 08cf66e..d00e463 100644 --- a/racket/syndicate/trace/stderr.rkt +++ b/racket/syndicate/trace/stderr.rkt @@ -64,6 +64,7 @@ (define YELLOW-ON-RED ";1;33;41") (define WHITE-ON-RED ";1;37;41") (define WHITE-ON-GREEN ";1;37;42") +(define WHITE-ON-BLUE ";1;37;44") (define GREY-ON-RED ";37;41") (define GREY-ON-GREEN ";37;42") (define RED ";31") @@ -115,7 +116,7 @@ (define (forget-process! process-names pids) (hash-remove! process-names pids)) -(define (display-notification the-notification process-names) +(define (display-notification the-notification process-names ground-state-box) (match-define (trace-notification source sink type detail) the-notification) (match* (type detail) [('turn-begin (process name _beh state)) @@ -125,6 +126,7 @@ (output "~a turn begins\n" (format-pids process-names sink))))] [('turn-end (process name _beh state)) (ensure-process-named! process-names sink name) + (when (null? sink) (set-box! ground-state-box state)) (when show-turns? (with-color BLUE (output "~a turn ends\n" (format-pids process-names sink)) @@ -192,6 +194,9 @@ (format-pids process-names sink) (pretty-format body)))])) +(define (summarise-ground-state state) + (syndicate-pretty-print state (current-error-port))) + (define (install-trace-procedure!) (define logger (make-logger 'syndicate-trace)) (define (trace-via-logger n) @@ -204,11 +209,15 @@ (dynamic-require 'unix-signals 'capture-signal!))) (and capture-signal! (begin (capture-signal! 'SIGUSR1) - (dynamic-require 'unix-signals 'next-signal-evt)))) + (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)) + (define ground-state-box (box #f)) (name-process! process-names '() 'ground) ;; by convention (define next-signal-evt (check-for-unix-signals-support!)) (parameterize ((pretty-print-columns 100)) @@ -216,15 +225,21 @@ (sync (handle-evt receiver (lambda (v) (match-define (vector level message-string data event-name) v) - (display-notification data process-names) + (display-notification data process-names ground-state-box) (loop))) (if next-signal-evt (handle-evt next-signal-evt - (lambda (_signum) - (with-color WHITE-ON-GREEN - (output "\e[2J\e[HProcess name table:\n") - (for [((pid name) (in-hash process-names))] - (output "\t~v\t--> ~v\n" pid name))) + (lambda (signame) + (match signame + ['SIGUSR1 + (with-color WHITE-ON-GREEN + (output "\e[2J\e[HProcess name table:\n") + (for [((pid name) (in-hash process-names))] + (output "\t~v\t--> ~v\n" pid name)))] + ['SIGUSR2 + (with-color WHITE-ON-BLUE + (output "\e[2J\e[HGround routing table:\n") + (summarise-ground-state (unbox ground-state-box)))]) (loop))) never-evt)))))