From 7972adc97a2928cddcd814355736f401e632bdfb Mon Sep 17 00:00:00 2001 From: Burke Fetscher Date: Thu, 31 May 2012 12:00:20 -0500 Subject: [PATCH] Futures visualizer - Various bug fixes --- .../racket/future/private/gui-helpers.rkt | 24 ++- .../racket/future/private/visualizer-data.rkt | 14 +- .../future/private/visualizer-drawing.rkt | 192 ++++++++++-------- .../racket/future/private/visualizer-gui.rkt | 18 +- collects/tests/future/visualizer.rkt | 69 +++++-- 5 files changed, 190 insertions(+), 127 deletions(-) diff --git a/collects/racket/future/private/gui-helpers.rkt b/collects/racket/future/private/gui-helpers.rkt index 0214ed1f7e..d8a0e2736a 100644 --- a/collects/racket/future/private/gui-helpers.rkt +++ b/collects/racket/future/private/gui-helpers.rkt @@ -25,7 +25,8 @@ (define draw-on-resize redraw-on-resize) (define do-logging #f) (define redraw-overlay #f) ;Whether we should redraw the overlay pict in the canvas - (define redo-bitmap-on-paint #f) + (define redo-bitmap-on-paint #t) ;Redraw the base bitmap on paint? #f for mouse events + (define scale-factor 1) (define/public (set-redo-bitmap-on-paint! v) (set! redo-bitmap-on-paint v)) @@ -53,6 +54,9 @@ (define/public (set-redraw-overlay! b) (set! redraw-overlay b)) + (define/public (set-scale-factor! s) + (set! scale-factor s)) + (define the-drawer #f) (define img-width 0) (define bm #f) @@ -61,11 +65,11 @@ (define/private (get-viewable-region) (define-values (x y) (get-view-start)) (define-values (w h) (get-client-size)) - (viewable-region x y w h)) + (scale-viewable-region (viewable-region x y w h) (/ 1 scale-factor))) (define/private (overlay-drawer dc vregion) (when ob - (define p (ob vregion)) + (define p (ob vregion scale-factor)) (unless (or (not p) (void? p)) (draw-pict p dc @@ -74,7 +78,7 @@ (define/private (redo-bitmap vregion) (when bp - (define p (bp vregion)) + (define p (scale (bp vregion) scale-factor)) (set! bm (pict->bitmap p)))) (define/public (redraw-everything) @@ -92,6 +96,8 @@ (define vregion (get-viewable-region)) (when (or redo-bitmap-on-paint (not bm)) (redo-bitmap vregion)) + (unless redo-bitmap-on-paint + (set! redo-bitmap-on-paint #t)) (when bm (let ([dc (get-dc)]) (send dc draw-bitmap @@ -102,12 +108,14 @@ (define/override (on-event event) (define vregion (get-viewable-region)) - (define x (+ (viewable-region-x vregion) (send event get-x))) - (define y (+ (viewable-region-y vregion) (send event get-y))) + (define x (+ (viewable-region-x vregion) (/ (send event get-x) scale-factor))) + (define y (+ (viewable-region-y vregion) (/ (send event get-y) scale-factor))) (case (send event get-event-type) - [(motion) + [(motion) + (set! redo-bitmap-on-paint #f) (when mh (mh x y vregion))] - [(left-up) + [(left-up) + (set! redo-bitmap-on-paint #f) (when ch (ch x y vregion))]) (when redraw-overlay (refresh))) diff --git a/collects/racket/future/private/visualizer-data.rkt b/collects/racket/future/private/visualizer-data.rkt index db0e056723..6173815100 100644 --- a/collects/racket/future/private/visualizer-data.rkt +++ b/collects/racket/future/private/visualizer-data.rkt @@ -243,7 +243,7 @@ h)) (for ([fid (in-list (hash-keys ftls))]) (hash-set! ftls fid (reverse (hash-ref ftls fid)))) - (define-values (block-hash sync-hash rt-hash) (build-rtcall-hash all-evts)) + (define-values (block-hash sync-hash rtcalls-per-future-hash) (build-rtcall-hashes all-evts)) (define tr (trace start-time end-time tls @@ -257,14 +257,14 @@ 0 block-hash sync-hash - rt-hash ;hash of fid -> rtcall-info + rtcalls-per-future-hash ;hash of fid -> rtcall-info (build-creation-graph ftls))) (connect-event-chains! tr) (connect-target-fid-events! tr) tr) -;;build-rtcall-hash : (listof event) -> (values (blocking_prim --o--> count) (sync_prim --o--> count) (fid --o--> rtcall-info) -(define (build-rtcall-hash evts) +;;build-rtcall-hash : (listof event) -> (values (blocking_prim -o-> count) (sync_prim -o-> count) (fid -o-> rtcall-info) +(define (build-rtcall-hashes evts) (define block-hash (make-hash)) (define sync-hash (make-hash)) (define rt-hash (make-hash)) @@ -272,7 +272,6 @@ (or (equal? (event-type e) 'block) (equal? (event-type e) 'sync)))) evts))]) - ;(printf "event: ~a\n" evt) (define isblock (case (event-type evt) [(block) #t] [else #f])) @@ -280,7 +279,7 @@ (hash-update! ophash (event-prim-name evt) (λ (old) (add1 old)) - (λ () 1)) + 1) (hash-update! rt-hash (event-future-id evt) (λ (old) @@ -302,7 +301,6 @@ (λ (o) (add1 o)) (λ () 1)) ri)))) - ; (printf "blocks: ~a\n syncs: ~a\n rts: ~a\n" block-hash sync-hash rt-hash) (values block-hash sync-hash rt-hash)) @@ -334,7 +332,7 @@ (let ([cur-evt (car rest)]) (when (and (or (equal? (event-type cur-evt) 'create) (equal? (event-type cur-evt) 'touch)) - (not (zero? (event-user-data cur-evt)))) + (>= (event-user-data cur-evt) 0)) (let ([targ-evt (findf (λ (e) (and (event-future-id e) (= (event-future-id e) (event-user-data cur-evt)))) diff --git a/collects/racket/future/private/visualizer-drawing.rkt b/collects/racket/future/private/visualizer-drawing.rkt index f73fae56c9..0617a942f2 100644 --- a/collects/racket/future/private/visualizer-drawing.rkt +++ b/collects/racket/future/private/visualizer-drawing.rkt @@ -23,7 +23,8 @@ build-timeline-overlay build-timeline-with-overlay build-timeline-bmp-with-overlay - build-creategraph-pict + draw-creategraph-pict + zoom-level->factor graph-overlay-pict (struct-out segment) (struct-out frame-info) @@ -170,21 +171,32 @@ (segment-x seg) (+ (segment-x seg) (segment-width seg)))) +(define (find-most-recent-and-next segs time) + (let loop ([ss segs]) + (cond + [(empty? (cddr ss)) + (values (first ss) (second ss) ss)] + [(> (event-start-time (segment-event (second ss))) time) + (values (first ss) (second ss) ss)] + [else + (loop (cdr ss))]))) + ;;calc-ticks : (listof segment) float trace -> (listof timeline-tick) (define (calc-ticks segs timeToPixMod tr) (define trace-start (inexact->exact (trace-start-time tr))) (define segs-len (length segs)) - (define-values (lt lx tks) + (define-values (lt lx tks _) (for/fold ([last-time trace-start] [last-x 0] - [ticks '()]) ([i (in-range 0 (floor (/ (- (trace-end-time tr) + [ticks '()] + [remain-segs segs]) ([i (in-range 0 (floor (/ (- (trace-end-time tr) trace-start) DEFAULT-TIME-INTERVAL)))]) (define tick-time (+ last-time DEFAULT-TIME-INTERVAL)) (define tick-rel-time (* (add1 i) DEFAULT-TIME-INTERVAL)) (define want-x (+ last-x (* DEFAULT-TIME-INTERVAL timeToPixMod))) - (define next-seg (findf (λ (s) (> (event-start-time (segment-event s)) tick-time)) segs)) - (define most-recent-seg (list-ref segs (sub1 (event-index (segment-event next-seg))))) + (define-values (most-recent-seg next-seg r-segs) + (find-most-recent-and-next remain-segs tick-time)) (define most-recent-evt (segment-event most-recent-seg)) (define most-recent-time (inexact->exact (event-start-time most-recent-evt))) (define next-evt (segment-event next-seg)) @@ -195,7 +207,8 @@ [(= most-recent-time tick-time) (values tick-time (segment-x most-recent-seg) - (cons (timeline-tick (segment-x most-recent-seg) tick-time tick-rel-time) ticks))] + (cons (timeline-tick (segment-x most-recent-seg) tick-time tick-rel-time) ticks) + r-segs)] [(= (segment-x next-seg) (add1 (+ (segment-x most-recent-seg) (segment-width most-recent-seg)))) (values tick-time (+ (segment-x most-recent-seg) (segment-width most-recent-seg)) @@ -203,7 +216,8 @@ (segment-width most-recent-seg)) tick-time tick-rel-time) - ticks))] + ticks) + r-segs)] [else (define start-x (max most-recent-edge last-x)) (define start-time (max most-recent-time last-time)) @@ -212,7 +226,8 @@ (define tick-x (round (+ start-x x-offset))) (values tick-time tick-x - (cons (timeline-tick tick-x tick-time tick-rel-time) ticks))]))) + (cons (timeline-tick tick-x tick-time tick-rel-time) ticks) + r-segs)]))) tks) ;;calc-process-timespan-lines : trace (listof segment) -> (listof (uint . uint)) @@ -232,14 +247,27 @@ cur))) ;;get-first-future-seg-in-region : viewable-region segment -> segment -(define (get-first-future-seg-in-region vregion seg) - (let loop ([cur seg]) - (let ([prev (segment-prev-future-seg cur)]) - (if (not prev) - cur - (if (not ((seg-in-vregion vregion) prev)) - cur - (loop prev)))))) +(define (get-first-future-seg-in-region vregion seg) + (define prev-seg (get-seg-previous-to-vregion vregion seg)) + (if ((seg-in-vregion vregion) prev-seg) + prev-seg + (segment-next-future-seg prev-seg))) + +;; get-seg-previous-to-vregion : viewable-region segment -> segment +(define (get-seg-previous-to-vregion vregion seg) + (define first-seg + (let loop ([cur seg]) + (define prev (segment-prev-future-seg cur)) + (if (not prev) + cur + (loop prev)))) + (let loop ([cur first-seg]) + (define next (segment-next-future-seg cur)) + (if (or (not next) + (> (segment-x next) (viewable-region-x vregion))) + cur + (loop next)))) + ;;adjust-work-segs! : (listof segment) -> void (define (adjust-work-segs! segs) @@ -294,13 +322,6 @@ (values last-right-edge (+ delta (- last-right-edge wanted-offset))))) (define radius (/ MIN-SEG-WIDTH 2)) (define segw MIN-SEG-WIDTH) - #;(define segw (case (event-type evt) - [(start-work start-0-work) - (max MIN-SEG-WIDTH - (inexact->exact - (round (* timeToPixModifier - (- (event-end-time evt) (event-start-time evt))))))] - [else MIN-SEG-WIDTH])) (define seg (segment evt (round offset) (- (calc-row-mid-y (event-proc-index evt) TIMELINE-ROW-HEIGHT) radius) @@ -341,7 +362,7 @@ ;;pict-for-segment : segment -> pict (define (pict-for-segment seg) - (when (not (segment-p seg)) + (unless (segment-p seg) (set-segment-p! seg (if (event-has-duration? (segment-event seg)) (rect-pict (segment-color seg) (timeline-event-strokecolor) @@ -454,8 +475,8 @@ ;;make-stand-out-pict : segment -> pict (define (make-stand-out-pict seg) (case (event-type (segment-event seg)) - [(start-work start-0-work) (scale (segment-p seg) 1 2)] - [else (scale (segment-p seg) 2)])) + [(start-work start-0-work) (scale (pict-for-segment seg) 1 2)] + [else (scale (pict-for-segment seg) 2)])) ;;frame-bg : viewable-region frame-info trace -> pict (define (frame-bg vregion finfo tr) @@ -523,10 +544,11 @@ ;;draw-arrows : pict viewable-region segment -> pict (define (draw-arrows base-pct vregion seg) - (let ([fst (get-first-future-seg-in-region vregion seg)]) + (let ([fst (get-seg-previous-to-vregion vregion seg)]) + ;(printf "~s ~s\n" (event-index (segment-event fst)) (event-type (segment-event fst))) (let loop ([pct base-pct] [cur-seg fst]) - (if (not cur-seg) + (if (not cur-seg) pct (let ([next (segment-next-future-seg cur-seg)]) (let* ([next-targ (segment-next-targ-future-seg cur-seg)] @@ -557,8 +579,11 @@ (event-target-future-line-color) #:with-arrow #t #:style 'dot))]) - (loop next-targ-arr - next))))))) + (if (and next + ((seg-in-vregion vregion) next)) + (loop next-targ-arr next) + next-targ-arr))))))) + ;;timeline-bmp-from-log : (listof indexed-fevent) (or uint bool) (or uint bool) -> bitmap% (define (build-timeline-bmp-from-log logs @@ -595,12 +620,13 @@ buf) new-b))) -;;build-timeline-bmp-with-overlay : (listof indexed-fevent) uint [uint] [uint] -> bitmap% +;;build-timeline-bmp-with-overlay : (listof indexed-fevent) uint vregion [uint] [uint] -> bitmap% (define (build-timeline-bmp-with-overlay logs event-index + vregion #:max-width [max-width #f] #:max-height [max-height #f]) - (define p (build-timeline-with-overlay logs event-index)) + (define p (build-timeline-with-overlay logs event-index vregion)) (define-values (w h) (values (if max-width (min max-width (pict-width p)) (pict-width p)) (if max-height (min max-height (pict-height p)) (pict-height p)))) @@ -635,10 +661,9 @@ (build-timeline-pict-from-trace (build-trace logs) vregion)) ;;build-timeline-with-overlay : (listof indexed-fevent) uint -> pict -(define (build-timeline-with-overlay logs event-index) +(define (build-timeline-with-overlay logs event-index vregion) (define tr (build-trace logs)) - (define-values (finfo segments) (calc-segments tr)) - (define vregion (viewable-region-from-frame finfo)) + (define-values (finfo segments) (calc-segments tr)) (define timeline-p (build-timeline-pict vregion tr finfo @@ -663,7 +688,7 @@ (viewable-region-height vregion))) (define-values (seg-with-arrows showing-tacked) (if tacked (values tacked #t) (values hovered #f))) - (if (and seg-with-arrows (segment-p seg-with-arrows)) + (if seg-with-arrows (let* ([bg base] [dots (let loop ([p bg] [cur-seg (get-first-future-seg-in-region vregion seg-with-arrows)]) (if (or (not cur-seg) (not ((seg-in-vregion vregion) cur-seg))) @@ -682,22 +707,21 @@ 0 (colorize (vline 1 height) (hover-tickline-color)))] [bigger (make-stand-out-pict seg-with-arrows)] - [width-dif (/ (- (pict-width bigger) (pict-width (segment-p seg-with-arrows))) 2)] - [height-dif (/ (- (pict-height bigger) (pict-height (segment-p seg-with-arrows))) 2)] + [width-dif (/ (- (pict-width bigger) (segment-width seg-with-arrows)) 2)] + [height-dif (/ (- (pict-height bigger) (segment-height seg-with-arrows)) 2)] [magnified (pin-over line (- aseg-rel-x width-dif) (- aseg-rel-y height-dif) bigger)] [hover-magnified (if (and showing-tacked hovered - (segment-p hovered) (not (eq? hovered tacked))) (let* ([hmag (make-stand-out-pict hovered)] [hwidth-dif (/ (- (pict-width hmag) - (pict-width (segment-p hovered))) + (pict-width (pict-for-segment hovered))) 2)] [hheight-dif (/ (- (pict-height hmag) - (pict-height (segment-p hovered))) + (pict-height (pict-for-segment hovered))) 2)]) (pin-over magnified (- (- (segment-x hovered) (viewable-region-x vregion)) hwidth-dif) @@ -710,19 +734,17 @@ ;Draw a line from one node on the creation graph to another ;;line-from : drawable-node drawable-node pict viewable-region -> pict -(define (line-from start end pct vregion) - (let* ([par-center (drawable-node-center start)] - [child-center (drawable-node-center end)] - [minx (viewable-region-x vregion)] - [miny (viewable-region-y vregion)]) - (draw-line-onto pct - (- (point-x par-center) minx) - (- (point-y par-center) miny) - (- (point-x child-center) minx) - (- (point-y child-center) miny) - (create-graph-edge-color) - #:width 1 - #:style 'dot))) +(define (line-from start end pct minx miny) + (define par-center (drawable-node-center start)) + (define child-center (drawable-node-center end)) + (draw-line-onto pct + (- (point-x par-center) minx) + (- (point-y par-center) miny) + (- (point-x child-center) minx) + (- (point-y child-center) miny) + (create-graph-edge-color) + #:width 1 + #:style 'dot)) ;Draws a circle for a node on the creation graph ;;node-pict : drawable-node -> pict @@ -739,40 +761,44 @@ ;Cache the creation graph pict after first drawing (define cg-pict #f) -;;draw-creategraph-pict : viewable-region tree-layout -> pict +;;draw-creategraph-pict : (or/c viewable-region #f) tree-layout -> pict +;; if vregion is #f, return a pict that includes the entire tree (define (draw-creategraph-pict vregion layout) (define rt-root (first (graph-layout-nodes layout))) (define width (inexact->exact (floor (graph-layout-width layout)))) (define height (inexact->exact (floor (graph-layout-height layout)))) - (define base (blank (viewable-region-width vregion) (viewable-region-height vregion))) - (define viewable-nodes (filter (λ (n) (in-viewable-region vregion - (drawable-node-x n) - (drawable-node-y n) - (drawable-node-width n) - (drawable-node-width n))) - (graph-layout-nodes layout))) - (let ([arrow-pct (for/fold ([pct base]) ([node (in-list (graph-layout-nodes layout))]) - (for/fold ([p pct]) ([child (in-list (drawable-node-children node))]) - (line-from node child p vregion)))]) - (for/fold ([pct arrow-pct]) ([node (in-list viewable-nodes)]) - (pin-over pct - (- (drawable-node-x node) (viewable-region-x vregion)) - (- (drawable-node-y node) (viewable-region-y vregion)) - (node-pict node))))) - -;Draws the pict displayed in the creation graph canvas -;;creategraph-p : viewable-region tree-layout uint -> pict -(define (build-creategraph-pict vregion layout zoom-level) - (define factor (zoom-level->factor zoom-level)) - (set! cg-pict (draw-creategraph-pict (scale-viewable-region vregion (/ 1 factor)) layout)) - (scale cg-pict factor)) + (define base (if vregion + (blank (viewable-region-width vregion) (viewable-region-height vregion)) + (blank))) + (define minx (if vregion (viewable-region-x vregion) 0)) + (define miny (if vregion (viewable-region-y vregion) 0)) + (define viewable-nodes (if vregion + (filter (λ (n) (in-viewable-region vregion + (drawable-node-x n) + (drawable-node-y n) + (drawable-node-width n) + (drawable-node-width n))) + (graph-layout-nodes layout)) + (graph-layout-nodes layout))) + (define with-arrows + (let ([arrow-pct (for/fold ([pct base]) ([node (in-list (graph-layout-nodes layout))]) + (for/fold ([p pct]) ([child (in-list (drawable-node-children node))]) + (line-from node child p minx miny)))]) + (for/fold ([pct arrow-pct]) ([node (in-list viewable-nodes)]) + (pin-over pct + (- (drawable-node-x node) minx) + (- (drawable-node-y node) miny) + (node-pict node))))) + (if vregion + with-arrows + (panorama with-arrows))) (define (zoom-level->factor zoom-level) (+ 1.0 (* (- zoom-level CREATE-GRAPH-DEFAULT-ZOOM) CREATE-GRAPH-ZOOM-FACTOR))) ;;graph-overlay-pict : drawable-node trace graph-layout -> pict -(define (graph-overlay-pict hover-node tr layout vregion) +(define (graph-overlay-pict hover-node tr layout vregion scale-factor) (when hover-node (unless (equal? (node-data (drawable-node-node hover-node)) 'runtime-thread) (define fid (event-user-data (node-data (drawable-node-node hover-node)))) @@ -787,17 +813,17 @@ #:key (λ (op) (hash-ref (rtcall-info-sync-hash ri) op)))) (define-values (node-origin-x node-origin-y) - (values (- (drawable-node-x hover-node) (viewable-region-x vregion)) - (- (drawable-node-y hover-node) (viewable-region-y vregion)))) + (values (* (- (drawable-node-x hover-node) (viewable-region-x vregion)) scale-factor) + (* (- (drawable-node-y hover-node) (viewable-region-y vregion)) scale-factor))) (define-values (center-x center-y) - (values (+ node-origin-x (/ (drawable-node-width hover-node) 2)) - (+ node-origin-y (/ (drawable-node-width hover-node) 2)))) + (values (+ node-origin-x (/ (* (drawable-node-width hover-node) scale-factor) 2)) + (+ node-origin-y (/ (* (drawable-node-width hover-node) scale-factor) 2)))) (define x (+ center-x CREATE-GRAPH-NODE-DIAMETER)) (define-values (pct yacc) (for/fold ([p (pin-over (blank (viewable-region-width vregion) (viewable-region-height vregion)) node-origin-x node-origin-y - (node-pict hover-node))] + (scale (node-pict hover-node) scale-factor))] [yacc node-origin-y]) ([rtcall (in-list (append (map (λ (op) (cons 'block op)) block-ops) (map (λ (op) (cons 'sync op)) sync-ops)))]) diff --git a/collects/racket/future/private/visualizer-gui.rkt b/collects/racket/future/private/visualizer-gui.rkt index 8204dd1ea0..2fad433552 100644 --- a/collects/racket/future/private/visualizer-gui.rkt +++ b/collects/racket/future/private/visualizer-gui.rkt @@ -158,7 +158,7 @@ (set! tacked-seg seg) ;(send timeline-panel set-redraw-overlay! #t) (post-event listener-table 'segment-click timeline-panel seg)))] - [overlay-builder (λ (vregion) + [overlay-builder (λ (vregion scale-factor) (build-timeline-overlay vregion tacked-seg hover-seg @@ -168,13 +168,13 @@ [min-height (inexact->exact (round (* winh .7)))] [style '(hscroll vscroll)] [stretchable-width #t])) + ;; TODO sometimes the sizes passed to the scrollbars are so big we blow up! (send timeline-panel init-auto-scrollbars (frame-info-adjusted-width frameinfo) (frame-info-adjusted-height frameinfo) 0.0 0.0) (send timeline-panel show-scrollbars #t #t) - (send timeline-panel set-redo-bitmap-on-paint! #t) ;Calculate for and create creation graph pict container (define creation-tree-layout (draw-tree (trace-creation-tree the-trace) @@ -187,9 +187,8 @@ [parent graph-container] [redraw-on-resize #f] [pict-builder (λ (vregion) - (build-creategraph-pict vregion - creation-tree-layout - cg-zoom-level))] + (draw-creategraph-pict vregion + creation-tree-layout))] [hover-handler (λ (x y vregion) (set! hovered-graph-node (find-node-for-coords x @@ -205,11 +204,12 @@ (send timeline-panel set-redraw-overlay! #t) (send timeline-panel refresh) (post-event listener-table 'segment-click timeline-panel seg)))] - [overlay-builder (λ (vregion) + [overlay-builder (λ (vregion scale-factor) (graph-overlay-pict hovered-graph-node the-trace creation-tree-layout - vregion))] + vregion + scale-factor))] [min-width 500] [min-height 500] [style '(hscroll vscroll)] @@ -221,7 +221,6 @@ (inexact->exact (floor (graph-layout-height creation-tree-layout))) 0.0 0.0) - (send creategraph-panel set-redo-bitmap-on-paint! #t) (define graph-footer (new horizontal-panel% @@ -234,8 +233,7 @@ ;;Handles a change event for the creation graph zoom slider ;;on-zoom : slider% event% -> void (define (on-zoom slider event) - (printf "slider: ~s\n" (send slider get-value)) ;;REMOVE - (set! cg-zoom-level (send slider get-value)) + (send creategraph-panel set-scale-factor! (zoom-level->factor (send slider get-value))) (send creategraph-panel redraw-everything)) (define zoom-slider (new slider% diff --git a/collects/tests/future/visualizer.rkt b/collects/tests/future/visualizer.rkt index 8741a8f24d..258c1eb2b0 100644 --- a/collects/tests/future/visualizer.rkt +++ b/collects/tests/future/visualizer.rkt @@ -118,32 +118,50 @@ (define ticks (frame-info-timeline-ticks finfo)) (check-equal? (length ticks) 11)) +(define (sanity-check-ticks ticks) + (define ticks-in-ascending-time-order (reverse ticks)) + (let loop ([cur (car ticks-in-ascending-time-order)] + [rest (cdr ticks-in-ascending-time-order)]) + (unless (null? rest) + (define next (car rest)) + (check-true (>= (timeline-tick-x next) (timeline-tick-x cur)) + (format "Tick at time ~a [x:~a] had x-coord less than previous tick: ~a [x:~a]" + (exact->inexact (timeline-tick-rel-time next)) + (timeline-tick-x next) + (exact->inexact (timeline-tick-rel-time cur)) + (timeline-tick-x cur))) + (loop next + (cdr rest))))) + +;;do-seg-check : trace segment timeline-tick (a a -> bool) string -> void +(define (do-seg-check tr seg tick op adjective) + (define evt (segment-event seg)) + (check-true (op (segment-x seg) (timeline-tick-x tick)) + (format "Event at time ~a [x:~a] (~a) should be ~a tick at time ~a [x:~a]" + (relative-time tr (event-start-time evt)) + (segment-x seg) + (event-type evt) + adjective + (exact->inexact (timeline-tick-rel-time tick)) + (timeline-tick-x tick)))) + +;;check-seg-layout : trace (listof segment) (listof timeline-tick) -> void (define (check-seg-layout tr segs ticks) - (define (do-seg-check seg tick op adjective) - (define evt (segment-event seg)) - (check-true (op (segment-x seg) (timeline-tick-x tick)) - (format "Event at time ~a [x:~a] (~a) should be ~a tick at time ~a [x:~a]" - (relative-time tr (event-start-time evt)) - (segment-x seg) - (event-type evt) - adjective - (exact->inexact (timeline-tick-rel-time tick)) - (timeline-tick-x tick)))) - (for ([seg (in-list segs)]) - (let* ([evt (segment-event seg)] - [evt-rel-time (relative-time tr (event-start-time evt))]) + (for ([seg (in-list segs)]) + (define evt-rel-time (relative-time tr (event-start-time (segment-event seg)))) (for ([tick (in-list ticks)]) - (let ([ttime (timeline-tick-rel-time tick)]) + (define ttime (timeline-tick-rel-time tick)) (cond [(< evt-rel-time ttime) - (do-seg-check seg tick <= "before")] + (do-seg-check tr seg tick <= "before")] [(= evt-rel-time ttime) - (do-seg-check seg tick = "equal to")] + (do-seg-check tr seg tick = "equal to")] [(> evt-rel-time ttime) - (do-seg-check seg tick >= "after")])))))) + (do-seg-check tr seg tick >= "after")])))) ;Test layout for 'bad' mandelbrot trace (let-values ([(tr finfo segs ticks) (compile-trace-data BAD-TRACE-1)]) + (sanity-check-ticks ticks) (check-seg-layout tr segs ticks)) (let* ([future-log (list (indexed-fevent 0 (future-event #f 0 'create 0.05 #f 42)) @@ -265,7 +283,22 @@ (let-values ([(tr finfo segs ticks) (compile-trace-data mand-first)]) (check-seg-layout tr segs ticks)) - +(define single-block-log + (list + (indexed-fevent 0 '#s(future-event #f 0 create 1339469018856.55 #f 1)) + (indexed-fevent 1 '#s(future-event 1 1 start-work 1339469018856.617 #f 0)) + (indexed-fevent 2 '#s(future-event 1 1 block 1339469018856.621 #f 0)) + (indexed-fevent 3 '#s(future-event 1 1 suspend 1339469018856.891 #f 0)) + (indexed-fevent 4 '#s(future-event 1 1 end-work 1339469018856.891 #f 0)) + (indexed-fevent 5 '#s(future-event 1 0 block 1339469019057.609 printf 0)) + (indexed-fevent 6 '#s(future-event 1 0 result 1339469019057.783 #f 0)) + (indexed-fevent 7 '#s(future-event 1 2 start-work 1339469019057.796 #f 0)) + (indexed-fevent 8 '#s(future-event 1 2 complete 1339469019057.799 #f 0)) + (indexed-fevent 9 '#s(future-event 1 2 end-work 1339469019057.801 #f 0)))) +(let ([tr (build-trace single-block-log)]) + (check-equal? (length (hash-keys (trace-block-counts tr))) 1) + (check-equal? (length (hash-keys (trace-sync-counts tr))) 0) + (check-equal? (length (hash-keys (trace-future-rtcalls tr))) 1))