added PLTDRPROFILE

svn: r15130

collects/drscheme/drscheme.ss

@@ -3,6 +3,7 @@
 (require "private/key.ss")
 
 (define debugging? (getenv "PLTDRDEBUG"))
+(define profiling? (getenv "PLTDRPROFILE"))
 
 (define install-cm? (and (not debugging?)
                          (getenv "PLTDRCM")))
@@ -52,4 +53,11 @@
       (manager-trace-handler
        (λ (x) (display "1: ") (display x) (newline) (flush-output))))))
 
+(when profiling?
+  (flprintf "PLTDRPROFILE: installing profiler\n")
+  (let ([orig-cust (current-custodian)]
+        [new-cust (make-custodian)])
+    (current-custodian new-cust)
+    ((dynamic-require 'drscheme/private/profile-drs 'start-profile) orig-cust)))
+
 (dynamic-require 'drscheme/private/drscheme-normal #f)

collects/drscheme/private/profile-drs.ss

@@ -0,0 +1,104 @@
+#lang scheme/base
+(require scheme/gui/base
+         scheme/class
+         profile/sampler
+         profile/render-text
+         profile/analyzer
+         framework/preferences)
+
+#|
+
+This file is loaded early in drscheme's startup when the PLTDRPROFILE
+environment variable is setup. It sets up a profiler to examine drscheme
+itself.
+
+|#
+
+(provide start-profile)
+
+(define (start-profile super-custodian)
+  (define drs-custodian (current-custodian))
+  (define profile-eventspace
+    (parameterize ([current-custodian super-custodian])
+      (make-eventspace)))
+  (define frame (parameterize ([current-eventspace profile-eventspace])
+                  (new frame% [label "Profiling"] [width 500] [height 550])))
+  (define t (let ([t (new text%)])
+              (send t lock #t)
+              t))
+  (define ec (new editor-canvas% [parent frame] [editor t]))
+  (define bp (new horizontal-panel% [parent frame] [stretchable-height #f]))
+  (define pause-b (new button% [label "Pause"] [parent bp] [callback (λ (a b) (pause))] [stretchable-width #t]))
+  (define resume-b (new button% [label "Resume"] [parent bp] [callback (λ (a b) (resume))] [stretchable-width #t]))
+  (define start-stop-b (new button% [label "Stop"] [parent bp] [callback (λ (a b) (start-stop))] [stretchable-width #t]))
+  (define choice (new choice% [label #f] [choices '("9" "10" "12")] [parent bp] [callback (λ (a b) (font-size))]))
+  
+  (define (font-size)
+    (let ([n (send choice get-string-selection)])
+      (when n
+        (send sd set-delta 'change-size (string->number n))
+        (update-profile-report))))
+  
+  (define (update-buttons)
+    (send resume-b enable (and current-sampler (not running?)))
+    (send pause-b enable (and current-sampler running?))
+    (send start-stop-b set-label (if current-sampler
+                                "Stop"
+                                "Start")))
+  
+  (define running? #f)
+  (define current-sampler #f)
+  (define (start-sampler)
+    (let ([s (create-sampler drs-custodian 1/2 super-custodian)])
+      (set! current-sampler s)))
+  (define (stop-sampler)
+    (current-sampler 'stop)
+    (set! current-sampler #f)
+    (set! running? #f))
+
+  (define sd (let ([sd (make-object style-delta%)])
+               (send sd set-delta 'change-size 9)
+               (send sd set-family 'modern)
+               sd))
+  
+  (define updating-thread 
+    (parameterize ([current-custodian super-custodian]
+                   [current-eventspace profile-eventspace])
+      (thread (λ ()
+                (let loop ()
+                  (queue-callback update-profile-report)
+                  (sleep 5) 
+                  (loop))))))
+  
+  (define (update-profile-report)
+    (when current-sampler
+      (send t begin-edit-sequence)
+      (send t lock #f)
+      (send t erase)
+      (parameterize ([current-output-port (open-output-text-editor t)])
+        (render (analyze-samples (current-sampler 'get-snapshots))))
+      (send t change-style sd 0 (send t last-position))
+      (send t set-position 0)
+      (send t lock #t)
+      (send t end-edit-sequence)))
+  
+  (define (resume) 
+    (set! running? #t)
+    (current-sampler 'resume)
+    (update-buttons))
+  (define (pause) 
+    (set! running? #f)
+    (current-sampler 'pause)
+    (update-buttons)
+    (update-profile-report))
+  (define (start-stop) 
+    (cond
+      [current-sampler (stop-sampler)]
+      [else 
+       (start-sampler)
+       (set! running? #t)])
+    (update-profile-report)
+    (update-buttons))
+
+  (update-buttons)
+  (send frame show #t))

collects/framework/preferences.ss

@@ -1,5 +1,5 @@
 #reader scribble/reader
-#lang scheme/gui
+#lang scheme/base
 #|
 
 There are three attributes for each preference:
@@ -27,7 +27,8 @@ the state transitions / contracts are:
 
 |#
 
-(require scribble/srcdoc)
+(require scribble/srcdoc scheme/class scheme/gui/base 
+         scheme/contract scheme/file)
 (require/doc scheme/base scribble/manual)
 
 (provide exn:struct:unknown-preference)

collects/scribblings/drscheme/extending.scrbl

@@ -135,6 +135,10 @@ Several environment variables can affect DrScheme's behavior:
        variable is set to @litchar{profile}, DrScheme also records
        profiling information about itself.}
 
+ @item{@indexed-envvar{PLTDRPROFILE} : When this environment variable is
+       set, DrScheme uses the @schememodname[profile] library (with
+       a little GUI) to collect profiling information about itself.}
+
  @item{@indexed-envvar{PLTDRBREAK} : When this environment variable is
        set, DrScheme creates a window with a break button, during
        startup. Clicking the button breaks DrScheme's eventspace's