diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls index 8e57b48588..e3f9b82735 100644 --- a/racket/src/cs/io.sls +++ b/racket/src/cs/io.sls @@ -480,4 +480,5 @@ (set-make-async-callback-poll-wakeup! unsafe-make-signal-received) (set-get-machine-info! get-machine-info) (set-processor-count! (1/processor-count)) - (install-future-logging-procs! logging-future-events? log-future-event)) + (install-future-logging-procs! logging-future-events? log-future-event) + (install-place-logging-procs! logging-place-events? log-place-event)) diff --git a/racket/src/io/logger/main.rkt b/racket/src/io/logger/main.rkt index f5e2594463..a7b5085302 100644 --- a/racket/src/io/logger/main.rkt +++ b/racket/src/io/logger/main.rkt @@ -25,7 +25,9 @@ add-syslog-log-receiver! logger-init! logging-future-events? - log-future-event) + log-future-event + logging-place-events? + log-place-event) (define (make-root-logger) (create-logger #:topic #f #:parent #f #:propagate-filters 'none)) @@ -68,6 +70,10 @@ (atomically/no-interrupts/no-wind (log-level?* root-logger 'debug 'future))) +(define (logging-place-events?) + (atomically/no-interrupts/no-wind + (log-level?* root-logger 'debug 'place))) + ;; In atomic mode with interrupts disabled (define/who (log-level?* logger level topic) (level>=? (logger-wanted-level logger topic) level)) @@ -139,6 +145,10 @@ (atomically/no-interrupts/no-wind (log-message* root-logger 'debug 'future message data #t #f))) +(define (log-place-event message data) + (atomically/no-interrupts/no-wind + (log-message* root-logger 'debug 'place message data #t #f))) + ;; In atomic mode with interrupts disabled ;; Can be called in any host Scheme thread and in interrupt handler, ;; like `log-level?*` diff --git a/racket/src/thread/Makefile b/racket/src/thread/Makefile index 23cad3250b..60934e8532 100644 --- a/racket/src/thread/Makefile +++ b/racket/src/thread/Makefile @@ -29,7 +29,9 @@ GLOBALS = --no-global \ ++global-ok make-place-ports+fds \ ++global-ok pthread-count \ ++global-ok "logging-future-events?" \ - ++global-ok log-future-event + ++global-ok log-future-event \ + ++global-ok "logging-place-events?" \ + ++global-ok log-place-event GENERATE_ARGS = -t main.rkt --submod main \ diff --git a/racket/src/thread/main.rkt b/racket/src/thread/main.rkt index 3ff15a49fb..db051b72e4 100644 --- a/racket/src/thread/main.rkt +++ b/racket/src/thread/main.rkt @@ -27,6 +27,7 @@ "stack-size.rkt" "place.rkt" "place-message.rkt" + "place-logging.rkt" "future.rkt" "future-logging.rkt" "fsemaphore.rkt" @@ -180,6 +181,7 @@ set-make-place-ports+fds! place-pumper-threads + install-place-logging-procs! unsafe-add-post-custodian-shutdown futures-enabled? @@ -194,7 +196,7 @@ mark-future-trace-end! set-processor-count! install-future-logging-procs! - + fsemaphore? make-fsemaphore fsemaphore-post diff --git a/racket/src/thread/place-logging.rkt b/racket/src/thread/place-logging.rkt new file mode 100644 index 0000000000..735c10b697 --- /dev/null +++ b/racket/src/thread/place-logging.rkt @@ -0,0 +1,34 @@ +#lang racket/base +(require "host.rkt" + "place-object.rkt") + +(provide log-place + + install-place-logging-procs!) + +(struct place-event (id action data time) + #:prefab) + +(define (log-place msg + #:action [action (string->symbol msg)] + #:data [data #f]) + (when (logging-place-events?) + (define id (place-id current-place)) + (log-place-event (string-append + "id " + (number->string id) + ": " + msg + (if data + (string-append " " (number->string data)) + "")) + (place-event id action data (current-inexact-milliseconds))))) + +;; ---------------------------------------- + +(define logging-place-events? (lambda () #f)) +(define log-place-event (lambda (msg e) (void))) + +(define (install-place-logging-procs! logging? log) + (set! logging-place-events? logging?) + (set! log-place-event log)) diff --git a/racket/src/thread/place-object.rkt b/racket/src/thread/place-object.rkt index dedb3d5e0a..823df99ede 100644 --- a/racket/src/thread/place-object.rkt +++ b/racket/src/thread/place-object.rkt @@ -19,6 +19,7 @@ custodian ; root custodian [custodian-ref #:mutable] ; owning custodian [host-thread #:mutable] ; host thread, needed for memory accounting + [id #:mutable] ; matches id of the host thread [host-roots #:mutable] ; continuation-independent state, needed for memory accounting [current-thread #:mutable] ; running Racket thread, needed for accounting [post-shutdown #:mutable] ; list of callbacks @@ -43,6 +44,7 @@ cust #f #f ; host thread + 0 ; id #f ; host roots #f ; running thread '() ; post-shutdown diff --git a/racket/src/thread/place.rkt b/racket/src/thread/place.rkt index c1e57f5040..b387fd8c98 100644 --- a/racket/src/thread/place.rkt +++ b/racket/src/thread/place.rkt @@ -18,7 +18,8 @@ "evt.rkt" "sandman.rkt" (submod "future.rkt" for-place) - "place-message.rkt") + "place-message.rkt" + "place-logging.rkt") (provide dynamic-place place? @@ -54,7 +55,10 @@ #:place-channel place-pch)) (set-custodian-place! orig-cust new-place) (define done-waiting (place-done-waiting new-place)) - (define (default-exit v) + (define (default-exit v #:explicit? [explicit? #f]) + (log-place (if explicit? + "exit (via `exit`)" + "exit")) (define flush-failed? #f) (plumber-flush-all/wrap orig-plumber ;; detect whether there's an error on a flush @@ -92,11 +96,12 @@ orig-cust (lambda () (set! current-place new-place) + (set-place-id! new-place (get-pthread-id)) (set-place-host-roots! new-place (host:current-place-roots)) (current-thread-group root-thread-group) (current-custodian orig-cust) (current-plumber orig-plumber) - (exit-handler default-exit) + (exit-handler (lambda (v) (default-exit v #:explicit? #t))) (current-pseudo-random-generator (make-pseudo-random-generator)) (current-evt-pseudo-random-generator (make-pseudo-random-generator)) (define finish @@ -109,6 +114,7 @@ (set-place-wakeup-handle! new-place (sandman-get-wakeup-handle)) (host:condition-signal started) ; place is sufficiently started (host:mutex-release lock) + (log-place "enter") (finish) (default-exit 0)) (default-continuation-prompt-tag) @@ -134,6 +140,7 @@ (host:condition-wait started lock) (host:mutex-release lock) (end-atomic) + (log-place "create" #:data (place-id new-place)) (values new-place parent-in parent-out parent-err)) (define/who (place-break p [kind #f]) @@ -202,6 +209,13 @@ (for ([s (in-vector vec)]) (when (thread? s) (thread-wait s))) (set-place-pumpers! p #f)) + (when (place-host-thread p) + (when (atomically + (and (place-host-thread p) + (begin + (set-place-host-thread! p #f) + #t))) + (log-place "reap" #:data (place-id p)))) result) ;; In atomic mode, callback from custodian: @@ -372,6 +386,7 @@ (pchannel-reader-key pch) (lambda (v) (end-atomic) + (log-place "get message" #:action 'get) (un-message-ize v)) (lambda (sema) (end-atomic) @@ -388,6 +403,7 @@ in-v (lambda () (raise-argument-error who "place-message-allowed?" in-v))))) + (log-place "put message" #:action 'put) (define pch (unwrap-place-channel in-pch)) (define out-mq (ephemeron-value (pchannel-out-mq-e pch))) (when out-mq