From 741be85f07f6d9fc66f3fa7ea9f679a2d9ad2c2a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Nov 2012 16:06:43 -0600 Subject: [PATCH] make the log follower always available in DrRacket --- collects/framework/private/follow-log.rkt | 151 ++++++++++++++++++++++ collects/framework/private/frame.rkt | 18 ++- 2 files changed, 165 insertions(+), 4 deletions(-) create mode 100644 collects/framework/private/follow-log.rkt diff --git a/collects/framework/private/follow-log.rkt b/collects/framework/private/follow-log.rkt new file mode 100644 index 0000000000..e45f9354a9 --- /dev/null +++ b/collects/framework/private/follow-log.rkt @@ -0,0 +1,151 @@ +#lang racket/base + +(require racket/list + racket/class + racket/match + racket/pretty + racket/gui/base + framework/private/logging-timer) + +#| + +This file sets up a log receiver and then +starts up DrRacket. It catches log messages and +organizes them on event boundaries, printing +out the ones that take the longest +(possibly dropping those where a gc occurs) + +The result shows, for each gui event, the +log messages that occured during its dynamic +extent as well as the number of milliseconds +from the start of the gui event before the +log message was reported. + +|# + + +(define lr (make-log-receiver (current-logger) + 'debug 'racket/engine + 'debug 'GC + 'debug 'gui-event + 'debug 'framework/colorer + 'debug 'timeline)) + +(define top-n-events 50) +(define drop-gc? #t) +(define start-right-away? #f) + +(define done-chan (make-channel)) +(define start-chan (make-channel)) +(void + (thread + (λ () + (let loop () + (sync start-chan) + (let loop ([events '()]) + (sync + (handle-evt + lr + (λ (info) + (loop (cons info events)))) + (handle-evt + done-chan + (λ (resp-chan) + (channel-put resp-chan events))))) + (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"] [parent f] + [callback + (λ (_1 _2) + (sb-callback))])) +(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] + [callback + (λ (_1 _2) + (define resp (make-channel)) + (channel-put done-chan resp) + (show-results (channel-get resp)) + (send db enable #f) + (send sb enable #t))])) +(define (sb-callback) + (send sb enable #f) + (send db enable #t) + (channel-put start-chan #t)) +(send f show #t) + +(struct gui-event (start end name) #:prefab) + +(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 interesting-gui-events + (take (sort gui-events > #:key (λ (x) + (define i (vector-ref x 2)) + (- (gui-event-end i) + (gui-event-start i)))) + 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))) + +(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])) + + +(module+ main + (when start-right-away? + (parameterize ([current-eventspace controller-frame-eventspace]) + (queue-callback sb-callback))) + (dynamic-require 'drracket #f)) + diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 215dab0786..1464406f3a 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -796,9 +796,14 @@ [ec (new position-canvas% [parent panel] [button-up - (λ () - (collect-garbage) - (update-memory-text))] + (λ (evt) + (cond + [(or (send evt get-alt-down) + (send evt get-control-down)) + (dynamic-require 'framework/private/follow-log #f)] + [else + (collect-garbage) + (update-memory-text)]))] [init-width "99.99 MB"])]) (set! memory-canvases (cons ec memory-canvases)) (update-memory-text) @@ -890,6 +895,7 @@ (inherit min-client-height min-client-width get-dc get-client-size refresh) (init init-width) (init-field [button-up #f]) + (init-field [char-typed void]) (define str "") (define/public (set-str _str) (set! str _str) @@ -913,7 +919,11 @@ (let-values ([(cw ch) (get-client-size)]) (when (and (<= (send evt get-x) cw) (<= (send evt get-y) ch)) - (button-up)))))) + (if (procedure-arity-includes? button-up 1) + (button-up evt) + (button-up))))))) + (define/override (on-char evt) + (char-typed evt)) (super-new (style '(transparent no-focus))) (let ([dc (get-dc)]) (let-values ([(_1 th _2 _3) (send dc get-text-extent str)])