325 lines
10 KiB
Racket
325 lines
10 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/list
|
|
racket/class
|
|
racket/match
|
|
racket/pretty
|
|
racket/gui/base
|
|
framework/private/logging-timer)
|
|
|
|
(provide stop-and-dump
|
|
sb-callback
|
|
controller-frame-eventspace)
|
|
|
|
(define lr (make-log-receiver (current-logger)
|
|
'debug 'racket/engine
|
|
'debug 'GC
|
|
'debug 'gui-event
|
|
'debug 'framework/colorer
|
|
'debug 'timeline))
|
|
(define gc-only-lr
|
|
(make-log-receiver (current-logger)
|
|
'debug 'GC))
|
|
|
|
(define top-n-events 30)
|
|
(define drop-gc? #f)
|
|
(define interesting-range-start 26)
|
|
(define interesting-range-end +inf.0)
|
|
|
|
(define log-done-chan (make-channel))
|
|
(define bt-done-chan (make-channel))
|
|
|
|
(define start-log-chan (make-channel))
|
|
(void
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(define lr (sync start-log-chan))
|
|
(let loop ([events '()])
|
|
(sync
|
|
(handle-evt
|
|
lr
|
|
(λ (info)
|
|
(loop (cons info events))))
|
|
(handle-evt
|
|
log-done-chan
|
|
(λ (resp-chan)
|
|
(channel-put resp-chan events)))))
|
|
(loop)))))
|
|
|
|
(define thread-to-watch (current-thread))
|
|
(let ([win (get-top-level-windows)])
|
|
(unless (null? win)
|
|
(define fr-thd (eventspace-handler-thread (send (car win) get-eventspace)))
|
|
(unless (eq? thread-to-watch fr-thd)
|
|
(eprintf "WARNING: current-thread and eventspace thread aren't the same thread\n"))))
|
|
(define start-bt-chan (make-channel))
|
|
(void
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(sync start-bt-chan)
|
|
(let loop ([marks '()])
|
|
(sync
|
|
(handle-evt
|
|
(alarm-evt (+ (current-inexact-milliseconds) 10))
|
|
(λ (_)
|
|
(loop (cons (continuation-marks thread-to-watch)
|
|
marks))))
|
|
(handle-evt
|
|
bt-done-chan
|
|
(λ (resp-chan)
|
|
(define stacks (map continuation-mark-set->context marks))
|
|
(channel-put resp-chan stacks)))))
|
|
(loop)))))
|
|
|
|
(define controller-frame-eventspace (make-eventspace))
|
|
(define f (parameterize ([current-eventspace controller-frame-eventspace])
|
|
(new frame% [label "Log Follower"])))
|
|
(define sb (new button% [label "Start Following Log"] [parent f]
|
|
[callback
|
|
(λ (_1 _2)
|
|
(sb-callback))]))
|
|
(define sb2 (new button% [label "Start Collecting Backtraces"] [parent f]
|
|
[callback
|
|
(λ (_1 _2)
|
|
(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]
|
|
[callback
|
|
(λ (_1 _2)
|
|
(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 sp (open-output-string))
|
|
(parameterize ([current-output-port sp])
|
|
(cond
|
|
[following-log?
|
|
(define resp (make-channel))
|
|
(channel-put log-done-chan resp)
|
|
(show-results (channel-get resp))
|
|
(set! following-log? #f)]
|
|
[following-bt?
|
|
(define resp (make-channel))
|
|
(channel-put bt-done-chan resp)
|
|
(define stacks (channel-get resp))
|
|
(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 sb enable #t)
|
|
(send sb2 enable #t)
|
|
(send sb3 enable #t))
|
|
(show-string (get-output-string sp)))
|
|
|
|
(define (show-string str)
|
|
(define t (new text%))
|
|
(send t insert str)
|
|
(send t change-style (make-object style-delta% 'change-family 'modern)
|
|
0
|
|
(send t last-position))
|
|
(define f (new frame% [width 600] [height 800] [label "Log Follower Results"]))
|
|
(define ec (new editor-canvas% [parent f] [editor t]))
|
|
(define mb (new menu-bar% [parent f]))
|
|
(define edit-menu (new menu% [label "Edit"] [parent mb]))
|
|
(append-editor-operation-menu-items edit-menu)
|
|
(send f show #t))
|
|
|
|
(define following-log? #f)
|
|
(define following-bt? #f)
|
|
(define following-gc-log? #f)
|
|
|
|
(define (sb-callback)
|
|
(set! following-log? #t)
|
|
(send sb enable #f)
|
|
(send sb2 enable #f)
|
|
(send sb3 enable #f)
|
|
(send db enable #t)
|
|
(channel-put start-log-chan lr))
|
|
|
|
(define (start-bt-callback)
|
|
(set! following-bt? #t)
|
|
(send sb enable #f)
|
|
(send sb2 enable #f)
|
|
(send sb3 enable #f)
|
|
(send db enable #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)
|
|
|
|
(define (show-gc lst)
|
|
(for ([x (in-list lst)])
|
|
(printf "~a\n" (vector-ref x 1))))
|
|
|
|
(define (show-bt-results stacks)
|
|
(define top-frame (make-hash))
|
|
(for ([stack (in-list stacks)])
|
|
(unless (null? stack)
|
|
(define k (car stack))
|
|
(hash-set! top-frame k (cons stack (hash-ref top-frame k '())))))
|
|
(define sorted (sort (hash-map top-frame (λ (x y) y)) > #:key length))
|
|
(printf "top 10: ~s\n" (map length (take sorted (min (length sorted) 10))))
|
|
(define most-popular (car sorted))
|
|
(for ([x (in-range 10)])
|
|
(printf "---- next stack\n")
|
|
(pretty-print (list-ref most-popular (random (length most-popular))))
|
|
(printf "\n"))
|
|
(void))
|
|
|
|
(struct gui-event (start end name) #:prefab)
|
|
|
|
(define (print-gui-event-hist gui-events)
|
|
(print-hist
|
|
(for/list ([gui-event (in-list gui-events)])
|
|
(gui-event->delta gui-event))))
|
|
|
|
(define (print-hist nums)
|
|
(define bucket-size 2) ;; in milliseconds
|
|
(define (δ->bucket δ)
|
|
(* bucket-size
|
|
(inexact->exact (round (* δ (/ 1.0 bucket-size))))))
|
|
|
|
(define buckets (make-hash))
|
|
(for ([num (in-list nums)])
|
|
(define bucket (δ->bucket num))
|
|
(hash-set! buckets bucket (+ (hash-ref buckets bucket 0) 1)))
|
|
(pretty-print
|
|
(sort (hash-map buckets vector)
|
|
<
|
|
#:key (λ (x) (vector-ref x 0)))))
|
|
|
|
(define (gui-event->delta x)
|
|
(define i (vector-ref x 2))
|
|
(- (gui-event-end i)
|
|
(gui-event-start i)))
|
|
|
|
(define (show-results evts)
|
|
(define gui-events (filter (λ (x)
|
|
(define i (vector-ref x 2))
|
|
(and (gui-event? i)
|
|
(number? (gui-event-end i))))
|
|
evts))
|
|
|
|
(define (show-hist)
|
|
(define gc-starts+ends
|
|
(filter
|
|
values
|
|
(for/list ([evt (in-list evts)])
|
|
(cond
|
|
[(gc-info? (vector-ref evt 2))
|
|
(cons (gc-info-start-time (vector-ref evt 2))
|
|
(gc-info-end-time (vector-ref evt 2)))]
|
|
[else #f]))))
|
|
|
|
(printf "gc deltas\n")
|
|
(print-hist (map (λ (x) (- (cdr x) (car x))) gc-starts+ends))
|
|
|
|
(define (has-a-gc? evt-vec)
|
|
(define evt (vector-ref evt-vec 2))
|
|
(for/or ([gc-start+end (in-list gc-starts+ends)])
|
|
(<= (gui-event-start evt)
|
|
(car gc-start+end)
|
|
(gui-event-end evt))))
|
|
|
|
(define-values (has-gc-events no-gc-events)
|
|
(partition has-a-gc? gui-events))
|
|
(printf "\nwith gc\n")
|
|
(print-gui-event-hist has-gc-events)
|
|
(printf "\nwithout gc\n")
|
|
(print-gui-event-hist no-gc-events)
|
|
(printf "\nboth with and without gc\n")
|
|
(print-gui-event-hist gui-events))
|
|
|
|
(define (show-top-events)
|
|
(define interesting-gui-events
|
|
(let ([candidate-events
|
|
(sort (filter (λ (x)
|
|
(<= interesting-range-start
|
|
(gui-event->delta x)
|
|
interesting-range-end))
|
|
gui-events)
|
|
>
|
|
#:key gui-event->delta)])
|
|
(take candidate-events (min (length candidate-events) top-n-events))))
|
|
|
|
(define with-other-events
|
|
(for/list ([gui-evt (in-list interesting-gui-events)])
|
|
(match (vector-ref gui-evt 2)
|
|
[(gui-event start end name)
|
|
(define in-the-middle
|
|
(append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x))
|
|
(sort
|
|
(filter (λ (x) (and (not (gui-event? (vector-ref x 2)))
|
|
(<= start (get-start-time x) end)))
|
|
evts)
|
|
<
|
|
#:key get-start-time))
|
|
(list (list (list 'δ (- end start)) 'end-of-gui-event))))
|
|
(list* (- end start)
|
|
gui-evt
|
|
in-the-middle)])))
|
|
|
|
(define (has-a-gc-event? x)
|
|
(define in-the-middle (cddr x))
|
|
(ormap (λ (x)
|
|
(and (vector? (list-ref x 1))
|
|
(gc-info? (vector-ref (list-ref x 1) 2))))
|
|
in-the-middle))
|
|
|
|
(pretty-print
|
|
(if drop-gc?
|
|
(filter (λ (x) (not (has-a-gc-event? x)))
|
|
with-other-events)
|
|
with-other-events)))
|
|
|
|
(show-top-events)
|
|
(printf "\n\n============================================================\n\n\n")
|
|
(show-hist))
|
|
|
|
(struct gc-info (major? pre-amount pre-admin-amount code-amount
|
|
post-amount post-admin-amount
|
|
start-process-time end-process-time
|
|
start-time end-time)
|
|
#:prefab)
|
|
(struct engine-info (msec name) #:prefab)
|
|
|
|
(define (get-start-time x)
|
|
(cond
|
|
[(gc-info? (vector-ref x 2))
|
|
(gc-info-start-time (vector-ref x 2))]
|
|
[(engine-info? (vector-ref x 2))
|
|
(engine-info-msec (vector-ref x 2))]
|
|
[(regexp-match #rx"framework" (vector-ref x 1))
|
|
(vector-ref x 2)]
|
|
[(timeline-info? (vector-ref x 2))
|
|
(timeline-info-milliseconds (vector-ref x 2))]
|
|
[else
|
|
(unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1))
|
|
(eprintf "unk: ~s\n" x))
|
|
0]))
|