suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: add place logging

Browse Source
This commit is contained in:
Matthew Flatt 2019-06-27 19:07:01 -06:00
parent c84765b554
commit 032ab4e374
7 changed files with 74 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
racket/src/cs/io.sls
View File

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

12
racket/src/io/logger/main.rkt
View File

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

4
racket/src/thread/Makefile
View File

@ -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 \

2
racket/src/thread/main.rkt
View File

@ -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?

34
racket/src/thread/place-logging.rkt Normal file
View File

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

2
racket/src/thread/place-object.rkt
View File

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

22
racket/src/thread/place.rkt
View File

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