1;;; pdhtml.ss 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16;;; NOTES: 17;;; - fixed bug in define-tags: moved (void) end of text ... to start 18;;; 19;;; - to change palette to use white background with colorized text: 20;;; (profile-palette 21;;; (vector-map 22;;; (lambda (p) (cons "white" (car p))) 23;;; (profile-palette))) 24 25;;; profile-dump-html suggestions from Oscar: 26;;; 27;;; We could probably build a table mapping source regions to procedure names 28;;; in enough cases to actually be useful. If so, showing procedure name instead 29;;; of line/char position would help the user get a high-level perspective on the 30;;; profile results. Right now the user has to synthesize that perspective by 31;;; remembering where each link led. 32;;; 33;;; Within the file view window, it would be nice to have a way to scan quickly 34;;; through the hot spots within that file (we have some obscenely large source 35;;; files at work). Perhaps you could reprise the profile spectrum horizontally 36;;; in a short frame at the top of the window and rig it so that dragging, scroll 37;;; wheel, or clicking on a color cycles through the regions tagged with that col> 38;;; 39;;; With a large range of profile counts to compress into a fairly small 40;;; spectrum, it might be nice if there were a way to zoom into a range by 41;;; clicking on the legend, either in the overview window or the file window. 42;;; Reallocating the color map could be confusing with multiple windows open, 43;;; but perhaps there's some javascript way to rig all the other colors to 44;;; desaturate when you zoom into a range in one window. Perhaps intensity 45;;; could be used to show the sub-ranges in varying shades of the main legend 46;;; color. 47;;; 48;;; I notice that the profile annotations on the when expressions start at the te> 49;;; expression rather than the start of the when. Yet the if expression annotati> 50;;; starts at the beginning of the if expression and extends to the closing paren. 51;;; Not sure if that made any sense, basically I'm trying to say that the "(when" 52;;; itself (and closing paren) isn't colored the same as the test part. 53;;; I don't remember exactly how we handled source annotations during wrapping and 54;;; unwrapping, but it seems offhand that it might make sense to wrap the input 55;;; source annotation around the transformer output so that the source info for t> 56;;; when expression is transferred to the generated if expression. 57 58(begin 59(let () 60 (include "types.ss") 61 (module (make-tracker tracker-profile-ct) 62 (define-record-type tracker 63 (nongenerative) 64 (fields profile-ct))) 65 (define-record-type cc 66 (nongenerative) 67 (fields (mutable cookie) (mutable total) (mutable current) (mutable preceding))) 68 (define-record-type (source-table $make-source-table $source-table?) 69 (nongenerative) 70 (sealed #t) 71 (opaque #t) 72 (fields ht) 73 (protocol 74 (lambda (new) 75 (lambda () 76 (define sfd-hash 77 (lambda (sfd)< 78 (source-file-descriptor-crc sfd))) 79 (define sfd=? 80 (lambda (sfd1 sfd2) 81 (and (fx= (source-file-descriptor-crc sfd1) (source-file-descriptor-crc sfd2)) 82 (= (source-file-descriptor-length sfd1) (source-file-descriptor-length sfd2)) 83 (equal? (source-file-descriptor-name sfd1) (source-file-descriptor-name sfd2))))) 84 (new (make-hashtable sfd-hash sfd=?)))))) 85 (define *local-profile-trackers* '()) 86 (define op+ car) 87 (define op- cdr) 88 (define count+ (constant-case ptr-bits [(32) +] [(64) fx+])) 89 (define count- (constant-case ptr-bits [(32) -] [(64) fx-])) 90 (define count< (constant-case ptr-bits [(32) <] [(64) fx<])) 91 (define get-counter-list (foreign-procedure "(cs)s_profile_counters" () ptr)) 92 (define release-counters (foreign-procedure "(cs)s_profile_release_counters" () ptr)) 93 94 (define rblock-count 95 (lambda (rblock) 96 (let sum ((op (rblock-op rblock))) 97 (if (profile-counter? op) 98 (profile-counter-count op) 99 ; using #3%fold-left in case the #2% versions are profiled 100 (#3%fold-left 101 (lambda (a op) (count- a (sum op))) 102 (#3%fold-left (lambda (a op) (count+ a (sum op))) 0 (op+ op)) 103 (op- op)))))) 104 105 (define profile-counts 106 ; like profile-dump but returns ((count . (src ...)) ...) 107 (case-lambda 108 [() (profile-counts (get-counter-list))] 109 [(counter*) 110 ; disabiling interrupts so we don't sum part of the counters for a block before 111 ; an interrupt and the remaining counters after the interrupt, which can lead 112 ; to inaccurate (and possibly negative) counts. we could disable interrupts just 113 ; around the body of rblock-count to shorten the windows during which interrupts 114 ; are disabled, but doing it here incurs less overhead 115 (with-interrupts-disabled 116 (fold-left 117 (lambda (r x) 118 (fold-left 119 (lambda (r rblock) 120 (cons (cons (rblock-count rblock) (rblock-srecs rblock)) r)) 121 r (cdr x))) 122 '() counter*))])) 123 124 (define (snapshot who uncleared-count* cleared-count*) 125 (lambda (tracker) 126 (define cookie (cons 'vanilla 'wafer)) 127 ; set current corresponding to each src to a total of its counts 128 (let ([incr-current 129 (lambda (count.src*) 130 (let ([count (car count.src*)]) 131 (for-each 132 (lambda (src) 133 (let ([a ($source-table-cell (tracker-profile-ct tracker) src #f)]) 134 (when (count< count 0) (errorf who "negative profile count ~s for ~s" count src)) 135 (let ([cc (cdr a)]) 136 (if cc 137 (if (eq? (cc-cookie cc) cookie) 138 (cc-current-set! cc (count+ (cc-current cc) count)) 139 (begin 140 (cc-cookie-set! cc cookie) 141 (cc-current-set! cc count))) 142 (set-cdr! a (make-cc cookie 0 count 0)))))) 143 (cdr count.src*))))]) 144 (for-each incr-current uncleared-count*) 145 (for-each incr-current cleared-count*)) 146 ; then increment total of each affected cc by the delta between current and preceding 147 (source-table-for-each 148 (lambda (src cc) 149 (when (eq? (cc-cookie cc) cookie) 150 (let ([current (cc-current cc)]) 151 (let ([delta (count- current (cc-preceding cc))]) 152 (unless (eqv? delta 0) 153 (when (count< delta 0) (errorf who "total profile count for ~s dropped from ~s to ~s" src (cc-preceding cc) current)) 154 (cc-total-set! cc (count+ (cc-total cc) delta)) 155 (cc-preceding-set! cc current)))))) 156 (tracker-profile-ct tracker)) 157 ; then reduce preceding by cleared counts 158 (for-each 159 (lambda (count.src*) 160 (let ([count (car count.src*)]) 161 (for-each 162 (lambda (src) 163 (let ([a ($source-table-cell (tracker-profile-ct tracker) src #f)]) 164 (let ([cc (cdr a)]) 165 (if cc 166 (cc-preceding-set! cc (count- (cc-preceding cc) count)) 167 (set-cdr! a (make-cc cookie 0 0 0)))))) 168 (cdr count.src*)))) 169 cleared-count*))) 170 171 (define adjust-trackers! 172 (lambda (who uncleared-counter* cleared-counter*) 173 (let ([local-tracker* *local-profile-trackers*]) 174 (unless (null? local-tracker*) 175 (let ([uncleared-count* (profile-counts uncleared-counter*)] 176 [cleared-count* (profile-counts cleared-counter*)]) 177 (let ([snapshot (snapshot who uncleared-count* cleared-count*)]) 178 (for-each snapshot local-tracker*))))))) 179 180 (define $source-table-contains? 181 (lambda (st src) 182 (let ([src-ht (hashtable-ref (source-table-ht st) (source-sfd src) #f)]) 183 (and src-ht (hashtable-contains? src-ht src))))) 184 185 (define $source-table-ref 186 (lambda (st src default) 187 (let ([src-ht (hashtable-ref (source-table-ht st) (source-sfd src) #f)]) 188 (if src-ht (hashtable-ref src-ht src default) default)))) 189 190 (define $source-table-cell 191 (lambda (st src default) 192 (define same-sfd-src-hash 193 (lambda (src) 194 (source-bfp src))) 195 (define same-sfd-src=? 196 (lambda (src1 src2) 197 (and (= (source-bfp src1) (source-bfp src2)) 198 (= (source-efp src1) (source-efp src2))))) 199 (let ([src-ht (let ([a (hashtable-cell (source-table-ht st) (source-sfd src) #f)]) 200 (or (cdr a) 201 (let ([src-ht (make-hashtable same-sfd-src-hash same-sfd-src=?)]) 202 (set-cdr! a src-ht) 203 src-ht)))]) 204 (hashtable-cell src-ht src default)))) 205 206 (define $source-table-delete! 207 (lambda (st src) 208 (let ([ht (source-table-ht st)] [sfd (source-sfd src)]) 209 (let ([src-ht (hashtable-ref ht sfd #f)]) 210 (when src-ht 211 (hashtable-delete! src-ht src) 212 (when (fx= (hashtable-size src-ht) 0) 213 (hashtable-delete! ht sfd))))))) 214 215 (define source-table-for-each 216 (lambda (p st) 217 (vector-for-each 218 (lambda (src-ht) 219 (let-values ([(vsrc vcount) (hashtable-entries src-ht)]) 220 (vector-for-each p vsrc vcount))) 221 (hashtable-values (source-table-ht st))))) 222 223 (set-who! profile-clear 224 (lambda () 225 (define clear-links 226 (lambda (op) 227 (if (profile-counter? op) 228 (profile-counter-count-set! op 0) 229 (begin 230 (for-each clear-links (op+ op)) 231 (for-each clear-links (op- op)))))) 232 (let ([counter* (get-counter-list)]) 233 (adjust-trackers! who '() counter*) 234 (for-each 235 (lambda (x) 236 (for-each 237 (lambda (node) (clear-links (rblock-op node))) 238 (cdr x))) 239 counter*)))) 240 241 (set-who! profile-release-counters 242 (lambda () 243 ; release-counters prunes out (and hands back) the released counters 244 (let* ([dropped-counter* (release-counters)] 245 [kept-counter* (get-counter-list)]) 246 (adjust-trackers! who kept-counter* dropped-counter*)))) 247 248 (set-who! profile-dump 249 ; like profile-counts but returns ((src . count) ...), which requires more allocation 250 ; profile-dump could use profile-counts but that would require even more allocation 251 (lambda () 252 ; could disable interrupts just around each call to rblock-count, but doing it here incurs less overhead 253 (with-interrupts-disabled 254 (fold-left 255 (lambda (r x) 256 (fold-left 257 (lambda (r rblock) 258 (let ([count (rblock-count rblock)]) 259 (fold-left 260 (lambda (r src) 261 (cons (cons src count) r)) 262 r (rblock-srecs rblock)))) 263 r (cdr x))) 264 '() (get-counter-list))))) 265 266 (set-who! make-source-table 267 (lambda () 268 ($make-source-table))) 269 270 (set-who! source-table? 271 (lambda (x) 272 ($source-table? x))) 273 274 (set-who! source-table-size 275 (lambda (st) 276 (unless ($source-table? st) ($oops who "~s is not a source table" st)) 277 (let ([vsrc-ht (hashtable-values (source-table-ht st))]) 278 (let ([n (vector-length vsrc-ht)]) 279 (do ([i 0 (fx+ i 1)] [size 0 (fx+ size (hashtable-size (vector-ref vsrc-ht i)))]) 280 ((fx= i n) size)))))) 281 282 (set-who! source-table-contains? 283 (lambda (st src) 284 (unless ($source-table? st) ($oops who "~s is not a source table" st)) 285 (unless (source? src) ($oops who "~s is not a source object" src)) 286 ($source-table-contains? st src))) 287 288 (set-who! source-table-ref 289 (lambda (st src default) 290 (unless ($source-table? st) ($oops who "~s is not a source table" st)) 291 (unless (source? src) ($oops who "~s is not a source object" src)) 292 ($source-table-ref st src default))) 293 294 (set-who! source-table-set! 295 (lambda (st src val) 296 (unless ($source-table? st) ($oops who "~s is not a source table" st)) 297 (unless (source? src) ($oops who "~s is not a source object" src)) 298 (set-cdr! ($source-table-cell st src #f) val))) 299 300 (set-who! source-table-delete! 301 (lambda (st src) 302 (unless ($source-table? st) ($oops who "~s is not a source table" st)) 303 (unless (source? src) ($oops who "~s is not a source object" src)) 304 ($source-table-delete! st src))) 305 306 (set-who! source-table-cell 307 (lambda (st src default) 308 (unless ($source-table? st) ($oops who "~s is not a source table" st)) 309 (unless (source? src) ($oops who "~s is not a source object" src)) 310 ($source-table-cell st src default))) 311 312 (set-who! source-table-dump 313 (lambda (st) 314 (unless ($source-table? st) ($oops who "~s is not a source table" st)) 315 (let* ([vsrc-ht (hashtable-values (source-table-ht st))] 316 [n (vector-length vsrc-ht)]) 317 (do ([i 0 (fx+ i 1)] 318 [dumpit* '() 319 (let-values ([(vsrc vcount) (hashtable-entries (vector-ref vsrc-ht i))]) 320 (let ([n (vector-length vsrc)]) 321 (do ([i 0 (fx+ i 1)] 322 [dumpit* dumpit* 323 (cons (cons (vector-ref vsrc i) (vector-ref vcount i)) dumpit*)]) 324 ((fx= i n) dumpit*))))]) 325 ((fx= i n) dumpit*))))) 326 327 (set-who! put-source-table 328 (lambda (op st) 329 (unless (and (output-port? op) (textual-port? op)) ($oops who "~s is not a textual output port" op)) 330 (unless ($source-table? st) ($oops who "~s is not a source table" st)) 331 (fprintf op "(source-table") 332 (let-values ([(vsfd vsrc-ht) (hashtable-entries (source-table-ht st))]) 333 (vector-for-each 334 (lambda (sfd src-ht) 335 (let-values ([(vsrc vval) (hashtable-entries src-ht)]) 336 (let ([n (vector-length vsrc)]) 337 (unless (fx= n 0) 338 (fprintf op "\n (file ~s ~s" 339 (source-file-descriptor-name sfd) 340 (source-file-descriptor-checksum sfd)) 341 (let ([v (vector-sort (lambda (x1 x2) (< (vector-ref x1 0) (vector-ref x2 0))) 342 (vector-map (lambda (src val) (vector (source-bfp src) (source-efp src) val)) vsrc vval))]) 343 (let loop ([i 0] [last-bfp 0]) 344 (unless (fx= i n) 345 (let ([x (vector-ref v i)]) 346 (let ([bfp (vector-ref x 0)] [efp (vector-ref x 1)] [val (vector-ref x 2)]) 347 (let ([offset (- bfp last-bfp)] [len (- efp bfp)]) 348 (fprintf op " (~s ~s ~s)" offset len val)) 349 (loop (fx+ i 1) bfp)))))) 350 (fprintf op ")"))))) 351 vsfd vsrc-ht)) 352 (fprintf op ")\n"))) 353 354 (set-who! get-source-table! 355 (rec get-source-table! 356 (case-lambda 357 [(ip st) (get-source-table! ip st #f)] 358 [(ip st combine) 359 (define (nnint? x) (and (integer? x) (exact? x) (nonnegative? x))) 360 (define (token-oops what bfp) 361 (if bfp 362 ($oops who "expected ~a at file position ~s of ~s" what bfp ip) 363 ($oops who "malformed source table reading from ~a" ip))) 364 (define (next-token expected-type expected-value? what) 365 (let-values ([(type val bfp efp) (read-token ip)]) 366 (unless (and (eq? type expected-type) (expected-value? val)) (token-oops what bfp)) 367 val)) 368 (unless (and (input-port? ip) (textual-port? ip)) ($oops who "~s is not a textual input port" ip)) 369 (unless ($source-table? st) ($oops who "~s is not a source table" st)) 370 (unless (or (not combine) (procedure? combine)) ($oops who "~s is not a procedure" combine)) 371 (next-token 'lparen not "open parenthesis") 372 (next-token 'atomic (lambda (x) (eq? x 'source-table)) "identifier 'source-table'") 373 (let file-loop () 374 (let-values ([(type val bfp efp) (read-token ip)]) 375 (unless (eq? type 'rparen) 376 (unless (eq? type 'lparen) (token-oops "open parenthesis" bfp)) 377 (next-token 'atomic (lambda (x) (eq? x 'file)) "identifier 'file'") 378 (let* ([path (next-token 'atomic string? "string")] 379 [checksum (next-token 'atomic nnint? "checksum")]) 380 (let ([sfd (#%source-file-descriptor path checksum)]) 381 (let entry-loop ([last-bfp 0]) 382 (let-values ([(type val bfp efp) (read-token ip)]) 383 (unless (eq? type 'rparen) 384 (unless (eq? type 'lparen) (token-oops "open parenthesis" bfp)) 385 (let* ([bfp (+ last-bfp (next-token 'atomic nnint? "file position"))] 386 [efp (+ bfp (next-token 'atomic nnint? "file position"))] 387 [val (get-datum ip)]) 388 (next-token 'rparen not "close parenthesis") 389 (let ([a ($source-table-cell st (make-source-object sfd bfp efp) #f)]) 390 (set-cdr! a 391 (if (and (cdr a) combine) 392 (combine (cdr a) val) 393 val))) 394 (entry-loop bfp))))))) 395 (file-loop))))]))) 396 397 (set-who! with-profile-tracker 398 (rec with-profile-tracker 399 (case-lambda 400 [(thunk) (with-profile-tracker #f thunk)] 401 [(include-existing-counts? thunk) 402 (define extract-covered-entries 403 (lambda (profile-ct) 404 (let ([covered-ct ($make-source-table)]) 405 (source-table-for-each 406 (lambda (src cc) 407 (let ([count (cc-total cc)]) 408 (unless (eqv? count 0) 409 ($source-table-cell covered-ct src count)))) 410 profile-ct) 411 covered-ct))) 412 (unless (procedure? thunk) ($oops who "~s is not a procedure" thunk)) 413 (let* ([profile-ct ($make-source-table)] 414 [tracker (make-tracker profile-ct)]) 415 (unless include-existing-counts? 416 ; set preceding corresponding to each src to a total of its dumpit counts 417 ; set total to zero, since we don't want to count anything from before 418 (for-each 419 (lambda (count.src*) 420 (let ([count (car count.src*)]) 421 (for-each 422 (lambda (src) 423 (let ([a ($source-table-cell profile-ct src #f)]) 424 (let ([cc (cdr a)]) 425 (if cc 426 (cc-preceding-set! cc (count+ (cc-preceding cc) count)) 427 (set-cdr! a (make-cc #f 0 0 count)))))) 428 (cdr count.src*)))) 429 (profile-counts))) 430 ; register for possible adjustment by profile-clear and profile-release-counters 431 (let-values ([v* (fluid-let ([*local-profile-trackers* (cons tracker *local-profile-trackers*)]) (thunk))]) 432 ; increment the recorded counts by the now current counts. 433 ((snapshot who (profile-counts) '()) tracker) 434 (apply values (extract-covered-entries profile-ct) v*)))])))) 435 436(let () 437 (include "types.ss") 438 439 (define check-dump 440 (lambda (who x) 441 (unless (and (list? x) 442 (andmap (lambda (x) 443 (and (pair? x) 444 (source-object? (car x)) 445 (let ([x (cdr x)]) 446 (and (integer? x) (exact? x))))) 447 x)) 448 ($oops who "invalid dump ~s" x)))) 449 450 (define-record-type filedata 451 (fields 452 (immutable sfd) 453 (immutable ip) 454 (mutable entry*) 455 ; remaining fields are ignored by profile-dump-list 456 (mutable max-count) 457 (mutable ci) 458 (mutable htmlpath) 459 (mutable htmlfn) 460 (mutable winid)) 461 (nongenerative) 462 (sealed #t) 463 (protocol 464 (lambda (new) 465 (lambda (sfd ip) 466 (new sfd ip '() #f #f #f #f #f))))) 467 468 (define-record-type entrydata 469 (fields 470 (immutable fdata) 471 (immutable bfp) 472 (immutable efp) 473 (mutable count) 474 (mutable line) 475 (mutable char) 476 ; ci is ignored by profile-dump-list 477 (mutable ci)) 478 (nongenerative) 479 (sealed #t) 480 (protocol 481 (lambda (new) 482 (lambda (fdata bfp efp count) 483 (new fdata bfp efp count #f #f #f))))) 484 485 (define (gather-filedata who warn? dumpit*) 486 ; returns list of fdata records, each holding a list of entries 487 ; the entries are sorted based on their (unique) bfps 488 (let ([fdata-ht (make-hashtable 489 (lambda (x) (source-file-descriptor-crc x)) 490 (lambda (x y) 491 ; there's no way to make this foolproof, so we identify paths with 492 ; same crc, length, and last component. this can cause problems 493 ; only if two copies of the same file are loaded and used. 494 (or (eq? x y) 495 (and (= (source-file-descriptor-crc x) 496 (source-file-descriptor-crc y)) 497 (= (source-file-descriptor-length x) 498 (source-file-descriptor-length y)) 499 (let ([maybe-path-last (lambda (p) 500 (if (string? p) (path-last p) p))]) 501 (equal? 502 (maybe-path-last (source-file-descriptor-name x)) 503 (maybe-path-last (source-file-descriptor-name y))))))))]) 504 (define (open-source sfd) 505 (cond 506 [(hashtable-ref fdata-ht sfd #f)] 507 [($open-source-file sfd) => 508 (lambda (ip) 509 (let ([fdata (make-filedata sfd ip)]) 510 (hashtable-set! fdata-ht sfd fdata) 511 fdata))] 512 [else 513 (when warn? 514 (warningf who 515 "unmodified source file ~s not found in source directories" 516 (source-file-descriptor-name sfd))) 517 (let ([fdata (make-filedata sfd #f)]) 518 (hashtable-set! fdata-ht sfd fdata) 519 fdata)])) 520 (for-each 521 (lambda (dumpit) 522 (let ([source (car dumpit)]) 523 (assert (source? source)) 524 (let ([bfp (source-bfp source)]) 525 (when (>= bfp 0) ; weed out block-profiling entries, whose bfps are negative 526 (let ([fdata (open-source (source-sfd source))]) 527 (filedata-entry*-set! fdata 528 (cons (make-entrydata fdata bfp (source-efp source) (cdr dumpit)) 529 (filedata-entry* fdata)))))))) 530 dumpit*) 531 (let ([fdatav (hashtable-values fdata-ht)]) 532 (vector-for-each 533 (lambda (fdata) 534 (let ([entry* (sort (lambda (x y) 535 (or (> (entrydata-bfp x) (entrydata-bfp y)) 536 (and (= (entrydata-bfp x) (entrydata-bfp y)) 537 (< (entrydata-efp x) (entrydata-efp y))))) 538 (filedata-entry* fdata))]) 539 #;(assert (not (null? entry*))) 540 (let loop ([entry (car entry*)] [entry* (cdr entry*)] [new-entry* '()]) 541 (if (null? entry*) 542 (filedata-entry*-set! fdata (cons entry new-entry*)) 543 (if (and (= (entrydata-bfp (car entry*)) (entrydata-bfp entry)) 544 (= (entrydata-efp (car entry*)) (entrydata-efp entry))) 545 (begin 546 (entrydata-count-set! entry 547 (+ (entrydata-count entry) 548 (entrydata-count (car entry*)))) 549 (loop entry (cdr entry*) new-entry*)) 550 (loop (car entry*) (cdr entry*) (cons entry new-entry*))))))) 551 fdatav) 552 (vector->list fdatav)))) 553 554 (let () 555 (define (scan-file fdata) 556 (let ([ip (filedata-ip fdata)] [line 1] [char 1]) 557 (define (read-until bfp next) 558 (let loop ([bfp bfp]) 559 (unless (= bfp next) 560 (cond 561 [(eqv? (read-char ip) #\newline) 562 (set! line (+ line 1)) 563 (set! char 1)] 564 [else (set! char (+ char 1))]) 565 (loop (+ bfp 1))))) 566 (let ([entry* (filedata-entry* fdata)]) ; already sorted by gather-filedata 567 (let f ([bfp 0] [entry* entry*]) 568 (unless (null? entry*) 569 (let ([entry (car entry*)] [entry* (cdr entry*)]) 570 (let ([next (entrydata-bfp entry)]) 571 (read-until bfp next) 572 (entrydata-line-set! entry line) 573 (entrydata-char-set! entry char) 574 (f next entry*)))))))) 575 576 (set-who! profile-dump-list 577 ; return list of lists of: 578 ; - count 579 ; - path ; current if line and char are not #f 580 ; - bfp 581 ; - efp 582 ; - line ; may be #f 583 ; - char ; may be #f 584 (rec profile-dump-list 585 (case-lambda 586 [() (profile-dump-list #t)] 587 [(warn?) (profile-dump-list warn? (profile-dump))] 588 [(warn? dumpit*) 589 (check-dump who dumpit*) 590 (let ([fdata* (gather-filedata who warn? dumpit*)]) 591 (for-each scan-file (remp (lambda (x) (not (filedata-ip x))) fdata*)) 592 (let ([ls (map (lambda (entry) 593 (let ([fdata (entrydata-fdata entry)]) 594 (list 595 (entrydata-count entry) 596 (cond 597 [(filedata-ip fdata) => port-name] 598 [else (source-file-descriptor-name 599 (filedata-sfd fdata))]) 600 (entrydata-bfp entry) 601 (entrydata-efp entry) 602 (entrydata-line entry) 603 (entrydata-char entry)))) 604 (sort 605 (lambda (x y) (> (entrydata-count x) (entrydata-count y))) 606 (apply append (map filedata-entry* fdata*))))]) 607 (for-each 608 (lambda (fdata) (cond [(filedata-ip fdata) => close-input-port])) 609 fdata*) 610 ls))])))) 611 612 (let () 613 (define-record-type profilit 614 (nongenerative #{profilit iw9f7z5ovg4jjetsvw5m0-2}) 615 (sealed #t) 616 (fields sfd bfp efp weight)) 617 (define make-profile-database 618 (lambda () 619 (make-hashtable 620 source-file-descriptor-crc 621 (lambda (x y) 622 (or (eq? x y) 623 (and (= (source-file-descriptor-crc x) 624 (source-file-descriptor-crc y)) 625 (= (source-file-descriptor-length x) 626 (source-file-descriptor-length y)) 627 (let ([maybe-path-last (lambda (p) 628 (if (string? p) (path-last p) p))]) 629 (string=? 630 (maybe-path-last (source-file-descriptor-name x)) 631 (maybe-path-last (source-file-descriptor-name y)))))))))) 632 633 (define profile-database #f) 634 (define profile-source-data? #f) 635 (define profile-block-data? #f) 636 (define update-sfd! 637 (lambda (cell sfd) 638 ; if the recorded sfd is the same but not eq, it's likely from an earlier session. 639 ; overwrite so remaining hashtable equality-procedure checks are more likely to 640 ; succeed at the eq? check 641 (unless (eq? (car cell) sfd) 642 (set-car! cell sfd)))) 643 (set-who! profile-clear-database 644 (lambda () 645 (set! profile-database #f))) 646 (set-who! profile-dump-data 647 (rec profile-dump-data 648 (case-lambda 649 [(ofn) (profile-dump-data ofn (profile-dump))] 650 [(ofn dumpit*) 651 (check-dump who dumpit*) 652 (let ([op ($open-file-output-port who ofn (file-options replace))]) 653 (on-reset (delete-file ofn #f) 654 (on-reset (close-port op) 655 (let* ([dump dumpit*] [max-count (inexact (fold-left max 1 (map cdr dump)))]) 656 (for-each 657 (lambda (dumpit) 658 (let ([source (car dumpit)] [count (cdr dumpit)]) 659 (fasl-write 660 (make-profilit (source-sfd source) (source-bfp source) (source-efp source) 661 ; compute weight as % of max count 662 (fl/ (inexact count) max-count)) 663 op))) 664 dump))) 665 (close-port op)))]))) 666 (set! $profile-source-data? (lambda () profile-source-data?)) 667 (set! $profile-block-data? (lambda () profile-block-data?)) 668 (set-who! profile-load-data 669 (lambda ifn* 670 (define populate! 671 (lambda (x) 672 (unless (profilit? x) ($oops who "invalid profile data element ~s" x)) 673 (unless profile-database (set! profile-database (make-profile-database))) 674 (let ([ht (let* ([sfd (profilit-sfd x)] 675 [cell (hashtable-cell profile-database sfd #f)]) 676 (update-sfd! cell sfd) 677 (or (cdr cell) 678 (let ([ht (make-hashtable values =)]) 679 (set-cdr! cell ht) 680 ht)))]) 681 ; each ht entry is an alist mapping efp -> (weight . n) where n is 682 ; the number of contributing entries so far for this sfd, bfp, and efp. 683 ; n is used to compute the average weight of the contributing entries. 684 (let ([bfp.alist (hashtable-cell ht (profilit-bfp x) '())]) 685 (cond 686 [(assv (profilit-efp x) (cdr bfp.alist)) => 687 (lambda (a) 688 (let ([weight.n (cdr a)]) 689 (let ([weight (car weight.n)] [n (cdr weight.n)]) 690 (let ([new-n (fl+ n 1.0)]) 691 (set-car! weight.n (fl/ (fl+ (* weight n) (profilit-weight x)) new-n)) 692 (set-cdr! weight.n new-n)))))] 693 [else (set-cdr! bfp.alist (cons (cons* (profilit-efp x) (profilit-weight x) 1.0) (cdr bfp.alist)))]))) 694 (if (fxnegative? (profilit-bfp x)) 695 (set! profile-block-data? #t) 696 (set! profile-source-data? #t)))) 697 (define (load-file ifn) 698 (let ([ip ($open-file-input-port who ifn)]) 699 (on-reset (close-port ip) 700 (let f () 701 (let ([x (fasl-read ip)]) 702 (unless (eof-object? x) 703 (with-tc-mutex (populate! x)) 704 (f))))) 705 (close-port ip))) 706 (for-each 707 (lambda (ifn) 708 (unless (string? ifn) ($oops who "~s is not a string" ifn))) 709 ifn*) 710 (for-each load-file ifn*))) 711 (set! $profile-show-database 712 (lambda () 713 (when profile-database 714 (let-values ([(sfd* ht*) (hashtable-entries profile-database)]) 715 (vector-for-each 716 (lambda (sfd ht) 717 (printf "~a:\n" (source-file-descriptor-name sfd)) 718 (let-values ([(bfp* alist*) (hashtable-entries ht)]) 719 (vector-for-each 720 (lambda (bfp alist) 721 (for-each 722 (lambda (a) (printf " ~s, ~s: ~s\n" bfp (car a) (cadr a))) 723 alist)) 724 bfp* alist*))) 725 sfd* ht*))))) 726 (set! profile-query-weight 727 (lambda (x) 728 (define src->weight 729 (lambda (src) 730 (cond 731 [(and profile-database 732 (let* ([sfd (source-object-sfd src)] 733 [ht (hashtable-ref profile-database sfd #f)]) 734 (and ht 735 (begin 736 ; could do just one lookup if we had a nondestructive variant of 737 ; hashtable-cell to call above 738 (update-sfd! (hashtable-cell profile-database sfd #f) sfd) 739 ht)))) => 740 (lambda (ht) 741 (let ([alist (hashtable-ref ht (source-object-bfp src) '())]) 742 (cond 743 [(assv (source-object-efp src) alist) => cadr] 744 [(and (fxnegative? (source-object-bfp src)) (not (null? alist))) 745 ($oops #f "block-profiling info is out-of-date for ~s" 746 (source-file-descriptor-name (source-object-sfd src)))] 747 ; no info for given bfp, efp...assume dead code and return 0 748 [else 0.0])))] 749 ; no info for given sfd...assume not profiled and return #f 750 [else #f]))) 751 (if (source? x) 752 (src->weight x) 753 (let ([x (syntax->annotation x)]) 754 (if (annotation? x) 755 (src->weight (annotation-source x)) 756 #f)))))) 757 758 (let () 759 ;;; The following copyright notice goes with the %html module. 760 761 ;;; Copyright (c) 2005 R. Kent Dybvig 762 763 ;;; Permission is hereby granted, free of charge, to any person obtaining a 764 ;;; copy of this software and associated documentation files (the "Software"), 765 ;;; to deal in the Software without restriction, including without limitation 766 ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 767 ;;; and/or sell copies of the Software, and to permit persons to whom the 768 ;;; Software is furnished to do so, subject to the following conditions: 769 770 ;;; The above copyright notice and this permission notice shall be included in 771 ;;; all copies or substantial portions of the Software. 772 773 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 774 ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 775 ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 776 ;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 777 ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 778 ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 779 ;;; DEALINGS IN THE SOFTWARE. 780 781 (module %html ((<html> <*> attribute $tag) 782 (<head> <*> attribute $tag) 783 (<body> <*> attribute $tag) 784 (<script> <*> attribute $tag) 785 (<style> <*> attribute $tag) 786 (<title> <*> attribute $tag) 787 (<base> <*> attribute $tag) 788 (<link> <*> attribute $tag) 789 (<meta> <*> attribute $tag) 790 (<address> <*> attribute $tag) 791 (<blockquote> <*> attribute $tag) 792 (<del> <*> attribute $tag) 793 (<div> <*> attribute $tag) 794 (<h1> <*> attribute $tag) 795 (<h2> <*> attribute $tag) 796 (<h3> <*> attribute $tag) 797 (<h4> <*> attribute $tag) 798 (<h5> <*> attribute $tag) 799 (<h6> <*> attribute $tag) 800 (<ins> <*> attribute $tag) 801 (<noscript> <*> attribute $tag) 802 (<p> <*> attribute $tag) 803 (<pre> <*> attribute $tag) 804 (<hr> <*> attribute $tag) 805 (<dd> <*> attribute $tag) 806 (<dl> <*> attribute $tag) 807 (<dt> <*> attribute $tag) 808 (<li> <*> attribute $tag) 809 (<ol> <*> attribute $tag) 810 (<ul> <*> attribute $tag) 811 (<table> <*> attribute $tag) 812 (<caption> <*> attribute $tag) 813 (<colgroup> <*> attribute $tag) 814 (<thead> <*> attribute $tag) 815 (<tfoot> <*> attribute $tag) 816 (<tbody> <*> attribute $tag) 817 (<tr> <*> attribute $tag) 818 (<td> <*> attribute $tag) 819 (<th> <*> attribute $tag) 820 (<col> <*> attribute $tag) 821 (<form> <*> attribute $tag) 822 (<button> <*> attribute $tag) 823 (<fieldset> <*> attribute $tag) 824 (<legend> <*> attribute $tag) 825 (<label> <*> attribute $tag) 826 (<select> <*> attribute $tag) 827 (<optgroup> <*> attribute $tag) 828 (<option> <*> attribute $tag) 829 (<textarea> <*> attribute $tag) 830 (<input> <*> attribute $tag) 831 (<a> <*> attribute $tag) 832 (<bdo> <*> attribute $tag) 833 (<map> <*> attribute $tag) 834 (<object> <*> attribute $tag) 835 (<q> <*> attribute $tag) 836 (<span> <*> attribute $tag) 837 (<sub> <*> attribute $tag) 838 (<sup> <*> attribute $tag) 839 (<br> <*> attribute $tag) 840 (<img> <*> attribute $tag) 841 (<area> <*> attribute $tag) 842 (<param> <*> attribute $tag) 843 (<abbr> <*> attribute $tag) 844 (<acronym> <*> attribute $tag) 845 (<cite> <*> attribute $tag) 846 (<code> <*> attribute $tag) 847 (<dfn> <*> attribute $tag) 848 (<em> <*> attribute $tag) 849 (<kbd> <*> attribute $tag) 850 (<samp> <*> attribute $tag) 851 (<strong> <*> attribute $tag) 852 (<var> <*> attribute $tag) 853 (<b> <*> attribute $tag) 854 (<big> <*> attribute $tag) 855 (<i> <*> attribute $tag) 856 (<small> <*> attribute $tag) 857 (<tt> <*> attribute $tag) 858 <doctype> 859 html-text nbsp encode-url-parameter flush-html-output) 860 (define $tag 861 (lambda (tag attributes text end-tag) 862 (define (simple-value? s) 863 (define (simple-char? c) 864 (or (char<=? #\0 c #\9) 865 (char<=? #\a c #\z) 866 (char<=? #\A c #\Z) 867 (char=? c #\-) 868 (char=? c #\.))) 869 (let ([n (string-length s)]) 870 (and (fx> n 0) 871 (let f ([i (fx- n 1)]) 872 (and (simple-char? (string-ref s i)) 873 (or (fx= i 0) (f (fx- i 1)))))))) 874 (printf "<~a" tag) 875 (for-each 876 (lambda (a) 877 (if (pair? a) 878 (let ([value (let ([s (cdr a)]) 879 (if (string? s) 880 s 881 (format "~a" (cdr a))))]) 882 (if (simple-value? value) 883 (printf " ~a=~a" (car a) value) 884 (let ([n (string-length value)]) 885 (printf " ~a=\"" (car a)) 886 (do ([i 0 (fx+ i 1)]) 887 ((fx= i n) (write-char #\")) 888 (display 889 (let ([c (string-ref value i)]) 890 (if (char=? c #\") 891 """ 892 (html-text-char c)))))))) 893 (printf " ~a" a))) 894 attributes) 895 (printf ">") 896 (cond 897 [end-tag (let-values ([v* (text)]) 898 (printf "</~a>" tag) 899 (apply values v*))] 900 [else (text)]))) 901 (meta define <*> 902 (lambda (id) 903 (datum->syntax-object id 904 (string->symbol 905 (string-append "<" (symbol->string (syntax-object->datum id)) ">"))))) 906 (meta define (attribute x) 907 (syntax-case x () 908 [(a v) (identifier? #'a) #'(cons 'a v)] 909 [a (identifier? #'a) #''a] 910 [else (syntax-error x "improper attribute")])) 911 (define-syntax define-tags 912 (lambda (x) 913 (syntax-case x () 914 [(_ tag ...) 915 (with-syntax ([(<tag> ...) (map <*> (syntax->list #'(tag ...)))]) 916 #'(begin 917 (define-syntax <tag> 918 (lambda (x) 919 (syntax-case x () 920 [(_ (attr (... ...)) text (... ...)) 921 (with-syntax ([(attr (... ...)) 922 (map attribute 923 (syntax->list #'(attr (... ...))))]) 924 #'($tag 'tag (list attr (... ...)) 925 (lambda () (void) text (... ...)) #t))]))) 926 ...))]))) 927 (define-syntax define-endless-tags 928 (lambda (x) 929 (syntax-case x () 930 [(_ tag ...) 931 (with-syntax ([(<tag> ...) (map <*> (syntax->list #'(tag ...)))]) 932 #'(begin 933 (define-syntax <tag> 934 (lambda (x) 935 (syntax-case x () 936 [(_) #'($tag 'tag '() (lambda () "") #f)] 937 [(_ (attr (... ...))) 938 (with-syntax ([(attr (... ...)) 939 (map attribute 940 (syntax->list #'(attr (... ...))))]) 941 #'($tag 'tag (list attr (... ...)) 942 (lambda () "") #f))]))) 943 ...))]))) 944 945 ; top-level 946 (define-tags html head body) 947 948 ; head 949 (define-tags script style title) ; script also special inline 950 (define-endless-tags base link meta) 951 952 ; block-level generic 953 ; del and ins are also phrase 954 (define-tags address blockquote del div h1 h2 h3 h4 h5 h6 ins noscript p pre) 955 (define-endless-tags hr) 956 957 ; lists 958 (define-tags dd dl dt li ol ul) 959 960 ; tables 961 (define-tags table caption colgroup thead tfoot tbody tr td th) 962 (define-endless-tags col) 963 964 ; forms 965 (define-tags form button fieldset legend label select optgroup option textarea) 966 (define-endless-tags input) 967 968 ; special inline 969 (define-tags a bdo map object q span sub sup) 970 (define-endless-tags br img area param) 971 972 ; phrase 973 (define-tags abbr acronym cite code dfn em kbd samp strong var) 974 975 ; font-style 976 (define-tags b big i small tt) 977 978 ; pseudo tags 979 (define (<doctype>) 980 (printf "<!DOCTYPE html>\n")) 981 982 ;;; other helpers 983 (define (html-text-char c) 984 (case c 985 [(#\<) "<"] 986 [(#\>) ">"] 987 [(#\&) "&"] 988 [(#\return) ""] 989 [else c])) 990 991 (define (html-text fmt . args) 992 (let ([s (apply format fmt args)]) 993 (let ([n (string-length s)]) 994 (do ([i 0 (fx+ i 1)]) 995 ((fx= i n)) 996 (display (html-text-char (string-ref s i))))))) 997 998 (define (nbsp) (display-string " ")) 999 1000 (define encode-url-parameter 1001 (let () 1002 (define get-encoding 1003 (let ([encoding (make-vector 256)]) 1004 (do ([i 0 (fx+ i 1)]) 1005 ((fx= i 256)) 1006 (let ([c (integer->char i)]) 1007 (cond 1008 [(or (char<=? #\a c #\z) 1009 (char<=? #\A c #\Z) 1010 (char<=? #\0 c #\9) 1011 (memv c '(#\$ #\- #\_ #\. #\+ #\! #\* #\' #\( #\) #\,))) 1012 (vector-set! encoding i c)] 1013 [(char=? c #\space) (vector-set! encoding i #\+)] 1014 [else (vector-set! encoding i (format "%~(~2,'0x~)" i))]))) 1015 (lambda (c) 1016 (let ([n (char->integer c)]) 1017 (if (fx< n 256) 1018 (vector-ref encoding c) 1019 ($oops 'encode-url-parameter "cannot encode non-latin-1 character ~s" c)))))) 1020 (lambda (s) 1021 (define (string-insert! s1 i1 s2 n2) 1022 (do ([i2 0 (fx+ i2 1)] [i1 i1 (fx+ i1 1)]) 1023 ((fx= i2 n2)) 1024 (string-set! s1 i1 (string-ref s2 i2)))) 1025 (let ([n (string-length s)]) 1026 (let f ([i 0] [j 0]) 1027 (if (fx= i n) 1028 (make-string j) 1029 (let ([x (get-encoding (string-ref s i))]) 1030 (if (char? x) 1031 (let ([s (f (fx+ i 1) (fx+ j 1))]) 1032 (string-set! s j x) 1033 s) 1034 (let ([xn (string-length x)]) 1035 (let ([s (f (fx+ i 1) (fx+ j xn))]) 1036 (string-insert! s j x xn) 1037 s)))))))))) 1038 1039 (define (flush-html-output) (flush-output-port)) 1040 ) 1041 (import %html) 1042 1043 (define (assign-colors ncolors fdata*) 1044 ; assign highest color to entries whose counts are within X% of maximum 1045 ; count, where X = 100/ncolors, then recur without assigned color or 1046 ; entries to which it is assigned 1047 ; NB: color 0 is for unprofiled code, and color 1 is for unexecuted code 1048 (let loop ([entry* (sort (lambda (x y) 1049 (> (entrydata-count x) (entrydata-count y))) 1050 (apply append (map filedata-entry* fdata*)))] 1051 [ci (- ncolors 1)]) 1052 (unless (null? entry*) 1053 (let ([limit (if (= ci 1) 1054 -1 1055 (let ([max-count (entrydata-count (car entry*))]) 1056 (truncate (* max-count (- 1 (/ 1 (- ci 1)))))))]) 1057 (let loop2 ([entry* entry*]) 1058 (unless (null? entry*) 1059 (let ([entry (car entry*)]) 1060 (if (<= (entrydata-count entry) limit) 1061 (loop entry* (- ci 1)) 1062 (let ([fdata (entrydata-fdata entry)]) 1063 (unless (filedata-ci fdata) 1064 (filedata-ci-set! fdata ci)) 1065 (entrydata-ci-set! entry ci) 1066 (loop2 (cdr entry*))))))))))) 1067 1068 (define-syntax with-html-file 1069 (syntax-rules () 1070 [(_ who palette ?path title body1 body2 ...) 1071 (let ([path ?path]) 1072 (let ([op ($open-file-output-port who path 1073 (file-options replace) 1074 (buffer-mode block) 1075 (current-transcoder))]) 1076 (on-reset (delete-file path #f) 1077 (on-reset (close-port op) 1078 (parameterize ([current-output-port op]) 1079 (<doctype>) 1080 (<html> () 1081 (newline) 1082 (<head> () 1083 (newline) 1084 (<meta> ([http-equiv "Content-Type"] 1085 [content "text/html;charset=utf-8"])) 1086 (newline) 1087 (<title> () (html-text "~a" title)) 1088 (newline) 1089 (display-style-with-palette palette) 1090 (newline)) 1091 (newline) 1092 (let () body1 body2 ...) 1093 (newline)))) 1094 (close-port op))))])) 1095 1096 (define (display-file who palette fdata) 1097 (let ([ip (filedata-ip fdata)] [line 1] [char 1]) 1098 (define (copy-all) 1099 (html-text "~a" 1100 (with-output-to-string 1101 (rec f 1102 (lambda () 1103 (let ([c (read-char ip)]) 1104 (unless (eof-object? c) 1105 (write-char c) 1106 (f)))))))) 1107 (define (read-space imax) 1108 (with-output-to-string 1109 (lambda () 1110 (let f ([imax imax]) 1111 (unless (= imax 0) 1112 (let ([c (peek-char ip)]) 1113 (when (memv c '(#\space #\tab)) 1114 (read-char ip) 1115 (set! char (+ char 1)) 1116 (write-char c) 1117 (f (- imax 1))))))))) 1118 (define (read-to-eol imax) 1119 (with-output-to-string 1120 (lambda () 1121 (let f ([imax imax]) 1122 (unless (= imax 0) 1123 (let ([c (peek-char ip)]) 1124 (unless (or (eof-object? c) (char=? c #\newline)) 1125 (read-char ip) 1126 (set! char (+ char 1)) 1127 (write-char c) 1128 (f (- imax 1))))))))) 1129 (define (copy-until bfp next ci title) 1130 (let loop ([bfp bfp]) 1131 (unless (= bfp next) 1132 (let ([s (read-to-eol (- next bfp))]) 1133 (let ([n (string-length s)]) 1134 (when (> n 0) 1135 (if ci 1136 (<span> ([class (color-class ci)] [title title]) 1137 (html-text "~a" s)) 1138 (html-text "~a" s))) 1139 (let ([bfp (+ bfp n)]) 1140 (unless (= bfp next) 1141 ; next character must be newline, if not eof 1142 (when (eof-object? (read-char ip)) 1143 ($oops who 1144 "unexpected end-of-file on ~s" 1145 ip)) 1146 (let ([bfp (+ bfp 1)]) 1147 (newline) 1148 (set! line (+ line 1)) 1149 (set! char 1) 1150 (let ([s (read-space (- next bfp))]) 1151 (let ([n (string-length s)]) 1152 (when (> n 0) (display s)) 1153 (loop (+ bfp n)))))))))))) 1154 (define-syntax with-line-numbers 1155 (syntax-rules () 1156 [(_ e1 e2 ...) 1157 (let ([th (lambda () e1 e2 ...)]) 1158 (cond 1159 [(profile-line-number-color) => 1160 (lambda (color) 1161 (define line-count 1162 (let loop ([n 0] [bol? #t]) 1163 (let ([c (read-char ip)]) 1164 (if (eof-object? c) 1165 (begin (set-port-position! ip 0) n) 1166 (loop (if bol? (+ n 1) n) (char=? c #\newline)))))) 1167 (<table> () 1168 (<tr> () 1169 (<td> ([style (format "color: ~a; font-weight: bold; padding-right: 1rem; text-align: right" color)]) 1170 (<pre> () 1171 (unless (fx= line-count 0) 1172 (newline) 1173 (let loop ([i 1]) 1174 (<span> ([id (format "line~d" i)]) (html-text "~s\n" i)) 1175 (unless (fx= i line-count) (loop (fx+ i 1))))))) 1176 (<td> () (th)))))] 1177 [else (th)]))])) 1178 (with-html-file who palette (filedata-htmlpath fdata) (port-name ip) 1179 (<body> ([class (color-class 0)]) 1180 (newline) 1181 (<h1> ([style "margin-bottom: 1rem"]) 1182 (html-text "~a" (port-name ip)) (<span> ([style "opacity: 0.5"]) (html-text " on ~a" (date-and-time)))) 1183 (newline) 1184 (with-line-numbers 1185 (<pre> () 1186 (newline) 1187 (let ([entry* (filedata-entry* fdata)]) ; already sorted by gather-filedata 1188 (let f ([bfp 0] [entry* entry*] [efp #f] [ci #f] [title ""]) 1189 (cond 1190 [(and (null? entry*) (not efp)) (copy-all)] 1191 [(and (not (null? entry*)) 1192 (or (not efp) (< (entrydata-bfp (car entry*)) efp))) 1193 (let ([entry (car entry*)] [entry* (cdr entry*)]) 1194 (let ([next (entrydata-bfp entry)]) 1195 (copy-until bfp next ci title) 1196 (entrydata-line-set! entry line) 1197 (entrydata-char-set! entry char) 1198 (let-values ([(bfp entry*) 1199 (f next entry* 1200 (entrydata-efp entry) 1201 (entrydata-ci entry) 1202 (format "line ~d char ~d count ~:d" line char (entrydata-count entry)))]) 1203 (f bfp entry* efp ci title))))] 1204 [else 1205 (copy-until bfp efp ci title) 1206 (values efp entry*)]))))) 1207 (newline))))) 1208 1209 (define color-class 1210 (lambda (ci) 1211 (format "pc~s" ci))) 1212 1213 (define (display-style-with-palette palette) 1214 (<style> ([type "text/css"]) 1215 (newline) 1216 1217 ;; CSS Reset Styling 1218 1219 ;; See https://perishablepress.com/a-killer-collection-of-global-css-reset-styles/ for an overview 1220 ;; of CSS resets. 1221 ;; 1222 ;; See http://code.stephenmorley.org/html-and-css/fixing-browsers-broken-monospace-font-handling/ 1223 ;; for an explanation of "font-family: monospace, monospace;" and the following "font-size: 1rem;". 1224 ;; 1225 (printf "* {") 1226 (printf " border: 0;") 1227 (printf " margin: 0;") 1228 (printf " outline: 0;") 1229 (printf " padding: 0;") 1230 (printf " vertical-align: baseline;") 1231 (printf " }\n") 1232 (printf "code, kbd, pre, samp {") 1233 (printf " font-family: monospace, monospace;") 1234 (printf " font-size: 1rem;") 1235 (printf " }\n") 1236 (printf "html {") 1237 (printf " -moz-osx-font-smoothing: grayscale;") 1238 (printf " -webkit-font-smoothing: antialiased;") 1239 (printf " }\n") 1240 (printf "table {") 1241 (printf " border-collapse: collapse;") 1242 (printf " border-spacing: 0;") 1243 (printf " }\n") 1244 1245 ;; CSS Base Styling 1246 1247 (printf "body {") 1248 (printf " padding: 1rem;") 1249 (printf " }\n") 1250 (printf "h1, h2, h3, h4 {") 1251 (printf " line-height: 1.25;") 1252 (printf " margin-bottom: 0.5rem;") 1253 (printf " }\n") 1254 (printf "h1 {") 1255 (printf " font-size: 1.296rem;") 1256 (printf " }\n") 1257 (printf "h2 {") 1258 (printf " font-size: 1.215rem;") 1259 (printf " }\n") 1260 (printf "h3 {") 1261 (printf " font-size: 1.138rem;") 1262 (printf " }\n") 1263 (printf "h4 {") 1264 (printf " font-size: 1.067rem;") 1265 (printf " }\n") 1266 (printf "html {") 1267 (printf " font-family: monospace, monospace;") 1268 (printf " font-size: 1rem;") 1269 (printf " }\n") 1270 (printf "p {") 1271 (printf " margin-bottom: 1.25rem;") 1272 (printf " }\n") 1273 1274 ;; CSS Profile Styling 1275 1276 (do ([ci 0 (fx+ ci 1)]) 1277 ((fx= ci (vector-length palette))) 1278 (let ([color (vector-ref palette ci)]) 1279 (printf ".~a { background-color: ~a; color: ~a; white-space: nowrap; }\n" 1280 (color-class ci) (car color) (cdr color)))))) 1281 1282 (define (safe-prefix name name*) 1283 (define (prefix? prefix str) 1284 (let ([n (string-length prefix)]) 1285 (and (fx<= n (string-length str)) 1286 (string=? prefix (substring str 0 n))))) 1287 (define (digit+? s i n) 1288 (and (fx< i n) 1289 (let ([n (fx- n 1)]) 1290 (let loop ([i i]) 1291 (and (char-numeric? (string-ref s i)) 1292 (or (fx= i n) (loop (fx+ i 1)))))))) 1293 (define (okay? prefix) 1294 (let loop ([name* name*]) 1295 (or (null? name*) 1296 (let ([next-name (car name*)]) 1297 (or (not (prefix? name next-name)) 1298 (and (or (not (prefix? prefix next-name)) 1299 (not (digit+? next-name 1300 (string-length prefix) 1301 (string-length next-name)))) 1302 (loop (cdr name*)))))))) 1303 (let try ([prefix name]) 1304 (let ([prefix (format "~a-" prefix)]) 1305 (if (okay? prefix) 1306 prefix 1307 (try prefix))))) 1308 1309 (define (readable-number n) 1310 (cond 1311 [(>= n 1000000000) (format "~~~sB" (quotient n 1000000000))] 1312 [(>= n 1000000) (format "~~~sM" (quotient n 1000000))] 1313 [(>= n 1000) (format "~~~sK" (quotient n 1000))] 1314 [else (format "~a" n)])) 1315 1316 (set-who! profile-dump-html 1317 (rec profile-dump-html 1318 (case-lambda 1319 [() (profile-dump-html "")] 1320 [(path-prefix) (profile-dump-html path-prefix (profile-dump))] 1321 [(path-prefix dumpit*) 1322 (unless (string? path-prefix) 1323 ($oops who "~s is not a string" path-prefix)) 1324 (check-dump who dumpit*) 1325 (let ([palette (profile-palette)]) 1326 (let ([fdata* (gather-filedata who #f dumpit*)]) 1327 (when (null? fdata*) 1328 ($oops who "no profiled code found")) 1329 (for-each 1330 (lambda (fdata) 1331 (filedata-max-count-set! fdata 1332 (apply max 1333 (map entrydata-count 1334 (filedata-entry* fdata))))) 1335 fdata*) 1336 ; assign unique html pathnames to fdatas with ips 1337 (let ([fdata* 1338 (sort 1339 (lambda (x y) 1340 (let ([xpath (path-last (port-name (filedata-ip x)))] 1341 [ypath (path-last (port-name (filedata-ip y)))]) 1342 (or (string<? xpath ypath) 1343 (and (string=? xpath ypath) 1344 (< (source-file-descriptor-crc (filedata-sfd x)) 1345 (source-file-descriptor-crc (filedata-sfd x))))))) 1346 (remp (lambda (x) (not (filedata-ip x))) fdata*))]) 1347 (for-each 1348 (lambda (fdata i htmlpath) 1349 (filedata-htmlpath-set! fdata htmlpath) 1350 (filedata-htmlfn-set! fdata (path-last htmlpath)) 1351 (filedata-winid-set! fdata (format "win~s" i))) 1352 fdata* 1353 (enumerate fdata*) 1354 (let f ([name* (map (lambda (fdata) 1355 (path-last (port-name (filedata-ip fdata)))) 1356 fdata*)] 1357 [last-name #f]) 1358 (if (null? name*) 1359 '() 1360 (let ([name (car name*)]) 1361 (if (equal? name last-name) 1362 (let ([prefix (safe-prefix name name*)]) 1363 (let g ([name* (cdr name*)] [i 0]) 1364 (cons (format "~a~a~s.html" path-prefix prefix i) 1365 (if (and (not (null? name*)) 1366 (string=? (car name*) name)) 1367 (g (cdr name*) (+ i 1)) 1368 (f name* name))))) 1369 (cons (format "~a~a.html" path-prefix name) 1370 (f (cdr name*) name)))))))) 1371 (assign-colors (vector-length palette) fdata*) 1372 (with-html-file who palette (format "~aprofile.html" path-prefix) "Profile Output" 1373 (<body> ([class (color-class 0)]) 1374 (newline) 1375 (<h1> ([style "margin-bottom: 1rem"]) 1376 (html-text "Profile Output") (<span> ([style "opacity: 0.5"]) (html-text " on ~a" (date-and-time)))) 1377 (newline) 1378 (<table> () 1379 (<tr> () 1380 (newline) 1381 (<td> ([style "vertical-align: top"]) 1382 (<h2> ([style "margin-bottom: 0.25rem"]) 1383 (html-text "Legend")) 1384 (newline) 1385 (<table> ([style "margin-bottom: 1rem"]) 1386 (newline) 1387 (let* ([n (vector-length palette)] [v (make-vector n #f)]) 1388 (for-each 1389 (lambda (fdata) 1390 (for-each 1391 (lambda (entry) 1392 (let ([ci (entrydata-ci entry)] 1393 [count (entrydata-count entry)]) 1394 (vector-set! v ci 1395 (let ([p (vector-ref v ci)]) 1396 (if p 1397 (cons (min (car p) count) 1398 (max (cdr p) count)) 1399 (cons count count)))))) 1400 (filedata-entry* fdata))) 1401 fdata*) 1402 (do ([ci (- n 1) (- ci 1)]) 1403 ((= ci 0)) 1404 (let ([p (vector-ref v ci)]) 1405 (when p 1406 (<tr> () 1407 (<td> ([class (color-class ci)] 1408 [style "padding: 0.5rem"]) 1409 (let ([smin (readable-number (car p))] 1410 [smax (readable-number (cdr p))]) 1411 (if (string=? smin smax) 1412 (html-text "executed ~a time~p" 1413 smin (car p)) 1414 (html-text "executed ~a-~a times" 1415 smin smax))))) 1416 (newline)))))) 1417 (newline) 1418 (<h2> ([style "margin-bottom: 0.25rem"]) 1419 (html-text "Files")) 1420 (newline) 1421 (<table> ([style "margin-bottom: 1rem"]) 1422 (newline) 1423 (for-each 1424 (lambda (fdata) 1425 (let ([ip (filedata-ip fdata)]) 1426 (<tr> () 1427 (<td> ([class (color-class (filedata-ci fdata))] 1428 [style "padding: 0.5rem"]) 1429 (if ip 1430 (<a> ([href (filedata-htmlfn fdata)] 1431 [target (filedata-winid fdata)] 1432 [class (color-class (filedata-ci fdata))]) 1433 (html-text "~a" (port-name (filedata-ip fdata)))) 1434 (html-text "~a" 1435 (source-file-descriptor-name (filedata-sfd fdata)))))) 1436 (newline) 1437 (when ip (display-file who palette fdata)))) 1438 (sort 1439 (lambda (x y) 1440 (> (filedata-max-count x) 1441 (filedata-max-count y))) 1442 fdata*)))) 1443 (newline) 1444 (<td> ([style "width: 10rem"])) 1445 (newline) 1446 (<td> ([style "vertical-align: top"]) 1447 (<h2> ([style "margin-bottom: 0.25rem"]) 1448 (html-text "Hot Spots")) 1449 (newline) 1450 (<table> ([style "margin-bottom: 1rem"]) 1451 (newline) 1452 (let loop ([entry* 1453 (sort 1454 (lambda (x y) 1455 (or (> (entrydata-count x) (entrydata-count y)) 1456 (and (= (entrydata-count x) (entrydata-count y)) 1457 (let ([fn1 (filedata-htmlfn (entrydata-fdata x))] 1458 [fn2 (filedata-htmlfn (entrydata-fdata y))]) 1459 (and fn1 fn2 1460 (or (string<? fn1 fn2) 1461 (and (string=? fn1 fn2) 1462 (let ([line1 (entrydata-line x)] 1463 [line2 (entrydata-line y)]) 1464 (and line1 line2 (< line1 line2)))))))))) 1465 (apply append (map filedata-entry* fdata*)))] 1466 [last-htmlfn #f] 1467 [last-count #f] 1468 [last-line #f]) 1469 (unless (or (null? entry*) (= (entrydata-count (car entry*)) 0)) 1470 (let* ([entry (car entry*)] 1471 [count (entrydata-count entry)] 1472 [line (entrydata-line entry)] 1473 [fdata (entrydata-fdata entry)] 1474 [htmlfn (filedata-htmlfn fdata)]) 1475 (unless (and htmlfn last-htmlfn 1476 (string=? htmlfn last-htmlfn) 1477 (= count last-count) 1478 (= line last-line)) 1479 (<tr> () 1480 (<td> ([class (color-class (entrydata-ci entry))] 1481 [style "padding: 0.5rem"]) 1482 (cond 1483 [(filedata-ip fdata) => 1484 (lambda (ip) 1485 (let ([url (format "~a#line~d" 1486 (filedata-htmlfn fdata) 1487 line)]) 1488 (<a> ([href url] 1489 [target (filedata-winid fdata)] 1490 [style "text-decoration: underline"] 1491 [class (color-class (entrydata-ci entry))]) 1492 (html-text "~a line ~s (~:d)" 1493 (port-name ip) (entrydata-line entry) 1494 (entrydata-count entry)))))] 1495 [else 1496 (html-text "~a char ~s (~:d)" 1497 (source-file-descriptor-name (filedata-sfd fdata)) 1498 (entrydata-bfp entry) 1499 (entrydata-count entry))]))) 1500 (newline)) 1501 (loop (cdr entry*) htmlfn count line))))) 1502 (newline)) 1503 (newline))) 1504 (newline))) 1505 (for-each 1506 (lambda (fdata) (cond [(filedata-ip fdata) => close-input-port])) 1507 fdata*)))])))) 1508 1509 (set-who! profile-palette 1510 (make-parameter 1511 ; color background with appropriate white or black foreground 1512 '#(("#111111" . "white") ; black (for unprofiled code) 1513 ("#607D8B" . "white") ; gray (for unexecuted code) 1514 ("#9C27B0" . "black") ; purple 1515 ("#673AB7" . "white") ; dark purple 1516 ("#3F51B5" . "white") ; dark blue 1517 ("#2196F3" . "black") ; medium blue 1518 ("#00BCD4" . "black") ; aqua 1519 ("#4CAF50" . "black") ; green 1520 ("#CDDC39" . "black") ; yellow green 1521 ("#FFEB3B" . "black") ; yellow 1522 ("#FFC107" . "black") ; dark yellow 1523 ("#FF9800" . "black") ; orange 1524 ("#F44336" . "white")) ; red 1525 (lambda (palette) 1526 (unless (and (vector? palette) 1527 (andmap 1528 (lambda (x) 1529 (and (pair? x) (string? (car x)) (string? (cdr x)))) 1530 (vector->list palette))) 1531 ($oops who "invalid palette ~s" palette)) 1532 (unless (fx> (vector-length palette) 2) 1533 ($oops who "palette ~s has too few entries" palette)) 1534 palette))) 1535 1536 (set-who! profile-line-number-color 1537 (make-parameter "#666666" 1538 (lambda (color) 1539 (unless (or (eq? color #f) (string? color)) ($oops who "~s is not a string or #f" color)) 1540 color))) 1541) 1542) 1543