From 75ea19d0f4cb10647ec199cde0f0b7544a9edeb5 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 25 Oct 2012 16:57:38 -0500
Subject: [PATCH] add some first-cut logging information to drracket to track
 how long events take to be handled

original commit: e89a121ae5e42366702a4674cd79b339151175a3
---
 collects/framework/private/color.rkt         |  5 +-
 collects/framework/private/logging-timer.rkt | 66 ++++++++++++++++++++
 collects/framework/private/text.rkt          |  7 ++-
 3 files changed, 73 insertions(+), 5 deletions(-)
 create mode 100644 collects/framework/private/logging-timer.rkt

diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt
index ed3196ef..7a6102c5 100644
--- a/collects/framework/private/color.rkt
+++ b/collects/framework/private/color.rkt
@@ -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)
diff --git a/collects/framework/private/logging-timer.rkt b/collects/framework/private/logging-timer.rkt
new file mode 100644
index 00000000..0c9ad724
--- /dev/null
+++ b/collects/framework/private/logging-timer.rkt
@@ -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)
diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt
index 9e8d8d7a..d66f8579 100644
--- a/collects/framework/private/text.rkt
+++ b/collects/framework/private/text.rkt
@@ -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