suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

FV: refactoring, various layout/display fixes

Browse Source
This commit is contained in:
James Swaine 2012-10-09 22:51:37 -05:00
parent be538b4f69
commit b94caa2d77
4 changed files with 142 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

207
collects/future-visualizer/private/visualizer-data.rkt
View File

@ -1,9 +1,8 @@
#lang racket/base #lang racket/base
(require racket/bool (require (only-in racket/list flatten)
racket/list (only-in racket/future futures-enabled?)
racket/contract
racket/future
racket/set racket/set
(only-in racket/vector vector-drop)
"constants.rkt" "constants.rkt"
"graph-drawing.rkt" "graph-drawing.rkt"
"display.rkt" "display.rkt"
@ -64,7 +63,8 @@
(struct trace (start-time ;Absolute start time (in process milliseconds) (struct trace (start-time ;Absolute start time (in process milliseconds)
end-time ;Absolute end time end-time ;Absolute end time
proc-timelines ;(listof process-timeline) proc-timelines ;(listof process-timeline)
future-timelines ;Hash of (future id --o--> (listof event)) future-timelines ;Hash of (future id --o--> (listof event))
gc-timeline ;(listof event), where each event is a GC
all-events ;(listof event) all-events ;(listof event)
real-time ;Total amount of time for the trace (in ms) real-time ;Total amount of time for the trace (in ms)
num-futures ;Number of futures created num-futures ;Number of futures created
@ -211,11 +211,12 @@
(define (stop-future-tracing!) (define (stop-future-tracing!)
(mark-future-trace-end!)) (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) (define (event-or-gc-time evt)
(if (future-event? evt) (cond
(future-event-time evt) [(future-event? evt) (future-event-time evt)]
(gc-info-start-real-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) ;;process-id-or-gc : (or future-event gc-info) -> (or nonnegative-integer 'gc)
(define (process-id-or-gc evt) (define (process-id-or-gc evt)
@ -261,14 +262,15 @@
;all the log output messages for a specific process ;all the log output messages for a specific process
;;organize-output : (listof indexed-future-event) real real -> (vectorof (vectorof future-event)) ;;organize-output : (listof indexed-future-event) real real -> (vectorof (vectorof future-event))
(define (organize-output raw-log-output start-time end-time) (define (organize-output raw-log-output start-time end-time)
(define unique-proc-ids (for/set ([ie (in-list raw-log-output)]) (define unique-proc-ids (for/set ([ie (in-list (filter (λ (e)
(process-id-or-gc (indexed-future-event-fevent ie)))) (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 ([procid (in-list (sort (set->list unique-proc-ids) proc-id-or-gc<?))])
(for/vector ([e (in-list raw-log-output)] (for/vector ([e (in-list raw-log-output)]
#:when (and (equal? procid (process-id-or-gc (indexed-future-event-fevent e))) #:when (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)))
e))) e)))
;;Grab the first and last future events in the trace. ;;Grab the first and last future events in the trace.
@ -278,7 +280,7 @@
[last #f] [last #f]
[remaining-log log]) [remaining-log log])
(cond (cond
[(empty? remaining-log) (values fst last)] [(null? remaining-log) (values fst last)]
[else [else
(define f (indexed-future-event-fevent (car remaining-log))) (define f (indexed-future-event-fevent (car remaining-log)))
(define rest (cdr remaining-log)) (define rest (cdr remaining-log))
@ -289,27 +291,70 @@
[else (if (future-event? f) [else (if (future-event? f)
(loop f last rest) (loop f last rest)
(loop fst 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 ;;build-trace : (listof indexed-future-event) -> trace
(define (build-trace log-output) (define (build-trace log-output)
(when (empty? log-output) (when (null? log-output)
(error 'build-trace "Empty timeline in log-output")) (error 'build-trace "Empty timeline in log-output"))
(define-values (fst last) (first-and-last-fevents log-output)) (define-values (fst last) (first-and-last-fevents log-output))
(define start-time (future-event-time fst)) (define start-time (future-event-time fst))
(define end-time (future-event-time last)) (define end-time (future-event-time last))
(define data (organize-output log-output start-time end-time)) (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)] (for/fold ([unique-fids (set)]
[nblocks 0] [nblocks 0]
[nsyncs 0] [nsyncs 0]
[ngcs 0]) ([ie (in-list log-output)]) [gc-evts '()]) ([ie (in-list log-output)])
(define evt (indexed-future-event-fevent ie)) (define evt (indexed-future-event-fevent ie))
(cond (cond
[(gc-info? evt) [(gc-info? evt)
(cond (cond
[(between (event-or-gc-time evt) start-time end-time) [(between (event-or-gc-time evt) start-time end-time)
(values unique-fids nblocks nsyncs (add1 ngcs))] (values unique-fids nblocks nsyncs (cons ie gc-evts))]
[else (values unique-fids nblocks nsyncs ngcs)])] [else (values unique-fids nblocks nsyncs gc-evts)])]
[else [else
(define fid (future-event-future-id evt)) (define fid (future-event-future-id evt))
(define is-future-thread? (not (= (future-event-process-id evt) RT-THREAD-ID))) (define is-future-thread? (not (= (future-event-process-id evt) RT-THREAD-ID)))
@ -323,96 +368,62 @@
[else #f])) [else #f]))
(add1 nblocks) (add1 nblocks)
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) (add1 nsyncs)
nsyncs) nsyncs)
ngcs)]))) gc-evts)])))
(define tls (for/list ([proc-log-vec (in-vector data)] (define ngcs (length gcs))
[i (in-naturals)]) ;If we have any GC events, the 0th element of 'data' contains them;
(cond ;don't buid a timeline for it in the usual manner
[(= (vector-length proc-log-vec) 0) (define tls (build-timelines (if (zero? ngcs) data (vector-drop data 1))))
(process-timeline 'gc (define gc-timeline (process-timeline 'gc
0 'gc
start-time start-time
end-time end-time
'())] (for/list ([gcie (in-list gcs)]
[else [i (in-naturals)])
(let* ([fst-ie (vector-ref proc-log-vec 0)] (define gc (indexed-future-event-fevent gcie))
[fst-log-msg (indexed-future-event-fevent fst-ie)]) (event (indexed-future-event-index gcie)
(process-timeline (process-id-or-gc fst-log-msg) (event-or-gc-time gc)
i (gc-info-end-real-time gc)
(event-or-gc-time fst-log-msg) 'gc
(event-or-gc-time (indexed-future-event-fevent i
(vector-ref proc-log-vec #f
(sub1 (vector-length proc-log-vec))))) #f
(for/list ([ie (in-vector proc-log-vec)] 'gc
[j (in-naturals)]) #f
(define evt (indexed-future-event-fevent ie)) (event-pos-description i ngcs)
(define start (event-or-gc-time evt)) #f #f #f #f #f #f #f))))
(define pos (cond (define all-evts (sort (flatten (append (process-timeline-events gc-timeline)
[(zero? j) (if (= j (sub1 (vector-length proc-log-vec))) (for/list ([tl (in-list tls)]) (process-timeline-events tl))))
'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)))
#:key event-index #:key event-index
<)) <))
(define ftls (let ([h (make-hash)]) (define future-tl-hash (let ([h (make-hash)])
(for ([evt (in-list all-evts)]) (for ([evt (in-list all-evts)])
(let* ([fid (event-future-id evt)] (let* ([fid (event-future-id evt)]
[existing (hash-ref h fid '())]) [existing (hash-ref h fid '())])
(hash-set! h fid (cons evt existing)))) (hash-set! h fid (cons evt existing))))
h)) h))
(for ([fid (in-list (hash-keys ftls))]) (for ([fid (in-list (hash-keys future-tl-hash))])
(hash-set! ftls fid (reverse (hash-ref ftls fid)))) (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-values (block-hash sync-hash rtcalls-per-future-hash) (build-rtcall-hashes all-evts))
(define tr (trace start-time (define tr (trace start-time
end-time end-time
tls tls
ftls future-tl-hash
gc-timeline
all-evts all-evts
(- end-time start-time) ;real time (- end-time start-time) ;real time
(set-count unique-fids) ;num-futures (set-count unique-fids) ;num-futures
nblocks ;num-blocks nblocks ;num-blocks
nsyncs ;num-syncs nsyncs ;num-syncs
ngcs ngcs ;num-gcs
0 0
0 0
block-hash block-hash
sync-hash sync-hash
rtcalls-per-future-hash ;hash of fid -> rtcall-info rtcalls-per-future-hash ;hash of fid -> rtcall-info
(build-creation-graph ftls))) (build-creation-graph future-tl-hash)))
(connect-event-chains! tr) (connect-event-chains! tr)
(connect-target-fid-events! tr) (connect-target-fid-events! tr)
tr) tr)
@ -447,26 +458,26 @@
(define (connect-event-chains! trace) (define (connect-event-chains! trace)
(for ([tl (in-list (trace-proc-timelines trace))]) (for ([tl (in-list (trace-proc-timelines trace))])
(let loop ([evts (process-timeline-events tl)]) (let loop ([evts (process-timeline-events tl)])
(if (or (empty? evts) (empty? (cdr evts))) (if (or (null? evts) (null? (cdr evts)))
void void
(begin (begin
(set-event-prev-proc-event! (first (cdr evts)) (car evts)) (set-event-prev-proc-event! (car (cdr evts)) (car evts))
(set-event-next-proc-event! (car evts) (first (cdr evts))) (set-event-next-proc-event! (car evts) (car (cdr evts)))
(loop (cdr evts)))))) (loop (cdr evts))))))
(for ([fid (in-list (hash-keys (trace-future-timelines trace)))]) (for ([fid (in-list (hash-keys (trace-future-timelines trace)))])
(let ([events (hash-ref (trace-future-timelines trace) fid)]) (let ([events (hash-ref (trace-future-timelines trace) fid)])
(let loop ([evts events]) (let loop ([evts events])
(if (or (empty? evts) (empty? (cdr evts))) (if (or (null? evts) (null? (cdr evts)))
void void
(begin (begin
(set-event-prev-future-event! (first (cdr evts)) (car evts)) (set-event-prev-future-event! (car (cdr evts)) (car evts))
(set-event-next-future-event! (car evts) (first (cdr evts))) (set-event-next-future-event! (car evts) (car (cdr evts)))
(loop (cdr evts)))))))) (loop (cdr evts))))))))
;;connect-target-fid-events! : trace -> void ;;connect-target-fid-events! : trace -> void
(define (connect-target-fid-events! trace) (define (connect-target-fid-events! trace)
(let loop ([rest (trace-all-events trace)]) (let loop ([rest (trace-all-events trace)])
(unless (empty? rest) (unless (null? rest)
(let ([cur-evt (car rest)]) (let ([cur-evt (car rest)])
(when (and (or (equal? (event-type cur-evt) 'create) (when (and (or (equal? (event-type cur-evt) 'create)
(equal? (event-type cur-evt) 'touch)) (equal? (event-type cur-evt) 'touch))

48
collects/future-visualizer/private/visualizer-drawing.rkt
View File

@ -152,17 +152,15 @@
x))) x)))
(- (- w (- max-x-extent w)) MIN-SEG-WIDTH)) (- (- w (- max-x-extent w)) MIN-SEG-WIDTH))
;;calc-row-mid-y : uint (or uint symbol) uint uint -> uint ;;calc-row-mid-y : uint uint trace -> uint
(define (calc-row-mid-y proc-index proc-id row-height num-tls) (define (calc-row-mid-y proc-index row-height tr)
(define PADDING 2) (define PADDING 2)
;GC events span the entire height of the execution timeline (floor (- (+ (* (if (> (trace-num-gcs tr) 0)
(cond (- proc-index 1)
[(symbol? proc-id) 0] proc-index)
[else row-height)
(floor (- (+ (* (- proc-index 1) (/ row-height 2))
row-height) PADDING)))
(/ row-height 2))
PADDING))]))
;Gets the center of a circle with (xleft, ytop) as the top-left coordinate. ;Gets the center of a circle with (xleft, ytop) as the top-left coordinate.
;;calc-center : uint uint uint -> (values uint uint) ;;calc-center : uint uint uint -> (values uint uint)
@ -351,7 +349,6 @@
(define last-right-edge (if is-gc-evt? (define last-right-edge (if is-gc-evt?
largest-x largest-x
(vector-ref last-right-edges (event-proc-index evt)))) (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 (define wanted-offset (+ delta (* DEFAULT-TIMELINE-WIDTH
(inexact->exact (inexact->exact
(/ (- (event-start-time evt) (trace-start-time tr)) (/ (- (event-start-time evt) (trace-start-time tr))
@ -367,7 +364,7 @@
[else MIN-SEG-WIDTH])) [else MIN-SEG-WIDTH]))
(define seg (segment evt (define seg (segment evt
(round offset) (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 segw
segh segh
(get-event-color (event-type evt)) (get-event-color (event-type evt))
@ -451,17 +448,13 @@
0 0
0 0
(for/fold ([pct base]) ([tl (in-list (filter (λ (tline) (for/fold ([pct base]) ([tl (in-list (filter (λ (tline)
(cond (define midy (calc-row-mid-y (process-timeline-proc-index tline)
[(equal? (process-timeline-proc-id tline) 'gc) #f] (frame-info-row-height finfo)
[else tr))
(define midy (calc-row-mid-y (process-timeline-proc-index tline) (define topy (- midy (frame-info-row-height finfo)))
(process-timeline-proc-id tline) (define boty (+ midy (frame-info-row-height finfo)))
(frame-info-row-height finfo) (or (in-viewable-region-vert? vregion topy)
num-tls)) (in-viewable-region-vert? vregion boty)))
(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)))]) (trace-proc-timelines tr)))])
(let* ([line-coords (list-ref (frame-info-process-line-coords finfo) (let* ([line-coords (list-ref (frame-info-process-line-coords finfo)
(process-timeline-proc-index tl))] (process-timeline-proc-index tl))]
@ -480,7 +473,7 @@
(- line-end vregion-start)] (- line-end vregion-start)]
[else vregion-end])] [else vregion-end])]
[index (process-timeline-proc-index tl)] [index (process-timeline-proc-index tl)]
[proc-name (if (= 1 index) [proc-name (if (zero? index)
"Thread 0 (Runtime Thread)" "Thread 0 (Runtime Thread)"
(format "Thread ~a" (process-timeline-proc-id tl)))] (format "Thread ~a" (process-timeline-proc-id tl)))]
[proc-title (text-block-pict proc-name [proc-title (text-block-pict proc-name
@ -494,15 +487,14 @@
(- (* index (frame-info-row-height finfo)) (viewable-region-y vregion)) (- (* index (frame-info-row-height finfo)) (viewable-region-y vregion))
(colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color))) (colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color)))
(at 0 (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))) (- (frame-info-row-height finfo) (pict-height proc-title)))
1) 1)
proc-title) proc-title)
(at start-x (at start-x
(- (calc-row-mid-y index (- (calc-row-mid-y index
(process-timeline-proc-id tl)
(frame-info-row-height finfo) (frame-info-row-height finfo)
num-tls) tr)
(viewable-region-y vregion)) (viewable-region-y vregion))
(colorize (hline (- end-x start-x) 1) (colorize (hline (- end-x start-x) 1)
(timeline-event-baseline-color)))))))) (timeline-event-baseline-color))))))))

16
collects/future-visualizer/private/visualizer-gui.rkt
View File

@ -22,10 +22,9 @@
[(equal? (process-timeline-proc-id tl) 'gc) [(equal? (process-timeline-proc-id tl) 'gc)
(values 0 (frame-info-adjusted-height frameinfo))] (values 0 (frame-info-adjusted-height frameinfo))]
[else [else
(define midy (calc-row-mid-y (process-timeline-proc-index tl) (define midy (calc-row-mid-y (process-timeline-proc-index tl)
(process-timeline-proc-id tl)
(frame-info-row-height frameinfo) (frame-info-row-height frameinfo)
(length (trace-proc-timelines tr)))) tr))
(values (floor (- midy (/ MIN-SEG-WIDTH 2))) (values (floor (- midy (/ MIN-SEG-WIDTH 2)))
(floor (+ midy (/ MIN-SEG-WIDTH 2))))])) (floor (+ midy (/ MIN-SEG-WIDTH 2))))]))
(interval-map-set! ym (interval-map-set! ym
@ -98,10 +97,19 @@
(values (min screen-w DEF-WINDOW-WIDTH) (values (min screen-w DEF-WINDOW-WIDTH)
(min screen-h DEF-WINDOW-HEIGHT))) (min screen-h DEF-WINDOW-HEIGHT)))
(define COMFORTABLE-TL-LEN 10000)
(define (show-visualizer #:timeline [timeline #f]) (define (show-visualizer #:timeline [timeline #f])
(define the-tl (if timeline timeline (timeline-events))) (define the-tl (if timeline timeline (timeline-events)))
(printf "trace length: ~a\n" (length the-tl))
(when (empty? the-tl) (when (empty? the-tl)
(error 'show-visualizer "No future log messages found.")) (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 the-trace (build-trace the-tl))
(define-values (winw winh) (get-window-size)) (define-values (winw winh) (get-window-size))
;The event segment we are currently mousing over ;The event segment we are currently mousing over

2
collects/tests/future/visualizer.rkt
View File

@ -52,7 +52,7 @@
(check-equal? (length in-vr) 5)) (check-equal? (length in-vr) 5))
;Trace compilation tests ;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 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 2 (future-event 0 1 'end-work 2 #f #f))
(indexed-future-event 3 (future-event 0 0 'complete 3 #f #f)))] (indexed-future-event 3 (future-event 0 0 'complete 3 #f #f)))]