64 lines
2.3 KiB
Racket
64 lines
2.3 KiB
Racket
#lang racket/base
|
|
|
|
(provide env-aref
|
|
format-pids
|
|
format-point
|
|
format-patch
|
|
check-for-unix-signals-support!)
|
|
|
|
(require racket/set)
|
|
(require racket/match)
|
|
(require (only-in racket/string string-join))
|
|
(require "../trie.rkt")
|
|
(require "../patch.rkt")
|
|
(require "../trace.rkt")
|
|
(require "../treap.rkt")
|
|
(require "../tset.rkt")
|
|
|
|
(define (env-aref varname default alist)
|
|
(define key (or (getenv varname) default))
|
|
(cond [(assoc key alist) => cadr]
|
|
[else (error 'env-aref
|
|
"Expected environment variable ~a to contain one of ~v; got ~v"
|
|
(map car alist)
|
|
key)]))
|
|
|
|
(define (format-pids process-names pids)
|
|
(define pidstr
|
|
(match pids
|
|
['() "ground"]
|
|
[(cons 'meta rest) (format "context of ~a" (format-pids process-names rest))]
|
|
[_ (string-join (map number->string (reverse pids)) ":")]))
|
|
(match (hash-ref process-names pids #f)
|
|
[#f pidstr]
|
|
[name (format "~a a.k.a ~v" pidstr name)]))
|
|
|
|
(define (format-point process-names point)
|
|
(match-define (spacetime pids moment) (or point (spacetime #f #f)))
|
|
(string-append (if pids (format-pids process-names pids) "?")
|
|
(if moment (format " @@~a" moment) "")))
|
|
|
|
(define (format-patch process-names dataspace-actor-path p)
|
|
(define (expand-pid local-pid) (cons local-pid dataspace-actor-path))
|
|
(define (format-pid local-pid) (format-pids process-names (expand-pid local-pid)))
|
|
(patch->pretty-string
|
|
(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)))))
|