|
14 | 14 | (define traces-table (make-hash)) |
15 | 15 | (let loop ([i 0]) |
16 | 16 | (sleep pause-time) |
17 | | - (let ([new-traces |
18 | | - (map (λ (t) (continuation-mark-set->context (continuation-marks t))) |
19 | | - (get-threads))]) |
20 | | - (for-each |
21 | | - (λ (trace) |
22 | | - (for-each |
23 | | - (λ (line) |
24 | | - (hash-set! traces-table line (cons trace (hash-ref traces-table line '())))) |
25 | | - trace)) |
26 | | - new-traces) |
27 | | - (cond |
28 | | - [(zero? i) |
29 | | - (update-gui traces-table) |
30 | | - (loop update-frequency)] |
31 | | - [else |
32 | | - (loop (- i 1))])))))) |
| 17 | + (define new-traces |
| 18 | + (map (λ (t) (continuation-mark-set->context (continuation-marks t))) (get-threads))) |
| 19 | + (for-each (λ (trace) |
| 20 | + (for-each (λ (line) |
| 21 | + (hash-set! traces-table |
| 22 | + line |
| 23 | + (cons trace (hash-ref traces-table line '())))) |
| 24 | + trace)) |
| 25 | + new-traces) |
| 26 | + (cond |
| 27 | + [(zero? i) |
| 28 | + (update-gui traces-table) |
| 29 | + (loop update-frequency)] |
| 30 | + [else (loop (- i 1))]))))) |
33 | 31 |
|
34 | 32 | (define (format-fn-name i) |
35 | | - (let ([id (car i)] |
36 | | - [src (cdr i)]) |
37 | | - (cond |
38 | | - [id (format "~a" id)] |
39 | | - [src |
40 | | - (format "~a:~a~a" |
41 | | - (cond |
42 | | - [(path? (srcloc-source src)) |
43 | | - (let-values ([(base name dir?) (split-path (srcloc-source src))]) |
44 | | - name)] |
45 | | - [else (srcloc-source src)]) |
46 | | - (if (srcloc-line src) |
47 | | - (format "~a:~a" |
48 | | - (srcloc-line src) |
49 | | - (srcloc-column src)) |
50 | | - (srcloc-position src)) |
51 | | - (if id |
52 | | - (format ": ~a" id) |
53 | | - ""))] |
54 | | - [else "???"]))) |
| 33 | + (define id (car i)) |
| 34 | + (define src (cdr i)) |
| 35 | + (cond |
| 36 | + [id (format "~a" id)] |
| 37 | + [src |
| 38 | + (format "~a:~a~a" |
| 39 | + (cond |
| 40 | + [(path? (srcloc-source src)) |
| 41 | + (let-values ([(base name dir?) (split-path (srcloc-source src))]) |
| 42 | + name)] |
| 43 | + [else (srcloc-source src)]) |
| 44 | + (if (srcloc-line src) |
| 45 | + (format "~a:~a" (srcloc-line src) (srcloc-column src)) |
| 46 | + (srcloc-position src)) |
| 47 | + (if id |
| 48 | + (format ": ~a" id) |
| 49 | + ""))] |
| 50 | + [else "???"])) |
55 | 51 |
|
56 | 52 | (define (insert-long-fn-name t i) |
57 | 53 | (send t begin-edit-sequence) |
|
76 | 72 | (send t end-edit-sequence)) |
77 | 73 |
|
78 | 74 | (define (format-percentage n) |
79 | | - (let ([trunc (floor (* n 100))]) |
80 | | - (format "~a%" (pad3 trunc)))) |
| 75 | + (define trunc (floor (* n 100))) |
| 76 | + (format "~a%" (pad3 trunc))) |
81 | 77 |
|
82 | 78 | (define (pad3 n) |
83 | 79 | (cond |
|
110 | 106 | (define/override (on-event event) |
111 | 107 | (cond |
112 | 108 | [(send event button-up? 'left) |
113 | | - (let ([admin (get-admin)]) |
114 | | - (when admin |
115 | | - (let ([dc (send admin get-dc)]) |
116 | | - (let-values ([(x y) (dc-location-to-editor-location (send event get-x) |
117 | | - (send event get-y))]) |
118 | | - (let* ([loc (find-position x y)] |
119 | | - [para (position-paragraph loc)]) |
120 | | - (set! clicked-srcloc-pr (and (<= 0 para (last-paragraph)) |
121 | | - (car (list-ref gui-display-data para)))) |
122 | | - (update-gui-display))))))] |
| 109 | + (define admin (get-admin)) |
| 110 | + (when admin |
| 111 | + (let ([dc (send admin get-dc)]) |
| 112 | + (let-values ([(x y) (dc-location-to-editor-location (send event get-x) |
| 113 | + (send event get-y))]) |
| 114 | + (let* ([loc (find-position x y)] |
| 115 | + [para (position-paragraph loc)]) |
| 116 | + (set! clicked-srcloc-pr |
| 117 | + (and (<= 0 para (last-paragraph)) (car (list-ref gui-display-data para)))) |
| 118 | + (update-gui-display)))))] |
123 | 119 | [else (void)])) |
124 | 120 |
|
125 | 121 | (define/public (set-gui-display-data/refresh traces-table) |
|
140 | 136 | (set! line-to-source (make-hasheq)) |
141 | 137 | (clear-old-pr) |
142 | 138 | (set! clear-old-pr void) |
143 | | - (let* ([denom-ht (make-hasheq)] |
144 | | - [filtered-gui-display-data |
145 | | - (map |
146 | | - (λ (pr) |
147 | | - (let ([id (car pr)] |
148 | | - [stacks (filter-stacks (cdr pr))]) |
149 | | - (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks) |
150 | | - (cons id stacks))) |
151 | | - gui-display-data)] |
152 | | - [denom-count (hash-count denom-ht)]) |
153 | | - (let loop ([prs filtered-gui-display-data] |
154 | | - [first? #t] |
155 | | - [i 0]) |
156 | | - (cond |
157 | | - [(null? prs) (void)] |
158 | | - [else |
159 | | - (let* ([pr (car prs)] |
160 | | - [fn (car pr)] |
161 | | - [count (length (cdr pr))]) |
162 | | - (cond |
163 | | - [(zero? count) |
164 | | - (loop (cdr prs) first? i)] |
165 | | - [else |
166 | | - (unless first? (insert "\n")) |
167 | | - (let ([before (last-position)]) |
168 | | - (hash-set! line-to-source i pr) |
169 | | - (insert (format-percentage (/ count denom-count))) |
170 | | - (insert (format " ~a" (format-fn-name fn))) |
171 | | - (let ([after (last-position)]) |
172 | | - (when (equal? (car pr) clicked-srcloc-pr) |
173 | | - (set! clear-old-pr (highlight-range before after "NavajoWhite"))))) |
174 | | - (loop (cdr prs) #f (+ i 1))]))])) |
175 | | - (lock #t) |
176 | | - (end-edit-sequence) |
177 | | - (update-info-editor clicked-srcloc-pr) |
178 | | - (send open-button enable (and clicked-srcloc-pr (path? (srcloc-source (cdr clicked-srcloc-pr))))))) |
| 139 | + (define denom-ht (make-hasheq)) |
| 140 | + (define filtered-gui-display-data |
| 141 | + (map (λ (pr) |
| 142 | + (let ([id (car pr)] |
| 143 | + [stacks (filter-stacks (cdr pr))]) |
| 144 | + (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks) |
| 145 | + (cons id stacks))) |
| 146 | + gui-display-data)) |
| 147 | + (define denom-count (hash-count denom-ht)) |
| 148 | + (let loop ([prs filtered-gui-display-data] |
| 149 | + [first? #t] |
| 150 | + [i 0]) |
| 151 | + (cond |
| 152 | + [(null? prs) (void)] |
| 153 | + [else |
| 154 | + (let* ([pr (car prs)] |
| 155 | + [fn (car pr)] |
| 156 | + [count (length (cdr pr))]) |
| 157 | + (cond |
| 158 | + [(zero? count) (loop (cdr prs) first? i)] |
| 159 | + [else |
| 160 | + (unless first? |
| 161 | + (insert "\n")) |
| 162 | + (let ([before (last-position)]) |
| 163 | + (hash-set! line-to-source i pr) |
| 164 | + (insert (format-percentage (/ count denom-count))) |
| 165 | + (insert (format " ~a" (format-fn-name fn))) |
| 166 | + (let ([after (last-position)]) |
| 167 | + (when (equal? (car pr) clicked-srcloc-pr) |
| 168 | + (set! clear-old-pr (highlight-range before after "NavajoWhite"))))) |
| 169 | + (loop (cdr prs) #f (+ i 1))]))])) |
| 170 | + (lock #t) |
| 171 | + (end-edit-sequence) |
| 172 | + (update-info-editor clicked-srcloc-pr) |
| 173 | + (send open-button enable |
| 174 | + (and clicked-srcloc-pr (path? (srcloc-source (cdr clicked-srcloc-pr)))))) |
179 | 175 |
|
180 | 176 | (define/private (filter-stacks stacks) |
181 | 177 | (cond |
|
187 | 183 |
|
188 | 184 | (define/public (open-current-pr) |
189 | 185 | (when clicked-srcloc-pr |
190 | | - (let ([src (cdr clicked-srcloc-pr)]) |
191 | | - (when (path? (srcloc-source src)) |
192 | | - (printf "open ~s\n" (srcloc-source src)) |
193 | | - (when (number? (srcloc-position src)) |
194 | | - (printf "go to ~s\n" (srcloc-position src))))))) |
| 186 | + (define src (cdr clicked-srcloc-pr)) |
| 187 | + (when (path? (srcloc-source src)) |
| 188 | + (printf "open ~s\n" (srcloc-source src)) |
| 189 | + (when (number? (srcloc-position src)) |
| 190 | + (printf "go to ~s\n" (srcloc-position src)))))) |
195 | 191 |
|
196 | 192 | (define/private (update-info-editor pr) |
197 | 193 | (send vp change-children (λ (l) (if pr (list ec1 lp) (list ec1)))) |
|
295 | 291 | (define show/hide-menu-item #f) |
296 | 292 |
|
297 | 293 | (define/public (show/hide-sprof-panel show?) |
298 | | - (let ([main-children (send main-panel get-children)]) |
299 | | - (send show/hide-menu-item |
300 | | - set-label |
301 | | - (if show? sc-hide-sprof sc-show-sprof)) |
302 | | - (unless (or (and show? (= 2 (length main-children))) |
303 | | - (and (not show?) (= 1 (length main-children)))) |
304 | | - (send main-panel change-children |
305 | | - (λ (l) |
306 | | - (if show? |
307 | | - (list everything-else sprof-main-panel) |
308 | | - (list everything-else))))))) |
| 294 | + (define main-children (send main-panel get-children)) |
| 295 | + (send show/hide-menu-item set-label (if show? sc-hide-sprof sc-show-sprof)) |
| 296 | + (unless (or (and show? (= 2 (length main-children))) |
| 297 | + (and (not show?) (= 1 (length main-children)))) |
| 298 | + (send main-panel change-children |
| 299 | + (λ (l) |
| 300 | + (if show? |
| 301 | + (list everything-else sprof-main-panel) |
| 302 | + (list everything-else)))))) |
309 | 303 |
|
310 | 304 | (define/override (make-root-area-container cls parent) |
311 | 305 | (set! main-panel (super make-root-area-container panel:horizontal-dragable% parent)) |
|
377 | 371 | (mixin (drscheme:rep:text<%>) () |
378 | 372 | (inherit get-user-custodian) |
379 | 373 | (define/public (get-threads-to-profile) |
380 | | - (let ([thds '()]) |
381 | | - (let loop ([cust (get-user-custodian)]) |
382 | | - (for-each |
383 | | - (λ (obj) |
384 | | - (cond |
385 | | - [(custodian? obj) (loop obj)] |
386 | | - [(thread? obj) (set! thds (cons obj thds))])) |
387 | | - (custodian-managed-list cust system-custodian))) |
388 | | - thds)) |
| 374 | + (define thds '()) |
| 375 | + (let loop ([cust (get-user-custodian)]) |
| 376 | + (for-each (λ (obj) |
| 377 | + (cond |
| 378 | + [(custodian? obj) (loop obj)] |
| 379 | + [(thread? obj) (set! thds (cons obj thds))])) |
| 380 | + (custodian-managed-list cust system-custodian))) |
| 381 | + thds) |
389 | 382 |
|
390 | 383 | ;; FIX |
391 | 384 | ;; something needs to happen here so that the profiling gets shutdown when the repl dies. |
|
0 commit comments