FV: refactoring, various layout/display fixes
This commit is contained in:
James Swaine
parent
be538b4f69
commit
b94caa2d77
|
|
@ -1,9 +1,8 @@
|
|||
#lang racket/base
|
||||
(require racket/bool
|
||||
racket/list
|
||||
racket/contract
|
||||
racket/future
|
||||
(require (only-in racket/list flatten)
|
||||
(only-in racket/future futures-enabled?)
|
||||
racket/set
|
||||
(only-in racket/vector vector-drop)
|
||||
"constants.rkt"
|
||||
"graph-drawing.rkt"
|
||||
"display.rkt"
|
||||
|
|
@ -65,6 +64,7 @@
|
|||
end-time ;Absolute end time
|
||||
proc-timelines ;(listof process-timeline)
|
||||
future-timelines ;Hash of (future id --o--> (listof event))
|
||||
gc-timeline ;(listof event), where each event is a GC
|
||||
all-events ;(listof event)
|
||||
real-time ;Total amount of time for the trace (in ms)
|
||||
num-futures ;Number of futures created
|
||||
|
|
@ -211,11 +211,12 @@
|
|||
(define (stop-future-tracing!)
|
||||
(mark-future-trace-end!))
|
||||
|
||||
;;event-or-gc-time : (or future-event gc-info) -> float
|
||||
;;event-or-gc-time : (or future-event gc-info indexed-future-event) -> float
|
||||
(define (event-or-gc-time evt)
|
||||
(if (future-event? evt)
|
||||
(future-event-time evt)
|
||||
(gc-info-start-real-time evt)))
|
||||
(cond
|
||||
[(future-event? evt) (future-event-time evt)]
|
||||
[(gc-info? evt) (gc-info-start-real-time evt)]
|
||||
[else (event-or-gc-time (indexed-future-event-fevent evt))]))
|
||||
|
||||
;;process-id-or-gc : (or future-event gc-info) -> (or nonnegative-integer 'gc)
|
||||
(define (process-id-or-gc evt)
|
||||
|
|
@ -261,14 +262,15 @@
|
|||
;all the log output messages for a specific process
|
||||
;;organize-output : (listof indexed-future-event) real real -> (vectorof (vectorof future-event))
|
||||
(define (organize-output raw-log-output start-time end-time)
|
||||
(define unique-proc-ids (for/set ([ie (in-list raw-log-output)])
|
||||
(process-id-or-gc (indexed-future-event-fevent ie))))
|
||||
(define unique-proc-ids (for/set ([ie (in-list (filter (λ (e)
|
||||
(between (event-or-gc-time (indexed-future-event-fevent e))
|
||||
start-time
|
||||
end-time))
|
||||
raw-log-output))])
|
||||
(process-id-or-gc (indexed-future-event-fevent ie))))
|
||||
(for/vector ([procid (in-list (sort (set->list unique-proc-ids) proc-id-or-gc<?))])
|
||||
(for/vector ([e (in-list raw-log-output)]
|
||||
#:when (and (equal? procid (process-id-or-gc (indexed-future-event-fevent e)))
|
||||
(between (event-or-gc-time (indexed-future-event-fevent e))
|
||||
start-time
|
||||
end-time)))
|
||||
#:when (equal? procid (process-id-or-gc (indexed-future-event-fevent e))))
|
||||
e)))
|
||||
|
||||
;;Grab the first and last future events in the trace.
|
||||
|
|
@ -278,7 +280,7 @@
|
|||
[last #f]
|
||||
[remaining-log log])
|
||||
(cond
|
||||
[(empty? remaining-log) (values fst last)]
|
||||
[(null? remaining-log) (values fst last)]
|
||||
[else
|
||||
(define f (indexed-future-event-fevent (car remaining-log)))
|
||||
(define rest (cdr remaining-log))
|
||||
|
|
@ -290,26 +292,69 @@
|
|||
(loop f last rest)
|
||||
(loop fst last rest))])])))
|
||||
|
||||
;;event-pos-description : uint uint -> (or 'singleton 'start 'end 'interior)
|
||||
(define (event-pos-description index timeline-len)
|
||||
(cond
|
||||
[(zero? index) (if (= index (sub1 timeline-len))
|
||||
'singleton
|
||||
'start)]
|
||||
[(= index (sub1 timeline-len)) 'end]
|
||||
[else 'interior]))
|
||||
|
||||
;;build-timelines : (vectorof (vectorof future-event)) -> (listof process-timeline)
|
||||
(define (build-timelines data)
|
||||
(for/list ([proc-log-vec (in-vector data)]
|
||||
[i (in-naturals)])
|
||||
(define timeline-len (vector-length proc-log-vec))
|
||||
(let* ([fst-ie (vector-ref proc-log-vec 0)]
|
||||
[fst-log-msg (indexed-future-event-fevent fst-ie)])
|
||||
(process-timeline (process-id-or-gc fst-log-msg)
|
||||
i
|
||||
(event-or-gc-time fst-log-msg)
|
||||
(event-or-gc-time (indexed-future-event-fevent
|
||||
(vector-ref proc-log-vec
|
||||
(sub1 timeline-len))))
|
||||
(for/list ([ie (in-vector proc-log-vec)]
|
||||
[j (in-naturals)])
|
||||
(define evt (indexed-future-event-fevent ie))
|
||||
(define pos (event-pos-description j timeline-len))
|
||||
(define start (event-or-gc-time evt))
|
||||
(define end (if (or (equal? pos 'end) (equal? pos 'singleton))
|
||||
start
|
||||
(future-event-time (indexed-future-event-fevent
|
||||
(vector-ref proc-log-vec (add1 j))))))
|
||||
(event (indexed-future-event-index ie)
|
||||
start
|
||||
end
|
||||
(process-id-or-gc evt)
|
||||
i
|
||||
(future-event-future-id evt)
|
||||
(future-event-user-data evt)
|
||||
(future-event-what evt)
|
||||
(future-event-prim-name evt)
|
||||
pos
|
||||
#f #f #f #f #f #f #f))))))
|
||||
|
||||
;;build-trace : (listof indexed-future-event) -> trace
|
||||
(define (build-trace log-output)
|
||||
(when (empty? log-output)
|
||||
(when (null? log-output)
|
||||
(error 'build-trace "Empty timeline in log-output"))
|
||||
(define-values (fst last) (first-and-last-fevents log-output))
|
||||
(define start-time (future-event-time fst))
|
||||
(define end-time (future-event-time last))
|
||||
(define data (organize-output log-output start-time end-time))
|
||||
(define-values (unique-fids nblocks nsyncs ngcs)
|
||||
(define-values (unique-fids nblocks nsyncs gcs)
|
||||
(for/fold ([unique-fids (set)]
|
||||
[nblocks 0]
|
||||
[nsyncs 0]
|
||||
[ngcs 0]) ([ie (in-list log-output)])
|
||||
[gc-evts '()]) ([ie (in-list log-output)])
|
||||
(define evt (indexed-future-event-fevent ie))
|
||||
(cond
|
||||
[(gc-info? evt)
|
||||
(cond
|
||||
[(between (event-or-gc-time evt) start-time end-time)
|
||||
(values unique-fids nblocks nsyncs (add1 ngcs))]
|
||||
[else (values unique-fids nblocks nsyncs ngcs)])]
|
||||
(values unique-fids nblocks nsyncs (cons ie gc-evts))]
|
||||
[else (values unique-fids nblocks nsyncs gc-evts)])]
|
||||
[else
|
||||
(define fid (future-event-future-id evt))
|
||||
(define is-future-thread? (not (= (future-event-process-id evt) RT-THREAD-ID)))
|
||||
|
|
@ -323,96 +368,62 @@
|
|||
[else #f]))
|
||||
(add1 nblocks)
|
||||
nblocks)
|
||||
(if (and is-future-thread? (symbol=? (future-event-what evt) 'sync))
|
||||
(if (and is-future-thread? (equal? (future-event-what evt) 'sync))
|
||||
(add1 nsyncs)
|
||||
nsyncs)
|
||||
ngcs)])))
|
||||
(define tls (for/list ([proc-log-vec (in-vector data)]
|
||||
[i (in-naturals)])
|
||||
(cond
|
||||
[(= (vector-length proc-log-vec) 0)
|
||||
(process-timeline 'gc
|
||||
0
|
||||
start-time
|
||||
end-time
|
||||
'())]
|
||||
[else
|
||||
(let* ([fst-ie (vector-ref proc-log-vec 0)]
|
||||
[fst-log-msg (indexed-future-event-fevent fst-ie)])
|
||||
(process-timeline (process-id-or-gc fst-log-msg)
|
||||
i
|
||||
(event-or-gc-time fst-log-msg)
|
||||
(event-or-gc-time (indexed-future-event-fevent
|
||||
(vector-ref proc-log-vec
|
||||
(sub1 (vector-length proc-log-vec)))))
|
||||
(for/list ([ie (in-vector proc-log-vec)]
|
||||
[j (in-naturals)])
|
||||
(define evt (indexed-future-event-fevent ie))
|
||||
(define start (event-or-gc-time evt))
|
||||
(define pos (cond
|
||||
[(zero? j) (if (= j (sub1 (vector-length proc-log-vec)))
|
||||
'singleton
|
||||
'start)]
|
||||
[(= j (sub1 (vector-length proc-log-vec))) 'end]
|
||||
[else 'interior]))
|
||||
(define end (cond
|
||||
[(gc-info? evt) (gc-info-end-real-time evt)]
|
||||
[else
|
||||
(if (or (equal? pos 'end) (equal? pos 'singleton))
|
||||
start
|
||||
(future-event-time (indexed-future-event-fevent
|
||||
(vector-ref proc-log-vec (add1 j)))))]))
|
||||
(cond
|
||||
[(gc-info? evt)
|
||||
(event (indexed-future-event-index ie)
|
||||
start
|
||||
end
|
||||
'gc
|
||||
i
|
||||
#f
|
||||
#f
|
||||
'gc
|
||||
#f
|
||||
pos #f #f #f #f #f #f #f)]
|
||||
[else
|
||||
(event (indexed-future-event-index ie)
|
||||
start
|
||||
end
|
||||
(process-id-or-gc evt)
|
||||
i
|
||||
(future-event-future-id evt)
|
||||
(future-event-user-data evt)
|
||||
(future-event-what evt)
|
||||
(future-event-prim-name evt)
|
||||
pos #f #f #f #f #f #f #f)]))))])))
|
||||
(define all-evts (sort (flatten (for/list ([tl (in-list tls)]) (process-timeline-events tl)))
|
||||
gc-evts)])))
|
||||
(define ngcs (length gcs))
|
||||
;If we have any GC events, the 0th element of 'data' contains them;
|
||||
;don't buid a timeline for it in the usual manner
|
||||
(define tls (build-timelines (if (zero? ngcs) data (vector-drop data 1))))
|
||||
(define gc-timeline (process-timeline 'gc
|
||||
'gc
|
||||
start-time
|
||||
end-time
|
||||
(for/list ([gcie (in-list gcs)]
|
||||
[i (in-naturals)])
|
||||
(define gc (indexed-future-event-fevent gcie))
|
||||
(event (indexed-future-event-index gcie)
|
||||
(event-or-gc-time gc)
|
||||
(gc-info-end-real-time gc)
|
||||
'gc
|
||||
i
|
||||
#f
|
||||
#f
|
||||
'gc
|
||||
#f
|
||||
(event-pos-description i ngcs)
|
||||
#f #f #f #f #f #f #f))))
|
||||
(define all-evts (sort (flatten (append (process-timeline-events gc-timeline)
|
||||
(for/list ([tl (in-list tls)]) (process-timeline-events tl))))
|
||||
#:key event-index
|
||||
<))
|
||||
(define ftls (let ([h (make-hash)])
|
||||
(define future-tl-hash (let ([h (make-hash)])
|
||||
(for ([evt (in-list all-evts)])
|
||||
(let* ([fid (event-future-id evt)]
|
||||
[existing (hash-ref h fid '())])
|
||||
(hash-set! h fid (cons evt existing))))
|
||||
h))
|
||||
(for ([fid (in-list (hash-keys ftls))])
|
||||
(hash-set! ftls fid (reverse (hash-ref ftls fid))))
|
||||
(for ([fid (in-list (hash-keys future-tl-hash))])
|
||||
(hash-set! future-tl-hash fid (reverse (hash-ref future-tl-hash fid))))
|
||||
(define-values (block-hash sync-hash rtcalls-per-future-hash) (build-rtcall-hashes all-evts))
|
||||
(define tr (trace start-time
|
||||
end-time
|
||||
tls
|
||||
ftls
|
||||
future-tl-hash
|
||||
gc-timeline
|
||||
all-evts
|
||||
(- end-time start-time) ;real time
|
||||
(set-count unique-fids) ;num-futures
|
||||
nblocks ;num-blocks
|
||||
nsyncs ;num-syncs
|
||||
ngcs
|
||||
nblocks ;num-blocks
|
||||
nsyncs ;num-syncs
|
||||
ngcs ;num-gcs
|
||||
0
|
||||
0
|
||||
block-hash
|
||||
sync-hash
|
||||
rtcalls-per-future-hash ;hash of fid -> rtcall-info
|
||||
(build-creation-graph ftls)))
|
||||
(build-creation-graph future-tl-hash)))
|
||||
(connect-event-chains! tr)
|
||||
(connect-target-fid-events! tr)
|
||||
tr)
|
||||
|
|
@ -447,26 +458,26 @@
|
|||
(define (connect-event-chains! trace)
|
||||
(for ([tl (in-list (trace-proc-timelines trace))])
|
||||
(let loop ([evts (process-timeline-events tl)])
|
||||
(if (or (empty? evts) (empty? (cdr evts)))
|
||||
(if (or (null? evts) (null? (cdr evts)))
|
||||
void
|
||||
(begin
|
||||
(set-event-prev-proc-event! (first (cdr evts)) (car evts))
|
||||
(set-event-next-proc-event! (car evts) (first (cdr evts)))
|
||||
(set-event-prev-proc-event! (car (cdr evts)) (car evts))
|
||||
(set-event-next-proc-event! (car evts) (car (cdr evts)))
|
||||
(loop (cdr evts))))))
|
||||
(for ([fid (in-list (hash-keys (trace-future-timelines trace)))])
|
||||
(let ([events (hash-ref (trace-future-timelines trace) fid)])
|
||||
(let loop ([evts events])
|
||||
(if (or (empty? evts) (empty? (cdr evts)))
|
||||
(if (or (null? evts) (null? (cdr evts)))
|
||||
void
|
||||
(begin
|
||||
(set-event-prev-future-event! (first (cdr evts)) (car evts))
|
||||
(set-event-next-future-event! (car evts) (first (cdr evts)))
|
||||
(set-event-prev-future-event! (car (cdr evts)) (car evts))
|
||||
(set-event-next-future-event! (car evts) (car (cdr evts)))
|
||||
(loop (cdr evts))))))))
|
||||
|
||||
;;connect-target-fid-events! : trace -> void
|
||||
(define (connect-target-fid-events! trace)
|
||||
(let loop ([rest (trace-all-events trace)])
|
||||
(unless (empty? rest)
|
||||
(unless (null? rest)
|
||||
(let ([cur-evt (car rest)])
|
||||
(when (and (or (equal? (event-type cur-evt) 'create)
|
||||
(equal? (event-type cur-evt) 'touch))
|
||||
|
|
|
|||
|
|
@ -152,17 +152,15 @@
|
|||
x)))
|
||||
(- (- w (- max-x-extent w)) MIN-SEG-WIDTH))
|
||||
|
||||
;;calc-row-mid-y : uint (or uint symbol) uint uint -> uint
|
||||
(define (calc-row-mid-y proc-index proc-id row-height num-tls)
|
||||
;;calc-row-mid-y : uint uint trace -> uint
|
||||
(define (calc-row-mid-y proc-index row-height tr)
|
||||
(define PADDING 2)
|
||||
;GC events span the entire height of the execution timeline
|
||||
(cond
|
||||
[(symbol? proc-id) 0]
|
||||
[else
|
||||
(floor (- (+ (* (- proc-index 1)
|
||||
row-height)
|
||||
(/ row-height 2))
|
||||
PADDING))]))
|
||||
(floor (- (+ (* (if (> (trace-num-gcs tr) 0)
|
||||
(- proc-index 1)
|
||||
proc-index)
|
||||
row-height)
|
||||
(/ row-height 2))
|
||||
PADDING)))
|
||||
|
||||
;Gets the center of a circle with (xleft, ytop) as the top-left coordinate.
|
||||
;;calc-center : uint uint uint -> (values uint uint)
|
||||
|
|
@ -351,7 +349,6 @@
|
|||
(define last-right-edge (if is-gc-evt?
|
||||
largest-x
|
||||
(vector-ref last-right-edges (event-proc-index evt))))
|
||||
#;(define last-right-edge (vector-ref last-right-edges (event-proc-index evt)))
|
||||
(define wanted-offset (+ delta (* DEFAULT-TIMELINE-WIDTH
|
||||
(inexact->exact
|
||||
(/ (- (event-start-time evt) (trace-start-time tr))
|
||||
|
|
@ -367,7 +364,7 @@
|
|||
[else MIN-SEG-WIDTH]))
|
||||
(define seg (segment evt
|
||||
(round offset)
|
||||
(- (calc-row-mid-y (event-proc-index evt) (event-proc-id evt) TIMELINE-ROW-HEIGHT num-tls) radius)
|
||||
(- (calc-row-mid-y (event-proc-index evt) TIMELINE-ROW-HEIGHT tr) radius)
|
||||
segw
|
||||
segh
|
||||
(get-event-color (event-type evt))
|
||||
|
|
@ -451,17 +448,13 @@
|
|||
0
|
||||
0
|
||||
(for/fold ([pct base]) ([tl (in-list (filter (λ (tline)
|
||||
(cond
|
||||
[(equal? (process-timeline-proc-id tline) 'gc) #f]
|
||||
[else
|
||||
(define midy (calc-row-mid-y (process-timeline-proc-index tline)
|
||||
(process-timeline-proc-id tline)
|
||||
(frame-info-row-height finfo)
|
||||
num-tls))
|
||||
(define topy (- midy (frame-info-row-height finfo)))
|
||||
(define boty (+ midy (frame-info-row-height finfo)))
|
||||
(or (in-viewable-region-vert? vregion topy)
|
||||
(in-viewable-region-vert? vregion boty))]))
|
||||
(define midy (calc-row-mid-y (process-timeline-proc-index tline)
|
||||
(frame-info-row-height finfo)
|
||||
tr))
|
||||
(define topy (- midy (frame-info-row-height finfo)))
|
||||
(define boty (+ midy (frame-info-row-height finfo)))
|
||||
(or (in-viewable-region-vert? vregion topy)
|
||||
(in-viewable-region-vert? vregion boty)))
|
||||
(trace-proc-timelines tr)))])
|
||||
(let* ([line-coords (list-ref (frame-info-process-line-coords finfo)
|
||||
(process-timeline-proc-index tl))]
|
||||
|
|
@ -480,7 +473,7 @@
|
|||
(- line-end vregion-start)]
|
||||
[else vregion-end])]
|
||||
[index (process-timeline-proc-index tl)]
|
||||
[proc-name (if (= 1 index)
|
||||
[proc-name (if (zero? index)
|
||||
"Thread 0 (Runtime Thread)"
|
||||
(format "Thread ~a" (process-timeline-proc-id tl)))]
|
||||
[proc-title (text-block-pict proc-name
|
||||
|
|
@ -494,15 +487,14 @@
|
|||
(- (* index (frame-info-row-height finfo)) (viewable-region-y vregion))
|
||||
(colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color)))
|
||||
(at 0
|
||||
(+ (+ (- (* (sub1 index) (frame-info-row-height finfo)) (viewable-region-y vregion))
|
||||
(+ (+ (- (* index (frame-info-row-height finfo)) (viewable-region-y vregion))
|
||||
(- (frame-info-row-height finfo) (pict-height proc-title)))
|
||||
1)
|
||||
proc-title)
|
||||
(at start-x
|
||||
(- (calc-row-mid-y index
|
||||
(process-timeline-proc-id tl)
|
||||
(frame-info-row-height finfo)
|
||||
num-tls)
|
||||
tr)
|
||||
(viewable-region-y vregion))
|
||||
(colorize (hline (- end-x start-x) 1)
|
||||
(timeline-event-baseline-color))))))))
|
||||
|
|
|
|||
|
|
@ -23,9 +23,8 @@
|
|||
(values 0 (frame-info-adjusted-height frameinfo))]
|
||||
[else
|
||||
(define midy (calc-row-mid-y (process-timeline-proc-index tl)
|
||||
(process-timeline-proc-id tl)
|
||||
(frame-info-row-height frameinfo)
|
||||
(length (trace-proc-timelines tr))))
|
||||
tr))
|
||||
(values (floor (- midy (/ MIN-SEG-WIDTH 2)))
|
||||
(floor (+ midy (/ MIN-SEG-WIDTH 2))))]))
|
||||
(interval-map-set! ym
|
||||
|
|
@ -98,10 +97,19 @@
|
|||
(values (min screen-w DEF-WINDOW-WIDTH)
|
||||
(min screen-h DEF-WINDOW-HEIGHT)))
|
||||
|
||||
(define COMFORTABLE-TL-LEN 10000)
|
||||
|
||||
(define (show-visualizer #:timeline [timeline #f])
|
||||
(define the-tl (if timeline timeline (timeline-events)))
|
||||
(printf "trace length: ~a\n" (length the-tl))
|
||||
(when (empty? the-tl)
|
||||
(error 'show-visualizer "No future log messages found."))
|
||||
(when (> (length the-tl) COMFORTABLE-TL-LEN)
|
||||
(log-warning (format
|
||||
"show-visualizer: truncating log to ~a, dropped ~a messages"
|
||||
COMFORTABLE-TL-LEN
|
||||
(- (length the-tl) COMFORTABLE-TL-LEN)))
|
||||
(set! the-tl (take the-tl COMFORTABLE-TL-LEN)))
|
||||
(define the-trace (build-trace the-tl))
|
||||
(define-values (winw winh) (get-window-size))
|
||||
;The event segment we are currently mousing over
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@
|
|||
(check-equal? (length in-vr) 5))
|
||||
|
||||
;Trace compilation tests
|
||||
(let* ([future-log (list (indexed-future-event 0 (future-event 0 0 'create 0 #f 0))
|
||||
(let* ([future-log (list (indexed-future-event 0 (future-event #f 0 'create 0 #f 0))
|
||||
(indexed-future-event 1 (future-event 0 1 'start-work 1 #f #f))
|
||||
(indexed-future-event 2 (future-event 0 1 'end-work 2 #f #f))
|
||||
(indexed-future-event 3 (future-event 0 0 'complete 3 #f #f)))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user