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

Fix block/sync counts in future visualizer and per-future block counts in creation graph mouseover

Browse Source
This commit is contained in:
James Swaine 2012-07-22 19:52:13 -05:00
parent 1355c711a8
commit 087ec3890c
4 changed files with 56 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/future-visualizer/private/pict-canvas.rkt
View File

@ -42,7 +42,11 @@
(when (or (not cached-base-bitmap) (not only-the-overlay?))
(set! cached-base-bitmap (pict->bitmap (scale (bp vregion) scale-factor))))
(when ob
(set! cached-overlay-bitmap (pict->bitmap (ob vregion scale-factor)))))
(define overlay-pict (ob vregion scale-factor))
(set! cached-overlay-bitmap
(if overlay-pict
(pict->bitmap overlay-pict)
#f))))
;Rebuilds the pict and stashes in a bitmap
;to be drawn to the canvas later

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

@ -148,10 +148,22 @@
[(block sync) #t]
[else #f]))
;;runtime-thread-evt? : (or event indexed-future-event future-event) -> bool
(define (runtime-thread-evt? evt)
(= (process-id evt) RT-THREAD-ID))
;;runtime-synchronization-event? : (or event indexed-future-event future-event) -> bool
(define (runtime-synchronization-event? evt)
(and (synchronization-event? evt) (= (process-id evt) RT-THREAD-ID)))
;;runtime-block-evt? : (or event indexed-future-event future-event) -> bool
(define (runtime-block-evt? evt)
(and (runtime-thread-evt? evt) (equal? (what evt) 'block)))
;;runtime-sync-evt? : (or event indexed-future-event future-event) -> bool
(define (runtime-sync-evt? evt)
(and (runtime-thread-evt? evt) (equal? (what evt) 'sync)))
;;final-event? : event -> bool
(define (final-event? evt)
(case (event-timeline-position evt)
@ -311,18 +323,13 @@
(define block-hash (make-hash))
(define sync-hash (make-hash))
(define rt-hash (make-hash))
(for ([evt (in-list (filter (λ (e) (and (= (event-proc-id e) RT-THREAD-ID)
(or (equal? (event-type e) 'block)
(equal? (event-type e) 'sync))))
evts))])
(define isblock (case (event-type evt)
[(block) #t]
[else #f]))
(for ([evt (in-list (filter runtime-synchronization-event? evts))])
(define isblock (runtime-block-evt? evt))
(define ophash (if isblock block-hash sync-hash))
(hash-update! ophash
(event-prim-name evt)
(λ (old) (add1 old))
1)
(λ (old) (+ old 1))
0)
(hash-update! rt-hash
(event-future-id evt)
(λ (old)
@ -331,19 +338,10 @@
(rtcall-info-sync-hash old))])
(hash-update! h
(event-prim-name evt)
(λ (o) (add1 o))
(λ () 1)))
old)
(λ ()
(let* ([ri (rtcall-info (event-future-id evt) (make-hash) (make-hash))]
[h (if isblock
(rtcall-info-block-hash ri)
(rtcall-info-sync-hash ri))])
(hash-update! h
(event-prim-name evt)
(λ (o) (add1 o))
(λ () 1))
ri))))
(λ (o) (+ o 1))
0))
old)
(rtcall-info (event-future-id evt) (make-hash) (make-hash))))
(values block-hash sync-hash rt-hash))
;;connect-event-chains! : trace -> void

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

@ -777,11 +777,16 @@
;;graph-overlay-pict : drawable-node trace graph-layout -> pict
(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))))
(define ri (hash-ref (trace-future-rtcalls tr) fid (λ () #f)))
(when ri
(define (root-sym-or-first-evt n) (node-data (drawable-node-node n)))
(cond
[(or (not hover-node) (equal? (root-sym-or-first-evt hover-node) 'runtime-thread))
#f]
[else
(define fid (event-user-data (root-sym-or-first-evt hover-node)))
(define ri (hash-ref (trace-future-rtcalls tr) fid #f))
(cond
[(not ri) #f]
[else
(define block-ops (sort (hash-keys (rtcall-info-block-hash ri))
>
#:key (λ (p)
@ -831,5 +836,5 @@
TOOLTIP-MARGIN
txtp))
(+ yacc (pict-height txtbg) CREATE-GRAPH-PADDING))))
pct))))
pct])]))

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

@ -106,14 +106,12 @@
[parent (send f get-area-container)]))
(define left-panel (new panel:horizontal-dragable% [parent main-panel]
[stretchable-width #t]
[min-width 0]))
[stretchable-width #t]))
(define hlist-ctl (new hierarchical-list%
[parent left-panel]
[stretchable-width #t]
[stretchable-height #t]
[style '(control-border)]
[min-width 0]))
[style '(control-border)]))
;Build up items in the hierlist
(define block-node (send hlist-ctl new-list))
@ -193,22 +191,30 @@
[pict-builder (λ (vregion)
(draw-creategraph-pict vregion
creation-tree-layout))]
#;[hover-handler #f (λ (x y vregion)
[hover-handler (λ (x y vregion)
(define hovered (find-node-for-coords x y
(graph-layout-nodes creation-tree-layout)))
(cond
[(eq? hovered hovered-graph-node) #f]
[else
(set! hovered-graph-node
(find-node-for-coords x
y
(graph-layout-nodes creation-tree-layout))))]
[click-handler (λ (x y vregion)
(graph-layout-nodes creation-tree-layout)))
hovered-graph-node]))]
#;[click-handler (λ (x y vregion)
(define fid (find-fid-for-coords
x y (graph-layout-nodes creation-tree-layout)
vregion))
(when fid
(define seg (first-seg-for-fid fid segments))
(set! tacked-seg seg)
(send timeline-panel set-redraw-overlay! #t)
(send timeline-panel refresh)
(post-event listener-table 'segment-click timeline-panel seg)))]
#;[overlay-builder (λ (vregion scale-factor)
(cond
[(not fid) #f]
[else
(define seg (first-seg-for-fid fid segments))
(set! tacked-seg seg)
(send timeline-panel redraw-everything)
(post-event listener-table 'segment-click timeline-panel seg)
#t]))]
[overlay-builder (λ (vregion scale-factor)
(graph-overlay-pict hovered-graph-node
the-trace
creation-tree-layout