cs: add place logging

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))

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?*`

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 \

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?

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))

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

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