add some first-cut logging information to drracket
to track how long events take to be handled
This commit is contained in:
Robby Findler
parent
7e8ac872fe
commit
e89a121ae5
|
|
@ -1,7 +1,8 @@
|
|||
#lang racket/unit
|
||||
|
||||
(require racket/class
|
||||
"drsig.rkt")
|
||||
"drsig.rkt"
|
||||
framework/private/logging-timer)
|
||||
|
||||
(import [prefix drracket:unit: drracket:unit^]
|
||||
[prefix drracket:frame: drracket:frame^]
|
||||
|
|
@ -13,7 +14,7 @@
|
|||
(export drracket:get/extend^)
|
||||
|
||||
(define make-extender
|
||||
(λ (get-base% name)
|
||||
(λ (get-base% name [final-mixin values])
|
||||
(let ([extensions (λ (x) x)]
|
||||
[built-yet? #f]
|
||||
[built #f]
|
||||
|
|
@ -42,7 +43,7 @@
|
|||
(λ ()
|
||||
(unless built-yet?
|
||||
(set! built-yet? #t)
|
||||
(set! built (extensions (get-base%))))
|
||||
(set! built (final-mixin (extensions (get-base%)))))
|
||||
built)))))
|
||||
|
||||
(define (get-base-tab%)
|
||||
|
|
@ -93,4 +94,14 @@
|
|||
(drracket:unit:get-definitions-text%)))))))
|
||||
|
||||
(define-values (extend-definitions-text get-definitions-text)
|
||||
(make-extender get-base-definitions-text% 'definitions-text%))
|
||||
(make-extender get-base-definitions-text%
|
||||
'definitions-text%
|
||||
(let ([add-on-paint-logging
|
||||
(λ (%)
|
||||
(class %
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(log-timeline
|
||||
(format "on-paint method of ~a area: ~a" (object-name this) (* (- right left) (- bottom top)))
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret)))
|
||||
(super-new)))])
|
||||
add-on-paint-logging)))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@
|
|||
racket/class
|
||||
racket/gui/base
|
||||
"drsig.rkt"
|
||||
"local-member-names.rkt")
|
||||
"local-member-names.rkt"
|
||||
framework/private/logging-timer)
|
||||
|
||||
(define op (current-output-port))
|
||||
(define (oprintf . args) (apply fprintf op args))
|
||||
|
|
@ -136,7 +137,7 @@
|
|||
(<= start hash-lang-last-location))
|
||||
|
||||
(unless timer
|
||||
(set! timer (new timer%
|
||||
(set! timer (new logging-timer%
|
||||
[notify-callback
|
||||
(λ ()
|
||||
(when in-module-language?
|
||||
|
|
|
|||
|
|
@ -25,7 +25,9 @@
|
|||
"rep.rkt"
|
||||
"eval-helpers.rkt"
|
||||
"local-member-names.rkt"
|
||||
"rectangle-intersect.rkt")
|
||||
"rectangle-intersect.rkt"
|
||||
|
||||
framework/private/logging-timer)
|
||||
|
||||
(define-runtime-path expanding-place.rkt "expanding-place.rkt")
|
||||
|
||||
|
|
@ -1316,7 +1318,7 @@
|
|||
|
||||
(define compilation-out-of-date? #f)
|
||||
|
||||
(define tmr (new timer% [notify-callback (lambda () (send-off))]))
|
||||
(define tmr (new logging-timer% [notify-callback (lambda () (send-off))]))
|
||||
|
||||
(define cb-proc (λ (sym new-val)
|
||||
(when new-val
|
||||
|
|
@ -1783,7 +1785,7 @@
|
|||
(define lang-wants-big-defs/ints-labels? #f)
|
||||
|
||||
(define recently-typed-timer
|
||||
(new timer%
|
||||
(new logging-timer%
|
||||
[notify-callback
|
||||
(λ ()
|
||||
(update-recently-typed #f)
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@
|
|||
setup/dirs
|
||||
images/icons/misc
|
||||
"../rectangle-intersect.rkt"
|
||||
string-constants)
|
||||
string-constants
|
||||
framework/private/logging-timer)
|
||||
(provide docs-text-mixin
|
||||
docs-editor-canvas-mixin
|
||||
syncheck:add-docs-range
|
||||
|
|
@ -376,7 +377,7 @@
|
|||
[else
|
||||
(super on-event evt)]))
|
||||
|
||||
(define timer (new timer%
|
||||
(define timer (new logging-timer%
|
||||
[notify-callback
|
||||
(λ ()
|
||||
(set! timer-running? #f)
|
||||
|
|
|
|||
|
|
@ -48,7 +48,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
"traversals.rkt"
|
||||
"annotate.rkt"
|
||||
"../tooltip.rkt"
|
||||
"blueboxes-gui.rkt")
|
||||
"blueboxes-gui.rkt"
|
||||
framework/private/logging-timer)
|
||||
(provide tool@)
|
||||
|
||||
(define orig-output-port (current-output-port))
|
||||
|
|
@ -969,7 +970,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
;; Starts or restarts a one-shot arrow draw timer
|
||||
(define/private (start-arrow-draw-timer delay-ms)
|
||||
(unless arrow-draw-timer
|
||||
(set! arrow-draw-timer (make-object timer% (λ () (maybe-update-drawn-arrows)))))
|
||||
(set! arrow-draw-timer (make-object logging-timer% (λ () (maybe-update-drawn-arrows)))))
|
||||
(send arrow-draw-timer start delay-ms #t))
|
||||
|
||||
;; this will be set to a time in the future if arrows shouldn't be drawn until then
|
||||
|
|
@ -1592,7 +1593,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(queue-callback
|
||||
(λ ()
|
||||
(when (unbox bx)
|
||||
(loop val 0)))
|
||||
(log-timeline "continuing replay-compile-comp-trace" (loop val 0))))
|
||||
#f)]
|
||||
[else
|
||||
(process-trace-element defs-text (car val))
|
||||
|
|
@ -2066,9 +2067,12 @@ If the namespace does not, they are colored the unbound color.
|
|||
(drracket:module-language-tools:add-online-expansion-handler
|
||||
online-comp.rkt
|
||||
'go
|
||||
(λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window)
|
||||
replay-compile-comp-trace
|
||||
defs-text
|
||||
val)))))
|
||||
(λ (defs-text val)
|
||||
(log-timeline
|
||||
"replace-compile-comp-trace"
|
||||
(send (send (send defs-text get-canvas) get-top-level-window)
|
||||
replay-compile-comp-trace
|
||||
defs-text
|
||||
val))))))
|
||||
|
||||
(define-runtime-path online-comp.rkt "online-comp.rkt")
|
||||
|
|
|
|||
|
|
@ -44,7 +44,8 @@ module browser threading seems wrong.
|
|||
|
||||
mzlib/date
|
||||
|
||||
framework/private/aspell)
|
||||
framework/private/aspell
|
||||
framework/private/logging-timer)
|
||||
|
||||
(provide unit@)
|
||||
|
||||
|
|
@ -4544,7 +4545,7 @@ module browser threading seems wrong.
|
|||
(define num-running-frames (vector-length running-frames))
|
||||
(define is-running? #f)
|
||||
(define frame 0)
|
||||
(define timer (make-object timer% (λ () (refresh) (yield)) #f))
|
||||
(define timer (make-object logging-timer% (λ () (refresh) (yield)) #f))
|
||||
|
||||
(define/public (set-running r?)
|
||||
(cond [r? (unless is-running? (set! frame 4))
|
||||
|
|
|
|||
|
|
@ -15,7 +15,8 @@ added get-regions
|
|||
string-constants
|
||||
"../preferences.rkt"
|
||||
"sig.rkt"
|
||||
"aspell.rkt")
|
||||
"aspell.rkt"
|
||||
framework/private/logging-timer)
|
||||
|
||||
(import [prefix icon: framework:icon^]
|
||||
[prefix mode: framework:mode^]
|
||||
|
|
@ -519,7 +520,7 @@ added get-regions
|
|||
exn))
|
||||
(set! tok-cor #f))))
|
||||
#;(printf "begin lexing\n")
|
||||
(when (coroutine-run 10 tok-cor)
|
||||
(when (log-timeline "colorer coroutine" (coroutine-run 10 tok-cor))
|
||||
(for-each (lambda (ls)
|
||||
(set-lexer-state-up-to-date?! ls #t))
|
||||
lexer-states)
|
||||
|
|
|
|||
66
collects/framework/private/logging-timer.rkt
Normal file
66
collects/framework/private/logging-timer.rkt
Normal file
|
|
@ -0,0 +1,66 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/gui/base
|
||||
racket/class
|
||||
(for-syntax racket/base))
|
||||
|
||||
(define timeline-logger (make-logger 'timeline (current-logger)))
|
||||
|
||||
(provide logging-timer%
|
||||
(struct-out timeline-info)
|
||||
log-timeline)
|
||||
|
||||
(define logging-timer%
|
||||
(class timer%
|
||||
(init notify-callback)
|
||||
(define name (object-name notify-callback))
|
||||
(define wrapped-notify-callback
|
||||
(λ ()
|
||||
(log-timeline
|
||||
(format "~a timer fired" name)
|
||||
(notify-callback))))
|
||||
(super-new [notify-callback wrapped-notify-callback])
|
||||
(define/override (start msec [just-once? #f])
|
||||
(log-timeline (format "~a timer started; msec ~s just-once? ~s" name msec just-once?))
|
||||
(super start msec just-once?))))
|
||||
|
||||
|
||||
(define-syntax (log-timeline stx)
|
||||
(syntax-case stx ()
|
||||
[(_ info-string expr)
|
||||
#'(log-timeline/proc
|
||||
(and (log-level? timeline-logger 'debug)
|
||||
info-string)
|
||||
(λ () expr))]
|
||||
[(_ info-string)
|
||||
#'(log-timeline/proc
|
||||
(and (log-level? timeline-logger 'debug)
|
||||
info-string)
|
||||
#f)]))
|
||||
|
||||
(define (log-timeline/proc info expr)
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(when info
|
||||
(log-message timeline-logger 'debug
|
||||
(format "~a start" info)
|
||||
(timeline-info (if expr 'start 'once)
|
||||
(current-process-milliseconds)
|
||||
start-time)))
|
||||
(when expr
|
||||
(begin0
|
||||
(expr)
|
||||
(when info
|
||||
(define end-time (current-inexact-milliseconds))
|
||||
(log-message timeline-logger 'debug
|
||||
(format "~a end; delta ms ~a" info (- end-time start-time))
|
||||
(timeline-info start-time
|
||||
end-time
|
||||
(current-inexact-milliseconds)))))))
|
||||
|
||||
|
||||
;; what : (or/c 'start 'once flonum)
|
||||
;; flonum means that this is an 'end' event and there should be
|
||||
;; a start event corresponding to it with that milliseconds
|
||||
;; process-milliseconds : fixnum
|
||||
;; milliseconds : flonum -- time of this event
|
||||
(struct timeline-info (what process-milliseconds milliseconds) #:transparent)
|
||||
|
|
@ -11,7 +11,8 @@
|
|||
"autocomplete.rkt"
|
||||
mred/mred-sig
|
||||
mrlib/interactive-value-port
|
||||
racket/list)
|
||||
racket/list
|
||||
"logging-timer.rkt")
|
||||
(require setup/xref
|
||||
scribble/xref
|
||||
scribble/manual-struct)
|
||||
|
|
@ -1063,7 +1064,7 @@
|
|||
(when searching-str
|
||||
(unless timer
|
||||
(set! timer
|
||||
(new timer%
|
||||
(new logging-timer%
|
||||
[notify-callback
|
||||
(λ ()
|
||||
(run-after-edit-sequence
|
||||
|
|
@ -1536,7 +1537,7 @@
|
|||
;; have not yet been propogated to the delegate
|
||||
(define todo '())
|
||||
|
||||
(define timer (new timer%
|
||||
(define timer (new logging-timer%
|
||||
[notify-callback
|
||||
(λ ()
|
||||
;; it should be the case that todo is always '() when the delegate is #f
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user