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