1#lang racket/base 2(require (only-in racket/list flatten) 3 (only-in racket/future futures-enabled?) 4 racket/set 5 (only-in racket/vector vector-drop) 6 "constants.rkt" 7 "graph-drawing.rkt" 8 "display.rkt" 9 (only-in '#%futures 10 reset-future-logs-for-tracing! 11 mark-future-trace-end!)) 12 13(provide start-future-tracing! 14 stop-future-tracing! 15 (struct-out future-event) 16 (struct-out gc-info) 17 (struct-out indexed-future-event) 18 (struct-out trace) 19 (struct-out process-timeline) 20 (struct-out future-timeline) 21 (struct-out event) 22 (struct-out rtcall-info) 23 timeline-events 24 organize-output 25 build-trace 26 missing-data? 27 event-has-duration? 28 op-name 29 touch-event? 30 allocation-event? 31 jitcompile-event? 32 synchronization-event? 33 runtime-synchronization-event? 34 runtime-block-event? 35 worker-block-event? 36 runtime-sync-event? 37 worker-sync-event? 38 gc-event? 39 work-event? 40 final-event? 41 relative-time 42 event-or-gc-time 43 proc-id-or-gc<?) 44 45(define-struct future-event (future-id process-id what time prim-name user-data) 46 #:prefab) 47 48(define-struct gc-info (major? 49 pre-used 50 pre-admin 51 code-page-total 52 post-used 53 post-admin 54 start-time 55 end-time 56 start-real-time 57 end-real-time) #:prefab) 58 59;Contains an index and a future-event, 60;so we can preserve the order in which future-events 61;were logged. 62;Many future-events can be logged at what appears to be the same 63;time, apparently because the time values don't have great enough precision 64;to separate events which temporally occur close together. 65(struct indexed-future-event (index fevent) #:transparent) 66 67;The whole trace, with a start/end time and list of process timelines 68(struct trace (start-time ;Absolute start time (in process milliseconds) 69 end-time ;Absolute end time 70 proc-timelines ;(listof process-timeline) 71 future-timelines ;Hash of (future id --o--> (listof event)) 72 gc-timeline ;process-timeline where proc-id == 'gc, and each event is a GC 73 all-events ;(listof event) 74 real-time ;Total amount of time for the trace (in ms) 75 num-futures ;Number of futures created 76 num-blocks ;Number of barricades hit 77 num-syncs ;Number of 'atomic' ops done 78 num-gcs ;Number of GC's that occurred during the trace 79 blocked-futures ;Number of futures which encountered a barricade at some point 80 avg-syncs-per-future 81 block-counts ;prim name --o--> number of blocks 82 sync-counts ;op name --o--> number of syncs 83 future-rtcalls ;fid --o--> rtcall-info 84 creation-tree)) 85 86(struct rtcall-info (fid 87 block-hash ; prim name --o--> number of blocks 88 sync-hash) ; op name --o--> number of syncs 89 #:transparent) 90 91;(struct process-timeline timeline (proc-index)) 92(struct process-timeline (proc-id 93 proc-index 94 start-time 95 end-time 96 events)) 97 98;(struct future-timeline timeline ()) 99(struct future-timeline (future-id 100 start-time 101 end-time 102 events)) 103 104;A block of time (e.g. a process executing a portion of a future thunk). 105(struct event (index 106 start-time 107 end-time 108 proc-id 109 proc-index ;The id of the process in which this event occurred 110 future-id 111 [user-data #:mutable] 112 type 113 [prim-name #:mutable] 114 timeline-position ;The event's position among all events occurring in its process (sorted by time) 115 [prev-proc-event #:mutable] 116 [next-proc-event #:mutable] 117 [prev-future-event #:mutable] 118 [next-future-event #:mutable] 119 [next-targ-future-event #:mutable] 120 [prev-targ-future-event #:mutable] 121 ;If the event is a block on a future thread, pointer to the corresponding 122 ;event indicating block handled on runtime thread 123 [block-handled-event #:mutable] 124 [segment #:mutable]) #:transparent) 125 126;;event-has-duration? : event -> bool 127(define (event-has-duration? evt) 128 (case (event-type evt) 129 [(start-work start-0-work gc) #t] 130 [else #f])) 131 132(define (missing-data? log) 133 (if (findf (λ (e) (equal? (future-event-what (indexed-future-event-fevent e)) 'missing)) log) 134 #t 135 #f)) 136 137;;event-op-name : (or event indexed-future-event future-event) -> symbol 138(define (op-name evt) 139 (cond 140 [(event? evt) (event-prim-name evt)] 141 [(indexed-future-event? evt) (op-name (indexed-future-event-fevent evt))] 142 [(future-event? evt) (future-event-prim-name evt)] 143 [(gc-info? evt) 'gc])) 144 145;;event-what : (or event indexed-future-event future-event) -> symbol 146(define (what evt) 147 (cond 148 [(event? evt) (event-type evt)] 149 [(indexed-future-event? evt) (what (indexed-future-event-fevent evt))] 150 [(future-event? evt) (future-event-what evt)] 151 [(gc-info? evt) 'gc])) 152 153;;process-id : (or event indexed-future-event future-event) -> exact-nonnegative-integer 154(define (process-id evt) 155 (cond 156 [(event? evt) (event-proc-id evt)] 157 [(indexed-future-event? evt) (process-id (indexed-future-event-fevent evt))] 158 [(future-event? evt) (future-event-process-id evt)] 159 [(gc-info? evt) RT-THREAD-ID])) 160 161;;touch-event? : (or event indexed-future-event future-event) -> symbol 162(define (touch-event? evt) 163 (equal? (what evt) 'touch)) 164 165;;allocation-event? : (or event indexed-future-event future-event) -> bool 166(define (allocation-event? evt) 167 (equal? (op-name evt) '|[allocate memory]|)) 168 169;;jitcompile-event : (or event indexed-future-event future-event) -> bool 170(define (jitcompile-event? evt) 171 (equal? (op-name evt) '|[jit_on_demand]|)) 172 173;;synchronization-event? : (or event indexed-future-event future-event) -> bool 174(define (synchronization-event? evt) 175 (case (what evt) 176 [(block sync) #t] 177 [else #f])) 178 179;;work-event : (or event indexed-future-event future-event) -> bool 180(define (work-event? evt) 181 (case (what evt) 182 [(start-work start-0-work) #t] 183 [else #f])) 184 185;;runtime-thread-evt? : (or event indexed-future-event future-event) -> bool 186(define (runtime-thread-evt? evt) 187 (define pid (process-id evt)) 188 (and (number? pid) (= (process-id evt) RT-THREAD-ID))) 189 190;;runtime-synchronization-event? : (or event indexed-future-event future-event) -> bool 191(define (runtime-synchronization-event? evt) 192 (and (synchronization-event? evt) (= (process-id evt) RT-THREAD-ID))) 193 194;;runtime-block-event? : (or event indexed-future-event future-event) -> bool 195(define (runtime-block-event? evt) 196 (and (runtime-thread-evt? evt) (equal? (what evt) 'block))) 197 198;;worker-block-event? : (or event indexed-future-event future-event) -> bool 199(define (worker-block-event? evt) 200 (and (not (runtime-thread-evt? evt)) (equal? (what evt) 'block))) 201 202;;runtime-sync-evt? : (or event indexed-future-event future-event) -> bool 203(define (runtime-sync-event? evt) 204 (and (runtime-thread-evt? evt) (equal? (what evt) 'sync))) 205 206;;worker-sync-evt? : (or event indexed-future-event future-event) -> bool 207(define (worker-sync-event? evt) 208 (and (not (runtime-sync-event? evt)) (equal? (what evt) 'sync))) 209 210;;gc-event? : (or event indexed-future-event future-event) -> bool 211(define (gc-event? evt) 212 (equal? (what evt) 'gc)) 213 214;;final-event? : event -> bool 215(define (final-event? evt) 216 (case (event-timeline-position evt) 217 [(end singleton) #t] 218 [else #f])) 219 220;;get-relative-start-time : trace float -> float 221(define (relative-time trace abs-time) 222 (- abs-time (trace-start-time trace))) 223 224;Log message receiver 225(define recv #f) 226 227;;start-future-tracing! -> void 228(define (start-future-tracing!) 229 (reset-future-logs-for-tracing!) 230 (when (not recv) 231 (set! recv (make-log-receiver (current-logger) 'debug)))) 232 233;;stop-future-tracing! -> void 234(define (stop-future-tracing!) 235 (mark-future-trace-end!)) 236 237;;event-or-gc-time : (or future-event gc-info indexed-future-event) -> float 238(define (event-or-gc-time evt) 239 (cond 240 [(future-event? evt) (future-event-time evt)] 241 [(gc-info? evt) (gc-info-start-real-time evt)] 242 [else (event-or-gc-time (indexed-future-event-fevent evt))])) 243 244;;process-id-or-gc : (or future-event gc-info) -> (or nonnegative-integer 'gc) 245(define (process-id-or-gc evt) 246 (if (future-event? evt) 247 (future-event-process-id evt) 248 'gc)) 249 250;;timeline-events/private : -> void 251(define (timeline-events/private) 252 (let ([info (sync/timeout 0 recv)]) 253 (if info 254 (let ([v (vector-ref info 2)]) 255 (cond 256 [(future-event? v) 257 (case (future-event-what v) 258 [(stop-trace) '()] 259 [else (cons v (timeline-events/private))])] 260 [(gc-info? v) (cons v (timeline-events/private))] 261 [else (timeline-events/private)])) 262 (timeline-events/private)))) 263 264;Gets log events for an execution timeline 265;;timeline-events : (listof indexed-future-event) 266(define (timeline-events) 267 (cond 268 [(not (futures-enabled?)) '()] 269 [else 270 (define sorted (sort (timeline-events/private) 271 #:key event-or-gc-time 272 <)) 273 (for/list ([evt (in-list sorted)] 274 [i (in-naturals)]) 275 (indexed-future-event i evt))])) 276 277;;proc-id-or-gc<? : (or number symbol) (or number symbol) -> bool 278(define (proc-id-or-gc<? a b) 279 (cond 280 [(equal? b 'gc) #f] 281 [(equal? a 'gc) #t] 282 [else (< a b)])) 283 284;Produces a vector of vectors, where each inner vector contains 285;all the log output messages for a specific process 286;;organize-output : (listof indexed-future-event) real real -> (vectorof (vectorof future-event)) 287(define (organize-output raw-log-output start-time end-time) 288 (define unique-proc-ids (for/set ([ie (in-list (filter (λ (e) 289 (between (event-or-gc-time (indexed-future-event-fevent e)) 290 start-time 291 end-time)) 292 raw-log-output))]) 293 (process-id-or-gc (indexed-future-event-fevent ie)))) 294 (for/vector ([procid (in-list (sort (set->list unique-proc-ids) proc-id-or-gc<?))]) 295 (for/vector ([e (in-list raw-log-output)] 296 #:when (equal? procid (process-id-or-gc (indexed-future-event-fevent e)))) 297 e))) 298 299;;Grab the first and last future events in the trace. 300;;first-and-last-fevents : (listof (or future-event gc-info)) -> (values future-event future-event) 301(define (first-and-last-fevents log) 302 (let loop ([fst #f] 303 [last #f] 304 [remaining-log log]) 305 (cond 306 [(null? remaining-log) (values fst last)] 307 [else 308 (define f (indexed-future-event-fevent (car remaining-log))) 309 (define rest (cdr remaining-log)) 310 (cond 311 [fst (if (future-event? f) 312 (loop fst f rest) 313 (loop fst last rest))] 314 [else (if (future-event? f) 315 (loop f last rest) 316 (loop fst last rest))])]))) 317 318;;event-pos-description : uint uint -> (or 'singleton 'start 'end 'interior) 319(define (event-pos-description index timeline-len) 320 (cond 321 [(zero? index) (if (= index (sub1 timeline-len)) 322 'singleton 323 'start)] 324 [(= index (sub1 timeline-len)) 'end] 325 [else 'interior])) 326 327;;build-timelines : (vectorof (vectorof future-event)) -> (listof process-timeline) 328(define (build-timelines data) 329 (for/list ([proc-log-vec (in-vector data)] 330 [i (in-naturals)]) 331 (define timeline-len (vector-length proc-log-vec)) 332 (let* ([fst-ie (vector-ref proc-log-vec 0)] 333 [fst-log-msg (indexed-future-event-fevent fst-ie)]) 334 (process-timeline (process-id-or-gc fst-log-msg) 335 i 336 (event-or-gc-time fst-log-msg) 337 (event-or-gc-time (indexed-future-event-fevent 338 (vector-ref proc-log-vec 339 (sub1 timeline-len)))) 340 (for/list ([ie (in-vector proc-log-vec)] 341 [j (in-naturals)]) 342 (define evt (indexed-future-event-fevent ie)) 343 (define pos (event-pos-description j timeline-len)) 344 (define start (event-or-gc-time evt)) 345 (define end (if (or (equal? pos 'end) (equal? pos 'singleton)) 346 start 347 (future-event-time (indexed-future-event-fevent 348 (vector-ref proc-log-vec (add1 j)))))) 349 (event (indexed-future-event-index ie) 350 start 351 end 352 (process-id-or-gc evt) 353 i 354 (future-event-future-id evt) 355 (future-event-user-data evt) 356 (future-event-what evt) 357 (future-event-prim-name evt) 358 pos 359 #f #f #f #f #f #f #f #f)))))) 360 361;;build-trace : (listof indexed-future-event) -> trace 362(define (build-trace log-output) 363 (when (null? log-output) 364 (error 'build-trace "Empty timeline in log-output")) 365 (define-values (fst last) (first-and-last-fevents log-output)) 366 (when (and (not fst) (not last)) ;If the log has no future events (only GC's) no timeline 367 (error 'build-trace "Empty timeline in log-output")) 368 (define start-time (future-event-time fst)) 369 (define end-time (future-event-time last)) 370 (define data (organize-output log-output start-time end-time)) 371 (define-values (unique-fids nblocks nsyncs gcs) 372 (for/fold ([unique-fids (set)] 373 [nblocks 0] 374 [nsyncs 0] 375 [gc-evts '()]) ([ie (in-list log-output)]) 376 (define evt (indexed-future-event-fevent ie)) 377 (cond 378 [(gc-info? evt) 379 (cond 380 [(between (event-or-gc-time evt) start-time end-time) 381 (values unique-fids nblocks nsyncs (cons ie gc-evts))] 382 [else (values unique-fids nblocks nsyncs gc-evts)])] 383 [else 384 (define fid (future-event-future-id evt)) 385 (define is-future-thread? (not (= (future-event-process-id evt) RT-THREAD-ID))) 386 (values 387 (if fid 388 (set-add unique-fids fid) 389 unique-fids) 390 (if (and is-future-thread? 391 (case (future-event-what evt) 392 [(block touch) #t] 393 [else #f])) 394 (add1 nblocks) 395 nblocks) 396 (if (and is-future-thread? (equal? (future-event-what evt) 'sync)) 397 (add1 nsyncs) 398 nsyncs) 399 gc-evts)]))) 400 (define ngcs (length gcs)) 401 ;If we have any GC events, the 0th element of 'data' contains them; 402 ;don't build a timeline for it in the usual manner 403 (define tls (build-timelines (if (zero? ngcs) data (vector-drop data 1)))) 404 (define gc-timeline (process-timeline 'gc 405 'gc 406 start-time 407 end-time 408 (for/list ([gcie (in-list gcs)] 409 [i (in-naturals)]) 410 (define gc (indexed-future-event-fevent gcie)) 411 (event (indexed-future-event-index gcie) 412 (event-or-gc-time gc) 413 (gc-info-end-real-time gc) 414 'gc 415 'gc 416 #f 417 (if (gc-info-major? gc) 'major 'minor) 418 'gc 419 #f 420 (event-pos-description i ngcs) 421 #f #f #f #f #f #f #f #f)))) 422 (define all-evts (sort (append (flatten (for/list ([tl (in-list tls)]) (process-timeline-events tl))) 423 (process-timeline-events gc-timeline)) 424 #:key event-index 425 <)) 426 (define non-gc-evts (filter (λ (e) (not (gc-event? e))) all-evts)) 427 (define future-tl-hash (let ([h (make-hash)]) 428 (for ([evt (in-list non-gc-evts)]) 429 (let* ([fid (event-future-id evt)] 430 [existing (hash-ref h fid '())]) 431 (hash-set! h fid (cons evt existing)))) 432 h)) 433 (for ([fid (in-list (hash-keys future-tl-hash))]) 434 (hash-set! future-tl-hash fid (reverse (hash-ref future-tl-hash fid)))) 435 (define-values (block-hash sync-hash rtcalls-per-future-hash) (build-rtcall-hashes all-evts)) 436 (define tr (trace start-time 437 end-time 438 tls 439 future-tl-hash 440 gc-timeline 441 all-evts 442 (- end-time start-time) ;real time 443 (set-count unique-fids) ;num-futures 444 nblocks ;num-blocks 445 nsyncs ;num-syncs 446 ngcs ;num-gcs 447 0 448 0 449 block-hash 450 sync-hash 451 rtcalls-per-future-hash ;hash of fid -> rtcall-info 452 (build-creation-graph future-tl-hash))) 453 (connect-event-chains! tr) 454 (connect-target-fid-events! tr) 455 tr) 456 457;;build-rtcall-hash : (listof event) -> (values (blocking_prim -o-> count) (sync_prim -o-> count) (fid -o-> rtcall-info) 458(define (build-rtcall-hashes evts) 459 (define block-hash (make-hash)) 460 (define sync-hash (make-hash)) 461 (define rt-hash (make-hash)) 462 (for ([evt (in-list (filter runtime-synchronization-event? evts))]) 463 (define isblock (runtime-block-event? evt)) 464 (define ophash (if isblock block-hash sync-hash)) 465 (hash-update! ophash 466 (event-prim-name evt) 467 (λ (old) (+ old 1)) 468 0) 469 (hash-update! rt-hash 470 (event-future-id evt) 471 (λ (old) 472 (let ([h (if isblock 473 (rtcall-info-block-hash old) 474 (rtcall-info-sync-hash old))]) 475 (hash-update! h 476 (event-prim-name evt) 477 (λ (o) (+ o 1)) 478 0)) 479 old) 480 (rtcall-info (event-future-id evt) (make-hash) (make-hash)))) 481 (values block-hash sync-hash rt-hash)) 482 483;;connect-event-chains! : trace -> void 484(define (connect-event-chains! trace) 485 (for ([tl (in-list (trace-proc-timelines trace))]) 486 (let loop ([evts (process-timeline-events tl)]) 487 (cond 488 [(or (null? evts) (null? (cdr evts))) void] 489 [else 490 (set-event-prev-proc-event! (car (cdr evts)) (car evts)) 491 (set-event-next-proc-event! (car evts) (car (cdr evts))) 492 (loop (cdr evts))]))) 493 (for ([fid (in-list (hash-keys (trace-future-timelines trace)))]) 494 (let loop ([evts (hash-ref (trace-future-timelines trace) fid)] 495 [last-fthread-block #f]) 496 (cond 497 [(or (null? evts) (null? (cdr evts))) void] 498 [else 499 (define curevt (car evts)) 500 (define nextevt (car (cdr evts))) 501 (set-event-prev-future-event! nextevt curevt) 502 (set-event-next-future-event! curevt nextevt) 503 (cond 504 [(and last-fthread-block (or (runtime-sync-event? curevt) (runtime-block-event? curevt))) 505 (set-event-block-handled-event! last-fthread-block curevt) 506 (set-event-prim-name! last-fthread-block (event-prim-name curevt)) 507 (set-event-user-data! last-fthread-block (event-user-data curevt)) 508 (loop (cdr evts) #f)] 509 [(or (worker-block-event? curevt) (worker-sync-event? curevt)) 510 (loop (cdr evts) curevt)] 511 [else 512 (loop (cdr evts) last-fthread-block)])])))) 513 514;;connect-target-fid-events! : trace -> void 515(define (connect-target-fid-events! trace) 516 (let loop ([rest (trace-all-events trace)]) 517 (unless (null? rest) 518 (let ([cur-evt (car rest)]) 519 (when (and (or (equal? (event-type cur-evt) 'create) 520 (equal? (event-type cur-evt) 'touch)) 521 (>= (event-user-data cur-evt) 0)) 522 (let ([targ-evt (findf (λ (e) (and (event-future-id e) 523 (= (event-future-id e) 524 (event-user-data cur-evt)))) 525 (cdr rest))]) 526 (when targ-evt 527 (set-event-next-targ-future-event! cur-evt targ-evt) 528 (set-event-prev-targ-future-event! targ-evt cur-evt)))) 529 (loop (cdr rest)))))) 530 531;;creation-event : event -> bool 532(define (creation-event? evt) 533 (equal? (event-type evt) 'create)) 534 535;;buid-creation-graph/private : (uint -o-> (listof future-event)) -> (listof node) 536(define (build-creation-graph/private future-timelines evt) 537 (let* ([fid (event-user-data evt)] 538 [ftimeline (hash-ref future-timelines fid #f)]) 539 (if ftimeline 540 (let ([fevents (filter creation-event? (hash-ref future-timelines fid #f))]) 541 (for/list ([cevt (in-list fevents)]) 542 (node cevt 543 (build-creation-graph/private future-timelines cevt)))) 544 (begin 545 (eprintf "WARNING: Could not find timeline for future ~a. Creation tree may be truncated.\n" fid) 546 '())))) 547 548;;build-creation-graph : (uint -o-> (listof future-event)) -> node 549(define (build-creation-graph future-timelines) 550 (define roots (filter creation-event? 551 (hash-ref future-timelines #f))) 552 (define root-nodes (for/list ([root (in-list roots)]) 553 (node root 554 (build-creation-graph/private future-timelines root)))) 555 (node 'runtime-thread 556 root-nodes)) 557