From b94caa2d779d0728d65c59b9ef77c7307ddaae4a Mon Sep 17 00:00:00 2001 From: James Swaine Date: Tue, 9 Oct 2012 22:51:37 -0500 Subject: [PATCH] FV: refactoring, various layout/display fixes --- .../private/visualizer-data.rkt | 207 +++++++++--------- .../private/visualizer-drawing.rkt | 48 ++-- .../private/visualizer-gui.rkt | 16 +- collects/tests/future/visualizer.rkt | 2 +- 4 files changed, 142 insertions(+), 131 deletions(-) diff --git a/collects/future-visualizer/private/visualizer-data.rkt b/collects/future-visualizer/private/visualizer-data.rkt index 5a66cbca46..80e841d083 100644 --- a/collects/future-visualizer/private/visualizer-data.rkt +++ b/collects/future-visualizer/private/visualizer-data.rkt @@ -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" @@ -64,7 +63,8 @@ (struct trace (start-time ;Absolute start time (in process milliseconds) end-time ;Absolute end time 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) 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 (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)]) + [nsyncs 0] + [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)) diff --git a/collects/future-visualizer/private/visualizer-drawing.rkt b/collects/future-visualizer/private/visualizer-drawing.rkt index 540d83f8fd..3e47a2d589 100644 --- a/collects/future-visualizer/private/visualizer-drawing.rkt +++ b/collects/future-visualizer/private/visualizer-drawing.rkt @@ -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) + (- (calc-row-mid-y index (frame-info-row-height finfo) - num-tls) + tr) (viewable-region-y vregion)) (colorize (hline (- end-x start-x) 1) (timeline-event-baseline-color)))))))) diff --git a/collects/future-visualizer/private/visualizer-gui.rkt b/collects/future-visualizer/private/visualizer-gui.rkt index 396f7a34fe..8a66dbb089 100644 --- a/collects/future-visualizer/private/visualizer-gui.rkt +++ b/collects/future-visualizer/private/visualizer-gui.rkt @@ -22,10 +22,9 @@ [(equal? (process-timeline-proc-id tl) 'gc) (values 0 (frame-info-adjusted-height frameinfo))] [else - (define midy (calc-row-mid-y (process-timeline-proc-index tl) - (process-timeline-proc-id tl) + (define midy (calc-row-mid-y (process-timeline-proc-index 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))) + (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 diff --git a/collects/tests/future/visualizer.rkt b/collects/tests/future/visualizer.rkt index c1472a4b41..71c65aaa92 100644 --- a/collects/tests/future/visualizer.rkt +++ b/collects/tests/future/visualizer.rkt @@ -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)))]