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

add gc log following info to the drr performance monitor

Browse Source
This commit is contained in:
Robby Findler 2013-02-16 07:39:04 -06:00
parent 5db56e3186
commit fbeecdc1aa
1 changed files with 45 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/tests/drracket/follow-log.rkt
View File

@ -33,6 +33,9 @@ log message was reported.
'debug 'gui-event 'debug 'gui-event
'debug 'framework/colorer 'debug 'framework/colorer
'debug 'timeline)) 'debug 'timeline))
(define gc-only-lr
(make-log-receiver (current-logger)
'debug 'GC))
(define top-n-events 30) (define top-n-events 30)
(define drop-gc? #f) (define drop-gc? #f)
@ -49,7 +52,7 @@ log message was reported.
(thread (thread
(λ () (λ ()
(let loop () (let loop ()
(sync start-log-chan) (define lr (sync start-log-chan))
(let loop ([events '()]) (let loop ([events '()])
(sync (sync
(handle-evt (handle-evt
@ -99,10 +102,24 @@ log message was reported.
[callback [callback
(λ (_1 _2) (λ (_1 _2)
(start-bt-callback))])) (start-bt-callback))]))
(define sb3 (new button% [label "Start Following GC Log"] [parent f]
[callback
(λ (_1 _2)
(start-gc-callback))]))
(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] (define db (new button% [label "Stop && Dump"] [parent f] [enabled #f]
[callback [callback
(λ (_1 _2) (λ (_1 _2)
(stop-and-dump))])) (stop-and-dump))]))
(let ([m 0])
(send f reflow-container)
(for ([x (in-list (send f get-children))])
(when (is-a? x button%)
(set! m (max m (send x get-width)))))
(for ([x (in-list (send f get-children))])
(when (is-a? x button%)
(send x min-width m))))
(define (stop-and-dump) (define (stop-and-dump)
(define sp (open-output-string)) (define sp (open-output-string))
(parameterize ([current-output-port sp]) (parameterize ([current-output-port sp])
@ -111,19 +128,22 @@ log message was reported.
(define resp (make-channel)) (define resp (make-channel))
(channel-put log-done-chan resp) (channel-put log-done-chan resp)
(show-results (channel-get resp)) (show-results (channel-get resp))
(send db enable #f)
(send sb enable #t)
(send sb2 enable #t)
(set! following-log? #f)] (set! following-log? #f)]
[following-bt? [following-bt?
(define resp (make-channel)) (define resp (make-channel))
(channel-put bt-done-chan resp) (channel-put bt-done-chan resp)
(define stacks (channel-get resp)) (define stacks (channel-get resp))
(show-bt-results stacks) (show-bt-results stacks)
(set! following-bt? #f)]
[following-gc-log?
(define resp (make-channel))
(channel-put log-done-chan resp)
(show-gc (channel-get resp))
(set! following-gc-log? #f)])
(send db enable #f) (send db enable #f)
(send sb enable #t) (send sb enable #t)
(send sb2 enable #t) (send sb2 enable #t)
(set! following-bt? #f)])) (send sb3 enable #t))
(show-string (get-output-string sp))) (show-string (get-output-string sp)))
(define (show-string str) (define (show-string str)
@ -141,23 +161,39 @@ log message was reported.
(define following-log? #f) (define following-log? #f)
(define following-bt? #f) (define following-bt? #f)
(define following-gc-log? #f)
(define (sb-callback) (define (sb-callback)
(set! following-log? #t) (set! following-log? #t)
(send sb enable #f) (send sb enable #f)
(send sb2 enable #f) (send sb2 enable #f)
(send sb3 enable #f)
(send db enable #t) (send db enable #t)
(channel-put start-log-chan #t)) (channel-put start-log-chan lr))
(define (start-bt-callback) (define (start-bt-callback)
(set! following-bt? #t) (set! following-bt? #t)
(send sb enable #f) (send sb enable #f)
(send sb2 enable #f) (send sb2 enable #f)
(send sb3 enable #f)
(send db enable #t) (send db enable #t)
(channel-put start-bt-chan #t)) (channel-put start-bt-chan #t))
(define (start-gc-callback)
(set! following-gc-log? #t)
(send sb enable #f)
(send sb2 enable #f)
(send sb3 enable #f)
(send db enable #t)
(channel-put start-log-chan gc-only-lr))
(send f show #t) (send f show #t)
(define (show-gc lst)
(for ([x (in-list lst)])
(printf "~a\n" (vector-ref x 1))))
(define (show-bt-results stacks) (define (show-bt-results stacks)
(define top-frame (make-hash)) (define top-frame (make-hash))
(for ([stack (in-list stacks)]) (for ([stack (in-list stacks)])