Add futures visualizer, improvements to futures logging
This commit is contained in:
James Swaine
parent
48e154e3cb
commit
b6f71ec4be
47
collects/racket/future/private/constants.rkt
Normal file
47
collects/racket/future/private/constants.rkt
Normal file
|
|
@ -0,0 +1,47 @@
|
||||||
|
#lang racket/base
|
||||||
|
(provide DEF-WINDOW-WIDTH
|
||||||
|
DEF-WINDOW-HEIGHT
|
||||||
|
RT-THREAD-ID
|
||||||
|
MIN-SEG-WIDTH
|
||||||
|
STROKE-WIDTH
|
||||||
|
MIN-SEG-INNER-WIDTH
|
||||||
|
DEFAULT-TIME-INTERVAL
|
||||||
|
TIMELINE-HEADER-OPACITY
|
||||||
|
CONNECTION-LINE-HAT-THRESHOLD
|
||||||
|
HAT-HEIGHT
|
||||||
|
CREATE-GRAPH-NODE-DIAMETER
|
||||||
|
CREATE-GRAPH-PADDING
|
||||||
|
CREATE-GRAPH-MIN-ZOOM
|
||||||
|
CREATE-GRAPH-MAX-ZOOM
|
||||||
|
CREATE-GRAPH-DEFAULT-ZOOM
|
||||||
|
CREATE-GRAPH-ZOOM-FACTOR
|
||||||
|
TIMELINE-ROW-HEIGHT
|
||||||
|
TIMELINE-MIN-TICK-PADDING
|
||||||
|
HEADER-PADDING
|
||||||
|
DEFAULT-TIMELINE-WIDTH
|
||||||
|
HEADER-HEIGHT
|
||||||
|
TOOLTIP-MARGIN)
|
||||||
|
|
||||||
|
(define DEF-WINDOW-WIDTH 1500)
|
||||||
|
(define DEF-WINDOW-HEIGHT 1000)
|
||||||
|
(define RT-THREAD-ID 0)
|
||||||
|
(define MIN-SEG-WIDTH 10)
|
||||||
|
(define STROKE-WIDTH 2)
|
||||||
|
(define MIN-SEG-INNER-WIDTH (- MIN-SEG-WIDTH STROKE-WIDTH))
|
||||||
|
;Default time interval (in MS) between ticks on the timeline
|
||||||
|
(define DEFAULT-TIME-INTERVAL (/ 1 10))
|
||||||
|
(define TIMELINE-HEADER-OPACITY 0.6)
|
||||||
|
(define CONNECTION-LINE-HAT-THRESHOLD 20)
|
||||||
|
(define HAT-HEIGHT 9)
|
||||||
|
(define CREATE-GRAPH-NODE-DIAMETER 30)
|
||||||
|
(define CREATE-GRAPH-PADDING 5)
|
||||||
|
(define CREATE-GRAPH-MIN-ZOOM 1)
|
||||||
|
(define CREATE-GRAPH-MAX-ZOOM 5)
|
||||||
|
(define CREATE-GRAPH-DEFAULT-ZOOM 3)
|
||||||
|
(define CREATE-GRAPH-ZOOM-FACTOR .4)
|
||||||
|
(define TIMELINE-ROW-HEIGHT 100)
|
||||||
|
(define TIMELINE-MIN-TICK-PADDING 10)
|
||||||
|
(define HEADER-PADDING 5)
|
||||||
|
(define DEFAULT-TIMELINE-WIDTH 1000)
|
||||||
|
(define HEADER-HEIGHT 30)
|
||||||
|
(define TOOLTIP-MARGIN 5)
|
||||||
126
collects/racket/future/private/display.rkt
Normal file
126
collects/racket/future/private/display.rkt
Normal file
|
|
@ -0,0 +1,126 @@
|
||||||
|
#lang racket/base
|
||||||
|
(provide get-event-color
|
||||||
|
get-event-forecolor
|
||||||
|
header-forecolor
|
||||||
|
header-backcolor
|
||||||
|
timeline-event-baseline-color
|
||||||
|
event-connection-line-color
|
||||||
|
event-target-future-line-color
|
||||||
|
timeline-tick-color
|
||||||
|
timeline-tick-bold-color
|
||||||
|
timeline-tick-label-backcolor
|
||||||
|
timeline-tick-label-forecolor
|
||||||
|
timeline-baseline-color
|
||||||
|
timeline-frame-color
|
||||||
|
timeline-frame-bg-color
|
||||||
|
timeline-event-strokecolor
|
||||||
|
hover-tickline-color
|
||||||
|
create-graph-node-backcolor
|
||||||
|
create-graph-node-strokecolor
|
||||||
|
create-graph-node-forecolor
|
||||||
|
create-graph-edge-color
|
||||||
|
create-graph-block-node-forecolor
|
||||||
|
create-graph-sync-node-forecolor
|
||||||
|
get-time-string
|
||||||
|
(struct-out viewable-region)
|
||||||
|
viewable-region-x-extent
|
||||||
|
viewable-region-y-extent
|
||||||
|
in-viewable-region
|
||||||
|
in-viewable-region-horiz
|
||||||
|
scale-viewable-region
|
||||||
|
between)
|
||||||
|
|
||||||
|
(struct viewable-region (x y width height) #:transparent)
|
||||||
|
|
||||||
|
;;viewable-region-x-extent : viewable-region -> uint
|
||||||
|
(define (viewable-region-x-extent vregion)
|
||||||
|
(+ (viewable-region-x vregion) (viewable-region-width vregion)))
|
||||||
|
|
||||||
|
;;viewable-region-y-extent : viewable-region -> uint
|
||||||
|
(define (viewable-region-y-extent vregion)
|
||||||
|
(+ (viewable-region-y vregion) (viewable-region-height vregion)))
|
||||||
|
|
||||||
|
(define (scale-viewable-region vreg factor)
|
||||||
|
(define (scale n) (* n factor))
|
||||||
|
(struct-copy viewable-region vreg
|
||||||
|
[width (scale (viewable-region-width vreg))]
|
||||||
|
[height (scale (viewable-region-height vreg))]))
|
||||||
|
|
||||||
|
|
||||||
|
;;between : uint uint uint -> bool
|
||||||
|
(define (between x start end)
|
||||||
|
(and (>= x start) (<= x end)))
|
||||||
|
|
||||||
|
;;in-viewable-region : viewable-region uint -> bool
|
||||||
|
(define (in-viewable-region-horiz vregion x)
|
||||||
|
(between x (viewable-region-x vregion) (viewable-region-x-extent vregion)))
|
||||||
|
|
||||||
|
;;in-viewable-region : viewable-region segment -> bool
|
||||||
|
(define (in-viewable-region vregion x y w h)
|
||||||
|
(define-values (start-x start-y end-x end-y)
|
||||||
|
(values (viewable-region-x vregion)
|
||||||
|
(viewable-region-y vregion)
|
||||||
|
(viewable-region-x-extent vregion)
|
||||||
|
(viewable-region-y-extent vregion)))
|
||||||
|
(define-values (x-end y-end)
|
||||||
|
(values (+ x w)
|
||||||
|
(+ y h)))
|
||||||
|
(and (or (between x start-x end-x)
|
||||||
|
(between x-end start-x end-x)
|
||||||
|
(between start-x x x-end)
|
||||||
|
(between end-y y y-end))
|
||||||
|
(or (between y start-y end-y)
|
||||||
|
(between y-end start-y end-y)
|
||||||
|
(between start-y y y-end)
|
||||||
|
(between end-y y y-end))))
|
||||||
|
|
||||||
|
;;get-event-color : symbol -> string
|
||||||
|
(define (get-event-color type)
|
||||||
|
(case type
|
||||||
|
[(create) "blue"]
|
||||||
|
[(start-work start-0-work touch-resume) "green"]
|
||||||
|
[(block touch) "red"]
|
||||||
|
[(sync) "orange"]
|
||||||
|
[(touch-pause) "blue"]
|
||||||
|
[(result abort suspend) "white"]
|
||||||
|
[(complete end-work) "white"]
|
||||||
|
[else "black"]))
|
||||||
|
|
||||||
|
;;get-event-forecolor : symbol -> string
|
||||||
|
(define (get-event-forecolor type)
|
||||||
|
(case type
|
||||||
|
[(block) "white"]
|
||||||
|
[else "black"]))
|
||||||
|
|
||||||
|
(define (header-forecolor) "white")
|
||||||
|
(define (header-backcolor) "slategray")
|
||||||
|
(define (timeline-event-baseline-color) "gray")
|
||||||
|
(define (event-connection-line-color) "orchid")
|
||||||
|
(define (event-target-future-line-color) "orange")
|
||||||
|
(define (creation-line-color) "green")
|
||||||
|
(define (touch-line-color) "red")
|
||||||
|
(define (timeline-tick-color) "gray")
|
||||||
|
(define (timeline-tick-bold-color) "darkgray")
|
||||||
|
(define (timeline-tick-label-backcolor) "darkgray")
|
||||||
|
(define (timeline-tick-label-forecolor) "white")
|
||||||
|
(define (timeline-baseline-color) "darkgray")
|
||||||
|
(define (timeline-frame-color) "gray")
|
||||||
|
(define (timeline-frame-bg-color) "white")
|
||||||
|
(define (timeline-event-strokecolor) "darkgray")
|
||||||
|
(define (hover-tickline-color) "darkgray")
|
||||||
|
(define (create-graph-node-forecolor) "white")
|
||||||
|
(define (create-graph-node-backcolor) "steelblue")
|
||||||
|
(define (create-graph-node-strokecolor) "darkgray")
|
||||||
|
(define (create-graph-edge-color) "black")
|
||||||
|
(define (create-graph-block-node-forecolor) "white")
|
||||||
|
(define (create-graph-sync-node-forecolor) "white")
|
||||||
|
|
||||||
|
(define (get-time-string time)
|
||||||
|
(if (or (= 0.0 time) (> time 0.1))
|
||||||
|
(format "~a ms" time)
|
||||||
|
(format "~a μs" (* 1000 time))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
109
collects/racket/future/private/drawing-helpers.rkt
Normal file
109
collects/racket/future/private/drawing-helpers.rkt
Normal file
|
|
@ -0,0 +1,109 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require slideshow/pict
|
||||||
|
"display.rkt"
|
||||||
|
"constants.rkt")
|
||||||
|
(provide opacity-layer
|
||||||
|
circle-pict
|
||||||
|
rect-pict
|
||||||
|
text-pict
|
||||||
|
text-block-pict
|
||||||
|
draw-line-onto
|
||||||
|
make-stand-out
|
||||||
|
at
|
||||||
|
draw-stack-onto)
|
||||||
|
|
||||||
|
;;opacity-layer : float uint uint -> pict
|
||||||
|
(define (opacity-layer alpha w h)
|
||||||
|
(cellophane (colorize (filled-rectangle w h)
|
||||||
|
"white")
|
||||||
|
0.6))
|
||||||
|
|
||||||
|
;;circle-pict : string string uint [uint] -> pict
|
||||||
|
(define (circle-pict color stroke-color width #:stroke-width [stroke-width 1])
|
||||||
|
(pin-over (colorize (filled-ellipse width
|
||||||
|
width)
|
||||||
|
stroke-color)
|
||||||
|
(* stroke-width 2)
|
||||||
|
(* stroke-width 2)
|
||||||
|
(colorize (filled-ellipse (- width (* stroke-width 4))
|
||||||
|
(- width (* stroke-width 4)))
|
||||||
|
color)))
|
||||||
|
|
||||||
|
;;rect-pict : string string uint uint [uint] -> pict
|
||||||
|
(define (rect-pict color stroke-color width height #:stroke-width [stroke-width 1])
|
||||||
|
(pin-over (colorize (filled-rectangle width height)
|
||||||
|
stroke-color)
|
||||||
|
(* stroke-width 2)
|
||||||
|
(* stroke-width 2)
|
||||||
|
(colorize (filled-rectangle (- width (* stroke-width 4))
|
||||||
|
(- height (* stroke-width 4)))
|
||||||
|
color)))
|
||||||
|
|
||||||
|
;;text-pict : string [string] -> pict
|
||||||
|
(define (text-pict t #:color [color "black"])
|
||||||
|
(colorize (text t) color))
|
||||||
|
|
||||||
|
;;text-block-pict : string [string] [string] [uint] [float] [uint] [uint] -> pict
|
||||||
|
(define (text-block-pict t #:backcolor [backcolor "white"]
|
||||||
|
#:forecolor [forecolor "black"]
|
||||||
|
#:padding [padding 10]
|
||||||
|
#:opacity [opacity 1.0]
|
||||||
|
#:width [width 0]
|
||||||
|
#:height [height 0])
|
||||||
|
(let* ([textp (colorize (text t) forecolor)]
|
||||||
|
[padx2 (* padding 2)]
|
||||||
|
[text-cont (pin-over (blank (+ (pict-width textp) padx2)
|
||||||
|
(+ (pict-height textp) padx2))
|
||||||
|
padding
|
||||||
|
padding
|
||||||
|
textp)]
|
||||||
|
[bg (cellophane (colorize (filled-rectangle (max width (pict-width text-cont))
|
||||||
|
(max height (pict-height text-cont)))
|
||||||
|
backcolor)
|
||||||
|
opacity)])
|
||||||
|
(lc-superimpose bg text-cont)))
|
||||||
|
|
||||||
|
;;draw-line-onto : pict uint uint uint uint string -> pict
|
||||||
|
(define (draw-line-onto base
|
||||||
|
startx
|
||||||
|
starty
|
||||||
|
endx
|
||||||
|
endy
|
||||||
|
color
|
||||||
|
#:width [width 1]
|
||||||
|
#:with-arrow [with-arrow #f]
|
||||||
|
#:arrow-sz [arrow-sz 10]
|
||||||
|
#:style [style 'solid])
|
||||||
|
(let ([dx (- endx startx)]
|
||||||
|
[dy (- endy starty)]
|
||||||
|
[line-f (if with-arrow pip-arrow-line pip-line)])
|
||||||
|
(pin-over base
|
||||||
|
startx
|
||||||
|
starty
|
||||||
|
(linewidth width
|
||||||
|
(linestyle style
|
||||||
|
(colorize (line-f dx
|
||||||
|
dy
|
||||||
|
arrow-sz)
|
||||||
|
color))))))
|
||||||
|
|
||||||
|
;;make-stand-out : pict -> pict
|
||||||
|
(define (make-stand-out pict)
|
||||||
|
(scale pict 2))
|
||||||
|
|
||||||
|
(struct draw-at (x y p) #:transparent)
|
||||||
|
|
||||||
|
;;at : uint uint pict -> draw-at
|
||||||
|
(define (at x y p)
|
||||||
|
(draw-at x y p))
|
||||||
|
|
||||||
|
;;draw-stack-onto : pict (listof pict) -> pict
|
||||||
|
(define (draw-stack-onto base . picts)
|
||||||
|
(for/fold ([p base]) ([cur-p (in-list picts)])
|
||||||
|
(cond
|
||||||
|
[(pict? cur-p) (pin-over p 0 0 cur-p)]
|
||||||
|
[(draw-at? cur-p) (pin-over p
|
||||||
|
(draw-at-x cur-p)
|
||||||
|
(draw-at-y cur-p)
|
||||||
|
(draw-at-p cur-p))]
|
||||||
|
[else (error 'draw-onto "Invalid argument in 'picts' list.")])))
|
||||||
440
collects/racket/future/private/graph-drawing.rkt
Normal file
440
collects/racket/future/private/graph-drawing.rkt
Normal file
|
|
@ -0,0 +1,440 @@
|
||||||
|
#lang racket
|
||||||
|
(require rackunit)
|
||||||
|
(provide (struct-out point)
|
||||||
|
(struct-out node)
|
||||||
|
(struct-out drawable-node)
|
||||||
|
(struct-out graph-layout)
|
||||||
|
draw-tree
|
||||||
|
drawable-node-center)
|
||||||
|
|
||||||
|
(define DEFAULT-WIDTH 10)
|
||||||
|
(define PADDING 5)
|
||||||
|
(define-struct/contract point ([x integer?] [y integer?]) #:transparent)
|
||||||
|
(struct node (data children))
|
||||||
|
(struct graph-layout (width height nodes) #:transparent)
|
||||||
|
(struct drawable-node (node x y width depth children children-xextent children-yextent) #:transparent)
|
||||||
|
|
||||||
|
(define (int x)
|
||||||
|
(floor (exact->inexact x)))
|
||||||
|
|
||||||
|
;;Gets the center point of a node circle.
|
||||||
|
;;drawable-node-center : node -> point
|
||||||
|
(define (drawable-node-center dnode)
|
||||||
|
(point (int (+ (drawable-node-x dnode) (/ (drawable-node-width dnode) 2)))
|
||||||
|
(int (+ (drawable-node-y dnode) (/ (drawable-node-width dnode) 2)))))
|
||||||
|
|
||||||
|
;
|
||||||
|
; ;; ;;
|
||||||
|
; ;;; ; ; ; ;
|
||||||
|
; ; ;; ; ; ;
|
||||||
|
; ; ; ;;;;;;; ;;;; ;; ;;; ;;; ; ;;;; ;; ;; ;;; ;
|
||||||
|
; ; ; ; ; ;; ; ; ;; ; ; ;;; ; ;;
|
||||||
|
; ;;;; ; ; ; ; ; ; ; ; ; ;
|
||||||
|
; ; ; ;;;;;; ; ; ; ; ;;;;;; ; ; ;
|
||||||
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
|
; ;; ; ; ; ;; ; ; ; ;; ; ;; ; ; ;;
|
||||||
|
; ; ;;; ;;;; ;;;; ;; ;;; ;;; ;;; ;; ;;;; ;; ;;;;;; ;;; ;;
|
||||||
|
;
|
||||||
|
|
||||||
|
;;draw-tree/standard : node uint uint uint uint uint -> drawable-node
|
||||||
|
(define (draw-tree/standard parent x y depth node-width padding)
|
||||||
|
(if (empty? (node-children parent))
|
||||||
|
(drawable-node parent
|
||||||
|
(+ padding x)
|
||||||
|
(+ padding y)
|
||||||
|
node-width
|
||||||
|
depth
|
||||||
|
'()
|
||||||
|
(+ padding x node-width)
|
||||||
|
(+ padding y node-width))
|
||||||
|
(let ([child-y (+ y node-width)]
|
||||||
|
[children (node-children parent)]
|
||||||
|
[parenty (+ y padding)])
|
||||||
|
(if (= 1 (length children)) ;Align parent and child vertically
|
||||||
|
(let ([child (draw-tree/standard (first children)
|
||||||
|
x
|
||||||
|
(+ parenty node-width)
|
||||||
|
(add1 depth)
|
||||||
|
node-width
|
||||||
|
padding)])
|
||||||
|
(drawable-node parent
|
||||||
|
(drawable-node-x child)
|
||||||
|
parenty
|
||||||
|
node-width
|
||||||
|
depth
|
||||||
|
(list child)
|
||||||
|
(drawable-node-children-xextent child)
|
||||||
|
(drawable-node-children-yextent child)))
|
||||||
|
(let-values ([(x-extent
|
||||||
|
y-extent
|
||||||
|
children)
|
||||||
|
(for/fold ([xacc x] [yacc y] [chn '()])
|
||||||
|
([child (in-list children)])
|
||||||
|
(let ([dchild (draw-tree/standard child
|
||||||
|
xacc
|
||||||
|
(+ parenty node-width)
|
||||||
|
(add1 depth)
|
||||||
|
node-width
|
||||||
|
padding)])
|
||||||
|
(values (drawable-node-children-xextent dchild)
|
||||||
|
(drawable-node-children-yextent dchild)
|
||||||
|
(cons dchild chn))))])
|
||||||
|
(let* ([chn (reverse children)]
|
||||||
|
[xmin (drawable-node-x (first chn))]
|
||||||
|
[xmax (drawable-node-x (last chn))])
|
||||||
|
(drawable-node parent
|
||||||
|
(+ xmin (/ (- xmax xmin) 2))
|
||||||
|
parenty
|
||||||
|
node-width
|
||||||
|
depth
|
||||||
|
chn
|
||||||
|
x-extent
|
||||||
|
(+ y-extent node-width))))))))
|
||||||
|
|
||||||
|
;; ; ;;;
|
||||||
|
; ;;;;;; ; ;
|
||||||
|
; ; ;; ; ;
|
||||||
|
; ; ; ;;;; ;;; ; ;;; ;;;; ;
|
||||||
|
; ; ; ; ; ; ;; ; ; ; ;
|
||||||
|
; ; ; ; ; ; ; ; ;
|
||||||
|
; ;;;;; ;;;;;; ; ; ; ;;;;;; ;
|
||||||
|
; ; ; ; ; ; ; ; ; ; ;
|
||||||
|
; ; ; ; ; ; ; ; ; ; ;
|
||||||
|
; ; ; ; ;; ; ;; ; ; ;; ;
|
||||||
|
; ;;; ;; ;;;; ;; ;;; ;; ;;;;;; ;;;; ;; ;;;;;;
|
||||||
|
;
|
||||||
|
|
||||||
|
;(r * cos(deg), r * sin(deg)) = point on circle given angle and radius r.
|
||||||
|
|
||||||
|
(struct attributed-node (node type num-leaves depth children))
|
||||||
|
(define (leaf? anode)
|
||||||
|
(equal? (attributed-node-type anode) 'leaf))
|
||||||
|
|
||||||
|
;;build-attr-tree : node uint -> attributed-node
|
||||||
|
(define (build-attr-tree parent depth)
|
||||||
|
(if (empty? (node-children parent))
|
||||||
|
(attributed-node parent 'leaf 0 depth '())
|
||||||
|
(let-values ([(leaves achn)
|
||||||
|
(for/fold ([l 0] [achildren '()]) ([child (in-list (node-children parent))])
|
||||||
|
(let ([anode (build-attr-tree child (add1 depth))])
|
||||||
|
(if (leaf? anode)
|
||||||
|
(values (add1 l) (cons anode achildren))
|
||||||
|
(values (+ l (attributed-node-num-leaves anode)) (cons anode achildren)))))])
|
||||||
|
(attributed-node parent
|
||||||
|
'interior
|
||||||
|
leaves
|
||||||
|
depth
|
||||||
|
achn))))
|
||||||
|
|
||||||
|
|
||||||
|
;(struct drawable-node (node x y width depth children children-xextent children-yextent) #:transparent)
|
||||||
|
;;draw-tree/radial : node uint (uint -> uint) uint -> drawable-node
|
||||||
|
(define (draw-tree/radial root node-width Bv p depth)
|
||||||
|
(let* ([atree (build-attr-tree root 0)]
|
||||||
|
#;[angle-incr (/ Bv (length (attributed-node-children root)))])
|
||||||
|
(for/fold ([angle 0] [chn '()]) ([achild (in-list (attributed-node-children atree))])
|
||||||
|
(let* ([Bu (/ (* (attributed-node-num-leaves achild) Bv)
|
||||||
|
(attributed-node-num-leaves atree))]
|
||||||
|
[pa (+ angle
|
||||||
|
(/ Bu 2))]
|
||||||
|
[x (* (p depth) (cos pa))]
|
||||||
|
[y (* (p depth) (sin pa))])
|
||||||
|
(values (+ angle Bu)
|
||||||
|
(cons (drawable-node (attributed-node-node achild)
|
||||||
|
x
|
||||||
|
y
|
||||||
|
node-width
|
||||||
|
depth
|
||||||
|
'()
|
||||||
|
0
|
||||||
|
0) chn))))))
|
||||||
|
|
||||||
|
;;tree-layout/private : drawable-node uint uint (listof drawable-node) -> (values uint uint (listof drawable-node))
|
||||||
|
(define (tree-layout/private parent xextent yextent nodes)
|
||||||
|
(if (empty? (drawable-node-children parent))
|
||||||
|
(values (max (+ (drawable-node-x parent) (drawable-node-width parent)) xextent)
|
||||||
|
(max (+ (drawable-node-y parent) (drawable-node-width parent)) yextent)
|
||||||
|
(cons parent nodes))
|
||||||
|
(for/fold ([x xextent] [y yextent] [ns (cons parent nodes)]) ([child (in-list (drawable-node-children parent))])
|
||||||
|
(tree-layout/private child x y (cons child ns)))))
|
||||||
|
|
||||||
|
;;calc-tree-layout : drawable-node uint uint -> graph-layout
|
||||||
|
(define (calc-tree-layout root node-width padding)
|
||||||
|
(define-values (w h nodes) (tree-layout/private root 0 0 '()))
|
||||||
|
(graph-layout w
|
||||||
|
h
|
||||||
|
nodes))
|
||||||
|
|
||||||
|
;;draw-tree : node [symbol] [uint] [uint] [uint] -> tree-layout
|
||||||
|
(define (draw-tree root
|
||||||
|
#:style [style 'standard]
|
||||||
|
#:node-width [node-width DEFAULT-WIDTH]
|
||||||
|
#:padding [padding PADDING]
|
||||||
|
#:zoom [zoom-level 1])
|
||||||
|
(let* ([scaled-node-w (* node-width zoom-level)]
|
||||||
|
[scaled-padding (* padding zoom-level)]
|
||||||
|
[layout
|
||||||
|
(case style
|
||||||
|
[(standard) (calc-tree-layout (draw-tree/standard root
|
||||||
|
0
|
||||||
|
0
|
||||||
|
0
|
||||||
|
scaled-node-w
|
||||||
|
scaled-padding)
|
||||||
|
scaled-node-w
|
||||||
|
scaled-padding)]
|
||||||
|
[(radial) (calc-tree-layout (draw-tree/radial root
|
||||||
|
(λ (i) (* i 50)))
|
||||||
|
scaled-node-w
|
||||||
|
scaled-padding)]
|
||||||
|
[(hv) 0]
|
||||||
|
[else
|
||||||
|
(error 'draw-tree "Invalid tree drawing style.")])])
|
||||||
|
(graph-layout (+ (graph-layout-width layout) scaled-padding)
|
||||||
|
(+ (graph-layout-height layout) scaled-padding)
|
||||||
|
(graph-layout-nodes layout))))
|
||||||
|
|
||||||
|
|
||||||
|
;Tests
|
||||||
|
(let* ([nodea (drawable-node (node 'a '()) 5 5 10 0 0 '() 10)]
|
||||||
|
[center (drawable-node-center nodea)])
|
||||||
|
(check-equal? (point-x center) 10.0)
|
||||||
|
(check-equal? (point-y center) 10.0))
|
||||||
|
|
||||||
|
|
||||||
|
(define test-padding 5)
|
||||||
|
(define test-width 10)
|
||||||
|
|
||||||
|
(define (tree root-data . children)
|
||||||
|
(node root-data children))
|
||||||
|
|
||||||
|
(define (get-node data layout)
|
||||||
|
(first (filter (λ (dn) (equal? (node-data (drawable-node-node dn)) data)) (graph-layout-nodes layout))))
|
||||||
|
|
||||||
|
#|
|
||||||
|
a
|
||||||
|
|
|
||||||
|
b
|
||||||
|
|#
|
||||||
|
(define tree0 (tree 'a (tree 'b)))
|
||||||
|
(let* ([layout (draw-tree tree0 #:node-width test-width #:padding test-padding)]
|
||||||
|
[dnode-a (get-node 'a layout)]
|
||||||
|
[dnode-b (get-node 'b layout)])
|
||||||
|
(check-equal? (graph-layout-width layout) (+ (* test-padding 2) test-width))
|
||||||
|
(check-equal? (graph-layout-height layout) (+ (* test-padding 3) (* test-width 2)))
|
||||||
|
(check-equal? (drawable-node-x dnode-a) test-padding)
|
||||||
|
(check-equal? (drawable-node-y dnode-a) test-padding)
|
||||||
|
(check-equal? (drawable-node-x dnode-b) test-padding)
|
||||||
|
(check-equal? (drawable-node-y dnode-b) (+ test-padding test-width test-padding)))
|
||||||
|
(let ([atree (build-attr-tree tree0 0)])
|
||||||
|
(check-equal? (attributed-node-num-leaves atree) 1))
|
||||||
|
|
||||||
|
#|
|
||||||
|
a
|
||||||
|
/ \
|
||||||
|
b c
|
||||||
|
|#
|
||||||
|
(define tree1 (tree 'a
|
||||||
|
(tree 'b)
|
||||||
|
(tree 'c)))
|
||||||
|
(define layout (draw-tree tree1 #:node-width test-width #:padding test-padding))
|
||||||
|
(for ([dnode (in-list (graph-layout-nodes layout))])
|
||||||
|
(check-equal? (drawable-node-width dnode) test-width))
|
||||||
|
(define dnode-a (get-node 'a layout))
|
||||||
|
(define dnode-b (get-node 'b layout))
|
||||||
|
(define dnode-c (get-node 'c layout))
|
||||||
|
|
||||||
|
(define slot-one-pos (+ test-padding test-width test-padding))
|
||||||
|
(define square-sz (+ (* test-padding 3) (* test-width 2)))
|
||||||
|
(check-equal? (graph-layout-width layout) square-sz)
|
||||||
|
(check-equal? (graph-layout-height layout) square-sz)
|
||||||
|
(check-equal? (drawable-node-x dnode-b) test-padding)
|
||||||
|
(check-equal? (drawable-node-y dnode-b) slot-one-pos)
|
||||||
|
(check-equal? (drawable-node-x dnode-c) slot-one-pos)
|
||||||
|
(check-equal? (drawable-node-y dnode-c) slot-one-pos)
|
||||||
|
(check-equal? (drawable-node-x dnode-a) (/ 25 2))
|
||||||
|
(check-equal? (drawable-node-y dnode-a) test-padding)
|
||||||
|
(check-equal? (length (drawable-node-children dnode-a)) 2)
|
||||||
|
(let ([atree (build-attr-tree tree1 0)])
|
||||||
|
(check-equal? (attributed-node-num-leaves atree) 2))
|
||||||
|
|
||||||
|
#|
|
||||||
|
a
|
||||||
|
/ \
|
||||||
|
b d
|
||||||
|
| / \
|
||||||
|
c e f
|
||||||
|
|
|
||||||
|
g
|
||||||
|
|#
|
||||||
|
(define tree2 (tree 'a
|
||||||
|
(tree 'b
|
||||||
|
(tree 'c))
|
||||||
|
(tree 'd
|
||||||
|
(tree 'e)
|
||||||
|
(tree 'f
|
||||||
|
(tree 'g)))))
|
||||||
|
(let* ([layout (draw-tree tree2 #:node-width test-width #:padding test-padding)]
|
||||||
|
[nodes (graph-layout-nodes layout)]
|
||||||
|
[dnode-a (get-node 'a layout)]
|
||||||
|
[dnode-b (get-node 'b layout)]
|
||||||
|
[dnode-c (get-node 'c layout)]
|
||||||
|
[dnode-d (get-node 'd layout)]
|
||||||
|
[dnode-e (get-node 'e layout)]
|
||||||
|
[dnode-f (get-node 'f layout)]
|
||||||
|
[dnode-g (get-node 'g layout)])
|
||||||
|
(check-equal? (node-data (drawable-node-node dnode-a)) 'a)
|
||||||
|
(check-equal? (node-data (drawable-node-node dnode-b)) 'b)
|
||||||
|
(check-equal? (node-data (drawable-node-node dnode-c)) 'c)
|
||||||
|
(check-equal? (node-data (drawable-node-node dnode-d)) 'd)
|
||||||
|
(check-equal? (node-data (drawable-node-node dnode-e)) 'e)
|
||||||
|
(check-equal? (node-data (drawable-node-node dnode-f)) 'f)
|
||||||
|
(check-equal? (node-data (drawable-node-node dnode-g)) 'g)
|
||||||
|
(check-equal? (graph-layout-width layout) 50)
|
||||||
|
(check-equal? (graph-layout-height layout) 65)
|
||||||
|
(check-equal? (drawable-node-x dnode-a) (/ 65 4))
|
||||||
|
(check-equal? (drawable-node-y dnode-a) test-padding)
|
||||||
|
(check-equal? (drawable-node-x dnode-b) test-padding)
|
||||||
|
(check-equal? (drawable-node-y dnode-b) (+ (* 2 test-padding) test-width))
|
||||||
|
(check-equal? (drawable-node-x dnode-c) test-padding)
|
||||||
|
(check-equal? (drawable-node-y dnode-c) (+ (drawable-node-y dnode-b) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-x dnode-e) (+ (* 2 test-padding) test-width))
|
||||||
|
(check-equal? (drawable-node-y dnode-e) (+ (drawable-node-y dnode-d) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-x dnode-f) (+ (drawable-node-x dnode-e) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-y dnode-f) (drawable-node-y dnode-e))
|
||||||
|
(check-equal? (drawable-node-x dnode-g) (drawable-node-x dnode-f))
|
||||||
|
(check-equal? (drawable-node-y dnode-g) (+ (drawable-node-y dnode-f) test-width test-padding)))
|
||||||
|
(let ([atree (build-attr-tree tree2 0)])
|
||||||
|
(check-equal? (attributed-node-num-leaves atree) 3))
|
||||||
|
|
||||||
|
#|
|
||||||
|
a
|
||||||
|
/|\
|
||||||
|
b c e
|
||||||
|
|
|
||||||
|
d
|
||||||
|
|#
|
||||||
|
(define tree3 (tree 'a
|
||||||
|
(tree 'b)
|
||||||
|
(tree 'c
|
||||||
|
(tree 'd))
|
||||||
|
(tree 'e)))
|
||||||
|
(let* ([layout (draw-tree tree3 #:node-width test-width #:padding test-padding)]
|
||||||
|
[nodes (graph-layout-nodes layout)]
|
||||||
|
[dnode-a (get-node 'a layout)]
|
||||||
|
[dnode-b (get-node 'b layout)]
|
||||||
|
[dnode-c (get-node 'c layout)]
|
||||||
|
[dnode-d (get-node 'd layout)]
|
||||||
|
[dnode-e (get-node 'e layout)])
|
||||||
|
(check-equal? (graph-layout-width layout) 50)
|
||||||
|
(check-equal? (graph-layout-height layout) 50)
|
||||||
|
(check-equal? (drawable-node-x dnode-a) 20)
|
||||||
|
(check-equal? (drawable-node-y dnode-a) 5)
|
||||||
|
(check-equal? (drawable-node-x dnode-b) test-padding)
|
||||||
|
(check-equal? (drawable-node-y dnode-b) (+ (* 2 test-padding) test-width))
|
||||||
|
(check-equal? (drawable-node-x dnode-c) (+ (* 2 test-padding) test-width))
|
||||||
|
(check-equal? (drawable-node-y dnode-c) (drawable-node-y dnode-b))
|
||||||
|
(check-equal? (drawable-node-x dnode-e) (+ (* 3 test-padding) (* 2 test-width)))
|
||||||
|
(check-equal? (drawable-node-y dnode-e) (drawable-node-y dnode-c))
|
||||||
|
(check-equal? (drawable-node-x dnode-d) (drawable-node-x dnode-c))
|
||||||
|
(check-equal? (drawable-node-y dnode-d) (+ (drawable-node-y dnode-c) test-padding test-width)))
|
||||||
|
(let ([atree (build-attr-tree tree3 0)])
|
||||||
|
(check-equal? (attributed-node-num-leaves atree) 3))
|
||||||
|
|
||||||
|
#|
|
||||||
|
a
|
||||||
|
/ | | \
|
||||||
|
b c f g
|
||||||
|
/ \
|
||||||
|
d e
|
||||||
|
|#
|
||||||
|
(define tree4 (tree 'a
|
||||||
|
(tree 'b)
|
||||||
|
(tree 'c
|
||||||
|
(tree 'd)
|
||||||
|
(tree 'e))
|
||||||
|
(tree 'f)
|
||||||
|
(tree 'g)))
|
||||||
|
(let* ([layout (draw-tree tree4 #:node-width test-width #:padding test-padding)]
|
||||||
|
[nodes (graph-layout-nodes layout)]
|
||||||
|
[dnode-a (get-node 'a layout)]
|
||||||
|
[dnode-b (get-node 'b layout)]
|
||||||
|
[dnode-c (get-node 'c layout)]
|
||||||
|
[dnode-d (get-node 'd layout)]
|
||||||
|
[dnode-e (get-node 'e layout)]
|
||||||
|
[dnode-f (get-node 'f layout)]
|
||||||
|
[dnode-g (get-node 'g layout)])
|
||||||
|
(check-equal? (graph-layout-width layout) 80)
|
||||||
|
(check-equal? (graph-layout-height layout) 50)
|
||||||
|
(check-equal? (drawable-node-x dnode-b) test-padding)
|
||||||
|
(check-equal? (drawable-node-y dnode-b) (+ (drawable-node-y dnode-a) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-y dnode-c) (drawable-node-y dnode-b))
|
||||||
|
(check-equal? (drawable-node-x dnode-d) (+ (drawable-node-x dnode-b) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-y dnode-d) (+ (drawable-node-y dnode-c) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-x dnode-e) (+ (drawable-node-x dnode-d) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-y dnode-e) (drawable-node-y dnode-d))
|
||||||
|
(check-equal? (drawable-node-x dnode-f) (+ (drawable-node-x dnode-e) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-y dnode-f) (drawable-node-y dnode-c))
|
||||||
|
(check-equal? (drawable-node-x dnode-g) (+ (drawable-node-x dnode-f) test-width test-padding)))
|
||||||
|
(let ([atree (build-attr-tree tree4 0)])
|
||||||
|
(check-equal? (attributed-node-num-leaves atree) 5))
|
||||||
|
|
||||||
|
#|
|
||||||
|
Layered-tree-draw example from Di Battista
|
||||||
|
a
|
||||||
|
/ \
|
||||||
|
b g
|
||||||
|
| / \
|
||||||
|
c h k
|
||||||
|
| / \
|
||||||
|
d i j
|
||||||
|
/ \
|
||||||
|
e f
|
||||||
|
|#
|
||||||
|
(define tree5 (tree 'a
|
||||||
|
(tree 'b
|
||||||
|
(tree 'c
|
||||||
|
(tree 'd
|
||||||
|
(tree 'e)
|
||||||
|
(tree 'f))))
|
||||||
|
(tree 'g
|
||||||
|
(tree 'h
|
||||||
|
(tree 'i)
|
||||||
|
(tree 'j))
|
||||||
|
(tree 'k))))
|
||||||
|
(let* ([layout (draw-tree tree5 #:node-width test-width #:padding test-padding)]
|
||||||
|
[nodes (graph-layout-nodes layout)]
|
||||||
|
[dnode-a (get-node 'a layout)]
|
||||||
|
[dnode-b (get-node 'b layout)]
|
||||||
|
[dnode-c (get-node 'c layout)]
|
||||||
|
[dnode-d (get-node 'd layout)]
|
||||||
|
[dnode-e (get-node 'e layout)]
|
||||||
|
[dnode-f (get-node 'f layout)]
|
||||||
|
[dnode-g (get-node 'g layout)]
|
||||||
|
[dnode-h (get-node 'h layout)]
|
||||||
|
[dnode-i (get-node 'i layout)]
|
||||||
|
[dnode-j (get-node 'j layout)]
|
||||||
|
[dnode-k (get-node 'k layout)])
|
||||||
|
(check-equal? (graph-layout-width layout) 80)
|
||||||
|
(check-equal? (graph-layout-height layout) 80)
|
||||||
|
(check-equal? (drawable-node-x dnode-e) test-padding)
|
||||||
|
(check-equal? (drawable-node-y dnode-e) 65)
|
||||||
|
(check-equal? (drawable-node-x dnode-f) (+ (drawable-node-x dnode-e) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-x dnode-i) (+ (drawable-node-x dnode-f) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-x dnode-j) (+ (drawable-node-x dnode-i) test-width test-padding))
|
||||||
|
(check-equal? (drawable-node-x dnode-k) (+ (drawable-node-x dnode-j) test-width test-padding)))
|
||||||
|
(let ([atree (build-attr-tree tree5 0)])
|
||||||
|
(check-equal? (attributed-node-num-leaves atree) 5))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
213
collects/racket/future/private/gui-helpers.rkt
Normal file
213
collects/racket/future/private/gui-helpers.rkt
Normal file
|
|
@ -0,0 +1,213 @@
|
||||||
|
#lang racket/gui
|
||||||
|
(require framework
|
||||||
|
slideshow/pict
|
||||||
|
"display.rkt"
|
||||||
|
"constants.rkt")
|
||||||
|
(provide pict-canvas%
|
||||||
|
label
|
||||||
|
mt-label
|
||||||
|
bold-label
|
||||||
|
mt-bold-label
|
||||||
|
section-header
|
||||||
|
(struct-out event-target)
|
||||||
|
make-listener-table
|
||||||
|
add-receiver
|
||||||
|
post-event)
|
||||||
|
|
||||||
|
(define pict-canvas%
|
||||||
|
(class canvas%
|
||||||
|
(init redraw-on-resize pict-builder hover-handler click-handler overlay-builder)
|
||||||
|
(inherit get-dc get-client-size refresh get-view-start)
|
||||||
|
(define bp pict-builder) ;Builds the main pict for the canvas
|
||||||
|
(define mh hover-handler) ;Mouse hover handler
|
||||||
|
(define ob overlay-builder) ;Hover overlay pict builder
|
||||||
|
(define ch click-handler) ;Mouse click handler
|
||||||
|
(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/public (set-redo-bitmap-on-paint! v)
|
||||||
|
(set! redo-bitmap-on-paint v))
|
||||||
|
|
||||||
|
(define/public (set-do-logging! v)
|
||||||
|
(set! do-logging v))
|
||||||
|
|
||||||
|
;;set-build-pict! : (viewable-region -> pict) -> void
|
||||||
|
(define/public (set-build-pict! f)
|
||||||
|
(set! bp f))
|
||||||
|
|
||||||
|
;;set-mouse-handler! : (uint uint -> segment) -> void
|
||||||
|
(define/public (set-mouse-handler! f)
|
||||||
|
(set! mh f))
|
||||||
|
|
||||||
|
;;set-overlay-builder! : (viewable-region -> pict) -> void
|
||||||
|
(define/public (set-overlay-builder! f)
|
||||||
|
(set! ob f))
|
||||||
|
|
||||||
|
;;set-click-handler! : (uint uint -> segment) -> void
|
||||||
|
(define/public (set-click-handler! f)
|
||||||
|
(set! ch f))
|
||||||
|
|
||||||
|
;;set-redraw-overlay! : bool -> void
|
||||||
|
(define/public (set-redraw-overlay! b)
|
||||||
|
(set! redraw-overlay b))
|
||||||
|
|
||||||
|
(define the-drawer #f)
|
||||||
|
(define img-width 0)
|
||||||
|
(define bm #f)
|
||||||
|
(define overlay-pict #f)
|
||||||
|
|
||||||
|
(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))
|
||||||
|
|
||||||
|
(define/private (overlay-drawer dc vregion)
|
||||||
|
(when ob
|
||||||
|
(define p (ob vregion))
|
||||||
|
(unless (or (not p) (void? p))
|
||||||
|
(draw-pict p
|
||||||
|
dc
|
||||||
|
(viewable-region-x vregion)
|
||||||
|
(viewable-region-y vregion)))))
|
||||||
|
|
||||||
|
(define/private (redo-bitmap vregion)
|
||||||
|
(when bp
|
||||||
|
(define p (bp vregion))
|
||||||
|
(set! bm (pict->bitmap p))))
|
||||||
|
|
||||||
|
(define/public (redraw-everything)
|
||||||
|
(redo-bitmap (get-viewable-region))
|
||||||
|
(refresh))
|
||||||
|
|
||||||
|
(define/override (on-size width height)
|
||||||
|
(when (or draw-on-resize
|
||||||
|
(not bm))
|
||||||
|
(set! bm #f)
|
||||||
|
(refresh))
|
||||||
|
(set! redraw-overlay #t))
|
||||||
|
|
||||||
|
(define/override (on-paint)
|
||||||
|
(define vregion (get-viewable-region))
|
||||||
|
(when (or redo-bitmap-on-paint (not bm))
|
||||||
|
(redo-bitmap vregion))
|
||||||
|
(when bm
|
||||||
|
(let ([dc (get-dc)])
|
||||||
|
(send dc draw-bitmap
|
||||||
|
bm
|
||||||
|
(viewable-region-x vregion)
|
||||||
|
(viewable-region-y vregion))
|
||||||
|
(overlay-drawer dc vregion))))
|
||||||
|
|
||||||
|
(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)))
|
||||||
|
(case (send event get-event-type)
|
||||||
|
[(motion)
|
||||||
|
(when mh (mh x y vregion))]
|
||||||
|
[(left-up)
|
||||||
|
(when ch (ch x y vregion))])
|
||||||
|
(when redraw-overlay
|
||||||
|
(refresh)))
|
||||||
|
|
||||||
|
(super-new)
|
||||||
|
(send (get-dc) set-smoothing 'aligned)))
|
||||||
|
|
||||||
|
(define bold-system-font
|
||||||
|
(send the-font-list find-or-create-font
|
||||||
|
(send normal-control-font get-point-size)
|
||||||
|
(send normal-control-font get-family)
|
||||||
|
(send normal-control-font get-style)
|
||||||
|
'bold))
|
||||||
|
|
||||||
|
(define (label p str)
|
||||||
|
(new message% [parent p]
|
||||||
|
[label str]
|
||||||
|
[stretchable-width #t]))
|
||||||
|
|
||||||
|
(define (mt-label p)
|
||||||
|
(label p ""))
|
||||||
|
|
||||||
|
(define (bold-label p str)
|
||||||
|
(new message% [parent p]
|
||||||
|
[label str]
|
||||||
|
[font bold-system-font]
|
||||||
|
[stretchable-width #t]))
|
||||||
|
|
||||||
|
(define (mt-bold-label p)
|
||||||
|
(bold-label p ""))
|
||||||
|
|
||||||
|
(define (section-header par name orientation)
|
||||||
|
(let* ([text-pict (colorize (text name) (header-forecolor))]
|
||||||
|
[text-container (pin-over (colorize (rectangle (+ 10 (pict-width text-pict))
|
||||||
|
(+ 10 (pict-height text-pict)))
|
||||||
|
(header-backcolor))
|
||||||
|
5
|
||||||
|
5
|
||||||
|
text-pict)]
|
||||||
|
[c (case orientation
|
||||||
|
[(horizontal)
|
||||||
|
(let ([canv (new pict-canvas%
|
||||||
|
[parent par]
|
||||||
|
[redraw-on-resize #t]
|
||||||
|
[pict-builder (λ (vregion)
|
||||||
|
(lc-superimpose (colorize (filled-rectangle (viewable-region-width vregion)
|
||||||
|
HEADER-HEIGHT)
|
||||||
|
(header-backcolor))
|
||||||
|
text-container))]
|
||||||
|
[hover-handler #f]
|
||||||
|
[click-handler #f]
|
||||||
|
[overlay-builder #f]
|
||||||
|
[min-height HEADER-HEIGHT]
|
||||||
|
[stretchable-width #t]
|
||||||
|
[stretchable-height #f])])
|
||||||
|
canv)]
|
||||||
|
[(vertical)
|
||||||
|
(let ([canv (new pict-canvas%
|
||||||
|
[parent par]
|
||||||
|
[redraw-on-resize #t]
|
||||||
|
[pict-builder (λ (vregion)
|
||||||
|
(rotate (lc-superimpose (colorize (filled-rectangle (viewable-region-height vregion)
|
||||||
|
HEADER-HEIGHT)
|
||||||
|
(header-backcolor))
|
||||||
|
text-container)
|
||||||
|
-1.57079633))]
|
||||||
|
[hover-handler #f]
|
||||||
|
[click-handler #f]
|
||||||
|
[overlay-builder #f]
|
||||||
|
[min-width HEADER-HEIGHT]
|
||||||
|
[stretchable-width #f]
|
||||||
|
[stretchable-height #t])])
|
||||||
|
canv)])])
|
||||||
|
c))
|
||||||
|
|
||||||
|
;Events
|
||||||
|
;receiver : any
|
||||||
|
;handler : (any -> void)
|
||||||
|
(struct event-target (receiver handler) #:transparent)
|
||||||
|
|
||||||
|
(define (make-listener-table) (make-hash))
|
||||||
|
|
||||||
|
(define (add-receiver table evt-name object handler)
|
||||||
|
(hash-update! table
|
||||||
|
evt-name
|
||||||
|
(λ (old)
|
||||||
|
(cons (event-target object handler) old))
|
||||||
|
(list (event-target object handler))))
|
||||||
|
|
||||||
|
(define (post-event table name sender arg)
|
||||||
|
(let ([targets (hash-ref table name)])
|
||||||
|
(for ([target (in-list targets)])
|
||||||
|
(let ([receiver (event-target-receiver target)]
|
||||||
|
[handler (event-target-handler target)])
|
||||||
|
(unless (eq? receiver sender)
|
||||||
|
(handler arg))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
365
collects/racket/future/private/visualizer-data.rkt
Normal file
365
collects/racket/future/private/visualizer-data.rkt
Normal file
|
|
@ -0,0 +1,365 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require racket/bool
|
||||||
|
racket/list
|
||||||
|
racket/contract
|
||||||
|
racket/future
|
||||||
|
racket/set
|
||||||
|
"constants.rkt"
|
||||||
|
"graph-drawing.rkt")
|
||||||
|
|
||||||
|
(provide (contract-out [start-performance-tracking! (-> void?)])
|
||||||
|
(struct-out future-event)
|
||||||
|
(struct-out indexed-fevent)
|
||||||
|
(struct-out trace)
|
||||||
|
(struct-out process-timeline)
|
||||||
|
(struct-out future-timeline)
|
||||||
|
(struct-out event)
|
||||||
|
(struct-out rtcall-info)
|
||||||
|
raw-log-output
|
||||||
|
organize-output
|
||||||
|
build-trace
|
||||||
|
event-has-duration?
|
||||||
|
final-event?
|
||||||
|
relative-time)
|
||||||
|
|
||||||
|
;Log message receiver
|
||||||
|
(define recv #f)
|
||||||
|
|
||||||
|
;;start-performance-tracking! -> void
|
||||||
|
(define (start-performance-tracking!)
|
||||||
|
(when (not recv)
|
||||||
|
(set! recv (make-log-receiver (current-logger) 'debug))))
|
||||||
|
|
||||||
|
(define-struct future-event (future-id process-id what time prim-name user-data)
|
||||||
|
#:prefab)
|
||||||
|
|
||||||
|
;Contains an index and a future-event,
|
||||||
|
;so we can preserve the order in which future-events
|
||||||
|
;were logged.
|
||||||
|
;Many future-events can be logged at what appears to be the same
|
||||||
|
;time, apparently because the time values don't have great enough precision
|
||||||
|
;to separate events which temporally occur close together.
|
||||||
|
(struct indexed-fevent (index fevent) #:transparent)
|
||||||
|
|
||||||
|
;The whole trace, with a start/end time and list of process timelines
|
||||||
|
(struct trace (start-time
|
||||||
|
end-time
|
||||||
|
proc-timelines
|
||||||
|
future-timelines
|
||||||
|
all-events
|
||||||
|
real-time ;TODO: What is this
|
||||||
|
num-futures ;TODO: (length future-timelines)
|
||||||
|
num-blocks
|
||||||
|
num-syncs
|
||||||
|
blocked-futures
|
||||||
|
avg-syncs-per-future
|
||||||
|
block-counts ;prim name --o--> number of blocks
|
||||||
|
sync-counts ;op name --o--> number of syncs
|
||||||
|
future-rtcalls ;fid --o--> rtcall-info
|
||||||
|
creation-tree))
|
||||||
|
|
||||||
|
(struct rtcall-info (fid
|
||||||
|
block-hash ; prim name --o--> number of blocks
|
||||||
|
sync-hash) ; op name --o--> number of syncs
|
||||||
|
#:transparent)
|
||||||
|
|
||||||
|
;The timeline of events for a specific process
|
||||||
|
(struct timeline (id
|
||||||
|
start
|
||||||
|
end
|
||||||
|
events))
|
||||||
|
;(struct process-timeline timeline (proc-index))
|
||||||
|
(struct process-timeline (proc-id
|
||||||
|
proc-index ;Why do we need this
|
||||||
|
start-time
|
||||||
|
end-time
|
||||||
|
events))
|
||||||
|
;(struct future-timeline timeline ())
|
||||||
|
(struct future-timeline (future-id
|
||||||
|
start-time
|
||||||
|
end-time
|
||||||
|
events))
|
||||||
|
|
||||||
|
;A block of time (e.g. a process executing a portion of a future thunk).
|
||||||
|
(struct event (index
|
||||||
|
start-time
|
||||||
|
end-time
|
||||||
|
proc-id
|
||||||
|
proc-index ;TODO: why here?
|
||||||
|
future-id
|
||||||
|
user-data
|
||||||
|
type
|
||||||
|
prim-name
|
||||||
|
timeline-position ;TODO: what is this
|
||||||
|
[prev-proc-event #:mutable]
|
||||||
|
[next-proc-event #:mutable]
|
||||||
|
[prev-future-event #:mutable]
|
||||||
|
[next-future-event #:mutable]
|
||||||
|
[next-targ-future-event #:mutable]
|
||||||
|
[prev-targ-future-event #:mutable]
|
||||||
|
[segment #:mutable]) #:transparent)
|
||||||
|
|
||||||
|
;;event-has-duration? : event -> bool
|
||||||
|
(define (event-has-duration? evt)
|
||||||
|
(case (event-type evt)
|
||||||
|
[(start-work start-0-work) #t]
|
||||||
|
[else #f]))
|
||||||
|
|
||||||
|
;;final-event? : event -> bool
|
||||||
|
(define (final-event? evt)
|
||||||
|
(case (event-timeline-position evt)
|
||||||
|
[(end singleton) #t]
|
||||||
|
[else #f]))
|
||||||
|
|
||||||
|
(define (get-log-events)
|
||||||
|
(let ([info (sync/timeout 0 recv)])
|
||||||
|
(if info
|
||||||
|
(let ([v (vector-ref info 2)])
|
||||||
|
(cons v (get-log-events)))
|
||||||
|
'())))
|
||||||
|
|
||||||
|
;;get-relative-start-time : trace float -> float
|
||||||
|
(define (relative-time trace abs-time)
|
||||||
|
(- abs-time (trace-start-time trace)))
|
||||||
|
|
||||||
|
;Gets log output as a straight list, ordered according to when the
|
||||||
|
;message was logged
|
||||||
|
;;raw-log-output : uint -> (listof indexed-fevent)
|
||||||
|
(define (raw-log-output index)
|
||||||
|
(let ([info (sync/timeout 0 recv)])
|
||||||
|
(if info
|
||||||
|
(let ([v (vector-ref info 2)])
|
||||||
|
(if (future-event? v)
|
||||||
|
(cons (indexed-fevent index v) (raw-log-output (add1 index)))
|
||||||
|
(raw-log-output index)))
|
||||||
|
'())))
|
||||||
|
|
||||||
|
(define (print-blocks raw-output)
|
||||||
|
(for ([fe (in-list raw-output)])
|
||||||
|
(when (equal? (future-event-what fe) 'block)
|
||||||
|
(printf "~a\n" (future-event-prim-name fe)))))
|
||||||
|
|
||||||
|
;Produces a vector of vectors, where each inner vector contains
|
||||||
|
;all the log output messages for a specific process
|
||||||
|
;;organize-output : (listof indexed-fevent) -> (vectorof (vectorof future-event))
|
||||||
|
(define (organize-output raw-log-output)
|
||||||
|
;TODO: Try using for/set here, does calling code depend on ordering
|
||||||
|
#;(define unique-proc-ids (for/set ([ie (in-list raw-log-output)])
|
||||||
|
(future-event-process-id (indexed-fevent-fevent ie))))
|
||||||
|
(let ([unique-proc-ids (sort (for/fold ([ids '()]) ([ie (in-list raw-log-output)])
|
||||||
|
(let* ([evt (indexed-fevent-fevent ie)]
|
||||||
|
[procid (future-event-process-id evt)])
|
||||||
|
(if (member procid ids)
|
||||||
|
ids
|
||||||
|
(cons procid ids))))
|
||||||
|
<)])
|
||||||
|
(for/vector ([procid (in-list unique-proc-ids)])
|
||||||
|
(for/vector ([e (in-list raw-log-output)]
|
||||||
|
#:when (eq? procid (future-event-process-id (indexed-fevent-fevent e))))
|
||||||
|
e))))
|
||||||
|
|
||||||
|
;;build-trace : (listof indexed-fevent) -> trace
|
||||||
|
(define (build-trace log-output)
|
||||||
|
(define data (organize-output log-output))
|
||||||
|
(define-values (start-time end-time unique-fids nblocks nsyncs)
|
||||||
|
(for/fold ([start-time #f]
|
||||||
|
[end-time #f]
|
||||||
|
[unique-fids (set)]
|
||||||
|
[nblocks 0]
|
||||||
|
[nsyncs 0]) ([ie (in-list log-output)])
|
||||||
|
(let* ([evt (indexed-fevent-fevent ie)]
|
||||||
|
[fid (future-event-future-id evt)]
|
||||||
|
[is-future-thread? (not (= (future-event-process-id evt) RT-THREAD-ID))])
|
||||||
|
(values
|
||||||
|
(if start-time
|
||||||
|
(min start-time (future-event-time evt))
|
||||||
|
(future-event-time evt))
|
||||||
|
(if end-time
|
||||||
|
(max end-time (future-event-time evt))
|
||||||
|
(future-event-time evt))
|
||||||
|
(if fid
|
||||||
|
(set-add unique-fids fid)
|
||||||
|
unique-fids)
|
||||||
|
(if (and is-future-thread?
|
||||||
|
(case (future-event-what evt)
|
||||||
|
[(block touch) #t]
|
||||||
|
[else #f]))
|
||||||
|
(add1 nblocks)
|
||||||
|
nblocks)
|
||||||
|
(if (and is-future-thread? (symbol=? (future-event-what evt) 'sync))
|
||||||
|
(add1 nsyncs)
|
||||||
|
nsyncs)))))
|
||||||
|
(define tls (for/list ([proc-log-vec (in-vector data)]
|
||||||
|
[i (in-naturals)])
|
||||||
|
(let* ([fst-ie (vector-ref proc-log-vec 0)]
|
||||||
|
[fst-log-msg (indexed-fevent-fevent fst-ie)])
|
||||||
|
(process-timeline (future-event-process-id fst-log-msg)
|
||||||
|
i
|
||||||
|
(future-event-time fst-log-msg)
|
||||||
|
(future-event-time (indexed-fevent-fevent
|
||||||
|
(vector-ref proc-log-vec
|
||||||
|
(sub1 (vector-length proc-log-vec)))))
|
||||||
|
(for/list ([ie (in-vector proc-log-vec)]
|
||||||
|
[j (in-naturals)])
|
||||||
|
(let* ([evt (indexed-fevent-fevent ie)]
|
||||||
|
[start (future-event-time evt)]
|
||||||
|
[pos (cond
|
||||||
|
[(zero? j) (if (= j (sub1 (vector-length proc-log-vec)))
|
||||||
|
'singleton
|
||||||
|
'start)]
|
||||||
|
[(= j (sub1 (vector-length proc-log-vec))) 'end]
|
||||||
|
[else 'interior])])
|
||||||
|
(event (indexed-fevent-index ie)
|
||||||
|
start
|
||||||
|
(if (or (equal? pos 'end) (equal? pos 'singleton))
|
||||||
|
start
|
||||||
|
(future-event-time (indexed-fevent-fevent
|
||||||
|
(vector-ref proc-log-vec (add1 j)))))
|
||||||
|
(future-event-process-id 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)))
|
||||||
|
(λ (a b)
|
||||||
|
(< (event-index a) (event-index b)))))
|
||||||
|
(define ftls (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))))
|
||||||
|
(define-values (block-hash sync-hash rt-hash) (build-rtcall-hash all-evts))
|
||||||
|
(define tr (trace start-time
|
||||||
|
end-time
|
||||||
|
tls
|
||||||
|
ftls
|
||||||
|
all-evts
|
||||||
|
(- end-time start-time) ;real time
|
||||||
|
(set-count unique-fids) ;num-futures
|
||||||
|
nblocks ;num-blocks
|
||||||
|
nsyncs ;num-syncs
|
||||||
|
0
|
||||||
|
0
|
||||||
|
block-hash
|
||||||
|
sync-hash
|
||||||
|
rt-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)
|
||||||
|
(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))])
|
||||||
|
;(printf "event: ~a\n" evt)
|
||||||
|
(define isblock (case (event-type evt)
|
||||||
|
[(block) #t]
|
||||||
|
[else #f]))
|
||||||
|
(define ophash (if isblock block-hash sync-hash))
|
||||||
|
(hash-update! ophash
|
||||||
|
(event-prim-name evt)
|
||||||
|
(λ (old) (add1 old))
|
||||||
|
(λ () 1))
|
||||||
|
(hash-update! rt-hash
|
||||||
|
(event-future-id evt)
|
||||||
|
(λ (old)
|
||||||
|
(let ([h (if isblock
|
||||||
|
(rtcall-info-block-hash old)
|
||||||
|
(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))))
|
||||||
|
; (printf "blocks: ~a\n syncs: ~a\n rts: ~a\n" block-hash sync-hash rt-hash)
|
||||||
|
(values block-hash sync-hash rt-hash))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;connect-event-chains! : trace -> void
|
||||||
|
(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)))
|
||||||
|
void
|
||||||
|
(begin
|
||||||
|
(set-event-prev-proc-event! (first (cdr evts)) (car evts))
|
||||||
|
(set-event-next-proc-event! (car evts) (first (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)))
|
||||||
|
void
|
||||||
|
(begin
|
||||||
|
(set-event-prev-future-event! (first (cdr evts)) (car evts))
|
||||||
|
(set-event-next-future-event! (car evts) (first (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)
|
||||||
|
(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))))
|
||||||
|
(let ([targ-evt (findf (λ (e) (and (event-future-id e)
|
||||||
|
(= (event-future-id e)
|
||||||
|
(event-user-data cur-evt))))
|
||||||
|
(cdr rest))])
|
||||||
|
(when targ-evt
|
||||||
|
(set-event-next-targ-future-event! cur-evt targ-evt)
|
||||||
|
(set-event-prev-targ-future-event! targ-evt cur-evt))))
|
||||||
|
(loop (cdr rest))))))
|
||||||
|
|
||||||
|
;;creation-event : event -> bool
|
||||||
|
(define (creation-event? evt)
|
||||||
|
(equal? (event-type evt) 'create))
|
||||||
|
|
||||||
|
;;buid-creation-graph/private : (uint -o-> (listof future-event)) -> (listof node)
|
||||||
|
(define (build-creation-graph/private future-timelines evt)
|
||||||
|
(let* ([fid (event-user-data evt)]
|
||||||
|
[fevents (filter creation-event? (hash-ref future-timelines fid))])
|
||||||
|
(for/list ([cevt (in-list fevents)])
|
||||||
|
(node cevt
|
||||||
|
(build-creation-graph/private future-timelines cevt)))))
|
||||||
|
|
||||||
|
;;build-creation-graph : (uint -o-> (listof future-event)) -> node
|
||||||
|
(define (build-creation-graph future-timelines)
|
||||||
|
(define roots (filter creation-event?
|
||||||
|
(hash-ref future-timelines #f)))
|
||||||
|
(define root-nodes (for/list ([root (in-list roots)])
|
||||||
|
(node root
|
||||||
|
(build-creation-graph/private future-timelines root))))
|
||||||
|
(node 'runtime-thread
|
||||||
|
root-nodes))
|
||||||
831
collects/racket/future/private/visualizer-drawing.rkt
Normal file
831
collects/racket/future/private/visualizer-drawing.rkt
Normal file
|
|
@ -0,0 +1,831 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require racket/list
|
||||||
|
racket/class
|
||||||
|
racket/draw
|
||||||
|
slideshow/pict
|
||||||
|
data/interval-map
|
||||||
|
"visualizer-data.rkt"
|
||||||
|
"graph-drawing.rkt"
|
||||||
|
"drawing-helpers.rkt"
|
||||||
|
"display.rkt"
|
||||||
|
"constants.rkt")
|
||||||
|
|
||||||
|
(provide seg-in-vregion
|
||||||
|
calc-segments
|
||||||
|
calc-ticks
|
||||||
|
calc-row-mid-y
|
||||||
|
find-seg-for-coords
|
||||||
|
segment-edge
|
||||||
|
segs-equal-or-later
|
||||||
|
build-timeline-pict
|
||||||
|
build-timeline-bmp-from-log
|
||||||
|
build-timeline-pict-from-log
|
||||||
|
build-timeline-overlay
|
||||||
|
build-timeline-with-overlay
|
||||||
|
build-timeline-bmp-with-overlay
|
||||||
|
build-creategraph-pict
|
||||||
|
graph-overlay-pict
|
||||||
|
(struct-out segment)
|
||||||
|
(struct-out frame-info)
|
||||||
|
(struct-out timeline-tick)
|
||||||
|
find-node-for-coords
|
||||||
|
find-fid-for-coords
|
||||||
|
first-seg-for-fid)
|
||||||
|
|
||||||
|
;Represents a dot or square on the timeline
|
||||||
|
(struct segment (event
|
||||||
|
x
|
||||||
|
y
|
||||||
|
width
|
||||||
|
height
|
||||||
|
color
|
||||||
|
p
|
||||||
|
prev-future-seg
|
||||||
|
next-future-seg
|
||||||
|
prev-proc-seg
|
||||||
|
next-proc-seg
|
||||||
|
prev-targ-future-seg
|
||||||
|
next-targ-future-seg) #:transparent #:mutable)
|
||||||
|
|
||||||
|
|
||||||
|
;General information about the timeline image
|
||||||
|
(struct frame-info (adjusted-width
|
||||||
|
adjusted-height
|
||||||
|
row-height
|
||||||
|
modifier
|
||||||
|
timeline-ticks
|
||||||
|
process-line-coords) #:transparent)
|
||||||
|
|
||||||
|
;Represents a vertical line depicting a specific time in the execution history
|
||||||
|
(struct timeline-tick (x
|
||||||
|
abs-time
|
||||||
|
rel-time) #:transparent)
|
||||||
|
|
||||||
|
;;viewable-region-from-frame : frame-info -> viewable-region
|
||||||
|
(define (viewable-region-from-frame finfo)
|
||||||
|
(viewable-region 0
|
||||||
|
0
|
||||||
|
(frame-info-adjusted-width finfo)
|
||||||
|
(frame-info-adjusted-height finfo)))
|
||||||
|
|
||||||
|
;;seg-in-vregion : viewable-region segment -> bool
|
||||||
|
(define (seg-in-vregion vregion)
|
||||||
|
(λ (seg)
|
||||||
|
(in-viewable-region vregion
|
||||||
|
(segment-x seg)
|
||||||
|
(segment-y seg)
|
||||||
|
(segment-width seg)
|
||||||
|
(segment-height seg))))
|
||||||
|
|
||||||
|
;;calc-seg-x : event process-timeline trace uint float -> uint
|
||||||
|
(define (calc-seg-x evt tr modifier)
|
||||||
|
(floor (* (relative-time tr (event-start-time evt))
|
||||||
|
modifier)))
|
||||||
|
|
||||||
|
;;calc-seg-width : float event -> uint
|
||||||
|
(define (calc-seg-width modifier evt)
|
||||||
|
(case (event-type evt)
|
||||||
|
[(start-work start-0-work) (max MIN-SEG-WIDTH (* modifier (- (event-end-time evt)
|
||||||
|
(event-start-time evt))))]
|
||||||
|
[else MIN-SEG-WIDTH]))
|
||||||
|
|
||||||
|
;Finds the segment for given x and y mouse coordinates
|
||||||
|
;;find-seg-for-coords : uint uint interval-map -> segment
|
||||||
|
(define (find-seg-for-coords x y index)
|
||||||
|
(let ([xmap (interval-map-ref index y #f)])
|
||||||
|
(if xmap
|
||||||
|
(interval-map-ref xmap x #f)
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
;;find-fid-for-coords : uint uint (listof drawable-node) -> drawable-node
|
||||||
|
(define (find-node-for-coords x y nodes)
|
||||||
|
(define node-l (filter (λ (n)
|
||||||
|
(define n-x (drawable-node-x n))
|
||||||
|
(define n-y (drawable-node-y n))
|
||||||
|
(define n-w (drawable-node-width n))
|
||||||
|
(and (n-x . < . x)
|
||||||
|
(n-y . < . y)
|
||||||
|
(x . < . (+ n-x n-w))
|
||||||
|
(y . < . (+ n-y n-w))))
|
||||||
|
(remove-duplicates (flatten nodes))))
|
||||||
|
(cond
|
||||||
|
[(empty? node-l)
|
||||||
|
#f]
|
||||||
|
[(= 1 (length node-l))
|
||||||
|
(car node-l)]
|
||||||
|
[else
|
||||||
|
(error 'find-node-for-coords "Multiple nodes found for coords: ~s ~s, ~s" x y node-l)]))
|
||||||
|
|
||||||
|
;;find-fid-for-coords : x y ??(listof (listof nodes)) by depth?? viewable-region -> fid
|
||||||
|
(define (find-fid-for-coords x y nodes vregion)
|
||||||
|
(define n (find-node-for-coords x y nodes))
|
||||||
|
(if n
|
||||||
|
(event-user-data (node-data (drawable-node-node n)))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
;;first-seg-for-fid : future-id (listof segments) -> segment
|
||||||
|
(define (first-seg-for-fid fid segs)
|
||||||
|
(first
|
||||||
|
(sort
|
||||||
|
(filter (λ (s) (define seg-fid (event-future-id (segment-event s)))
|
||||||
|
(and seg-fid fid (= fid seg-fid))) segs)
|
||||||
|
< #:key (λ (s) (event-start-time (segment-event s))))))
|
||||||
|
|
||||||
|
;;calc-adjusted-width : uint trace -> uint
|
||||||
|
(define (calc-adjusted-width w tr)
|
||||||
|
(define baseModifier (/ w (- (trace-end-time tr) (trace-start-time tr))))
|
||||||
|
(define max-x-extent (for*/fold ([x 0]) ([tl (in-list (trace-proc-timelines tr))]
|
||||||
|
[evt (in-list (process-timeline-events tl))])
|
||||||
|
(max (+ (calc-seg-x evt tr baseModifier)
|
||||||
|
(calc-seg-width baseModifier evt))
|
||||||
|
x)))
|
||||||
|
(- (- w (- max-x-extent w)) MIN-SEG-WIDTH))
|
||||||
|
|
||||||
|
;;calc-row-mid-y : uint uint -> uint
|
||||||
|
(define (calc-row-mid-y proc-index row-height)
|
||||||
|
(floor (- (+ (* proc-index
|
||||||
|
row-height)
|
||||||
|
(/ row-height 2))
|
||||||
|
2)))
|
||||||
|
|
||||||
|
;Gets the center of a circle with (xleft, ytop) as the top-left coordinate.
|
||||||
|
;;calc-center : uint uint uint -> (values uint uint)
|
||||||
|
(define (calc-center xleft ytop diameter)
|
||||||
|
(let ([rad (floor (/ diameter 2))])
|
||||||
|
(values (+ xleft rad)
|
||||||
|
(+ ytop rad))))
|
||||||
|
|
||||||
|
;;segs-equal-or-after : float (listof segment) -> (listof segment)
|
||||||
|
(define (segs-equal-or-later real-time segs)
|
||||||
|
(let loop ([sgs segs])
|
||||||
|
(cond
|
||||||
|
[(null? sgs) '()]
|
||||||
|
[(>= (event-start-time (segment-event (car sgs))) real-time) sgs]
|
||||||
|
[else (loop (cdr sgs))])))
|
||||||
|
|
||||||
|
;;segment-edge : segment -> uint
|
||||||
|
(define (segment-edge seg)
|
||||||
|
(define evt (segment-event seg))
|
||||||
|
(if (event-has-duration? evt)
|
||||||
|
(segment-x seg)
|
||||||
|
(+ (segment-x seg) (segment-width seg))))
|
||||||
|
|
||||||
|
;;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)
|
||||||
|
(for/fold ([last-time trace-start]
|
||||||
|
[last-x 0]
|
||||||
|
[ticks '()]) ([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 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))
|
||||||
|
(define next-evt-time (inexact->exact (event-start-time next-evt)))
|
||||||
|
(define most-recent-edge (segment-edge most-recent-seg))
|
||||||
|
(define next-edge (segment-x next-seg))
|
||||||
|
(cond
|
||||||
|
[(= 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))]
|
||||||
|
[(= (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))
|
||||||
|
(cons (timeline-tick (+ (segment-x most-recent-seg)
|
||||||
|
(segment-width most-recent-seg))
|
||||||
|
tick-time
|
||||||
|
tick-rel-time)
|
||||||
|
ticks))]
|
||||||
|
[else
|
||||||
|
(define start-x (max most-recent-edge last-x))
|
||||||
|
(define start-time (max most-recent-time last-time))
|
||||||
|
(define size-mod (/ (- next-edge start-x) (- next-evt-time start-time)))
|
||||||
|
(define x-offset (ceiling (* (- tick-time start-time) size-mod)))
|
||||||
|
(define tick-x (round (+ start-x x-offset)))
|
||||||
|
(values tick-time
|
||||||
|
tick-x
|
||||||
|
(cons (timeline-tick tick-x tick-time tick-rel-time) ticks))])))
|
||||||
|
tks)
|
||||||
|
|
||||||
|
;;calc-process-timespan-lines : trace (listof segment) -> (listof (uint . uint))
|
||||||
|
(define (calc-process-timespan-lines trace segs)
|
||||||
|
(for/list ([tl (in-list (trace-proc-timelines trace))])
|
||||||
|
(let ([segs (filter (λ (s) (= (process-timeline-proc-id tl)
|
||||||
|
(event-proc-id (segment-event s))))
|
||||||
|
segs)])
|
||||||
|
(cons (segment-x (car segs))
|
||||||
|
(segment-x (last segs))))))
|
||||||
|
|
||||||
|
;;get-first-future-seg : seg -> seg
|
||||||
|
(define (get-first-future-seg seg)
|
||||||
|
(let loop ([cur seg])
|
||||||
|
(if (segment-prev-future-seg cur)
|
||||||
|
(loop (segment-prev-future-seg cur))
|
||||||
|
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))))))
|
||||||
|
|
||||||
|
;;adjust-work-segs! : (listof segment) -> void
|
||||||
|
(define (adjust-work-segs! segs)
|
||||||
|
(for ([seg (in-list segs)])
|
||||||
|
(case (event-type (segment-event seg))
|
||||||
|
[(start-work start-0-work)
|
||||||
|
(set-segment-width! seg (max MIN-SEG-WIDTH
|
||||||
|
(- (segment-x (segment-next-proc-seg seg)) (segment-x seg))))]
|
||||||
|
[else
|
||||||
|
void])))
|
||||||
|
|
||||||
|
;;connect-segments! : (listof segment) -> void
|
||||||
|
(define (connect-segments! segs)
|
||||||
|
(for ([s (in-list segs)])
|
||||||
|
(let ([evt (segment-event s)])
|
||||||
|
(set-segment-prev-proc-seg! s (if (event-prev-proc-event evt)
|
||||||
|
(event-segment (event-prev-proc-event evt))
|
||||||
|
#f))
|
||||||
|
(set-segment-next-proc-seg! s (if (event-next-proc-event evt)
|
||||||
|
(event-segment (event-next-proc-event evt))
|
||||||
|
#f))
|
||||||
|
(set-segment-prev-future-seg! s (if (event-prev-future-event evt)
|
||||||
|
(event-segment (event-prev-future-event evt))
|
||||||
|
#f))
|
||||||
|
(set-segment-next-future-seg! s (if (event-next-future-event evt)
|
||||||
|
(event-segment (event-next-future-event evt))
|
||||||
|
#f))
|
||||||
|
(set-segment-prev-targ-future-seg! s (if (event-prev-targ-future-event evt)
|
||||||
|
(event-segment (event-prev-targ-future-event evt))
|
||||||
|
#f))
|
||||||
|
(set-segment-next-targ-future-seg! s (if (event-next-targ-future-event evt)
|
||||||
|
(event-segment (event-next-targ-future-event evt))
|
||||||
|
#f)))))
|
||||||
|
|
||||||
|
(struct acc (delta last-right-edge) #:transparent)
|
||||||
|
|
||||||
|
;;build-seg-layout : flonum (listof event) trace -> (values (listof segment) uint uint)
|
||||||
|
(define (build-seg-layout timeToPixModifier events tr)
|
||||||
|
(define last-right-edges (build-vector (length (trace-proc-timelines tr)) (λ (n) 0)))
|
||||||
|
(define-values (sgs d x-extent)
|
||||||
|
(for/fold ([segs '()]
|
||||||
|
[delta 0]
|
||||||
|
[largest-x 0]) ([evt (in-list events)])
|
||||||
|
(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))
|
||||||
|
(- (trace-end-time tr) (trace-start-time tr)))))))
|
||||||
|
(define-values (offset new-delta)
|
||||||
|
(if (last-right-edge . <= . wanted-offset)
|
||||||
|
(values wanted-offset delta)
|
||||||
|
(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)
|
||||||
|
segw
|
||||||
|
MIN-SEG-WIDTH
|
||||||
|
(get-event-color (event-type evt))
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
#f))
|
||||||
|
(set-event-segment! evt seg)
|
||||||
|
(vector-set! last-right-edges (event-proc-index evt) (+ offset segw))
|
||||||
|
(values (cons seg segs)
|
||||||
|
new-delta
|
||||||
|
(max largest-x last-right-edge))))
|
||||||
|
(values sgs x-extent))
|
||||||
|
|
||||||
|
;;calc-segments : trace uint uint -> (values frame-info (listof segment))
|
||||||
|
(define (calc-segments tr)
|
||||||
|
(define evts (trace-all-events tr))
|
||||||
|
(define timeToPixModifier (/ DEFAULT-TIMELINE-WIDTH (- (trace-end-time tr) (trace-start-time tr))))
|
||||||
|
(define-values (segments x)
|
||||||
|
(build-seg-layout timeToPixModifier evts tr))
|
||||||
|
(define ordered-segs (reverse segments))
|
||||||
|
(connect-segments! ordered-segs)
|
||||||
|
(adjust-work-segs! ordered-segs)
|
||||||
|
(define ticks (calc-ticks ordered-segs timeToPixModifier tr))
|
||||||
|
(values (frame-info (+ MIN-SEG-WIDTH (round x))
|
||||||
|
(* TIMELINE-ROW-HEIGHT (length (trace-proc-timelines tr)))
|
||||||
|
TIMELINE-ROW-HEIGHT
|
||||||
|
timeToPixModifier
|
||||||
|
ticks
|
||||||
|
(calc-process-timespan-lines tr ordered-segs))
|
||||||
|
ordered-segs))
|
||||||
|
|
||||||
|
;;pict-for-segment : segment -> pict
|
||||||
|
(define (pict-for-segment seg)
|
||||||
|
(when (not (segment-p seg))
|
||||||
|
(set-segment-p! seg (if (event-has-duration? (segment-event seg))
|
||||||
|
(rect-pict (segment-color seg)
|
||||||
|
(timeline-event-strokecolor)
|
||||||
|
(segment-width seg)
|
||||||
|
MIN-SEG-WIDTH
|
||||||
|
#:stroke-width .5)
|
||||||
|
(circle-pict (segment-color seg)
|
||||||
|
(timeline-event-strokecolor)
|
||||||
|
MIN-SEG-WIDTH
|
||||||
|
#:stroke-width .5))))
|
||||||
|
(segment-p seg))
|
||||||
|
|
||||||
|
;;draw-ruler-on : pict viewable-region frameinfo -> pict
|
||||||
|
(define (draw-ruler-on base vregion frameinfo)
|
||||||
|
(let loop ([pct base]
|
||||||
|
[ticks (filter (λ (t) (in-viewable-region-horiz vregion (timeline-tick-x t)))
|
||||||
|
(frame-info-timeline-ticks frameinfo))]
|
||||||
|
[next-label-x (viewable-region-x-extent vregion)]
|
||||||
|
[next-tick-x (viewable-region-x-extent vregion)])
|
||||||
|
(cond
|
||||||
|
[(null? ticks) pct]
|
||||||
|
[(< (- next-tick-x (timeline-tick-x (car ticks))) TIMELINE-MIN-TICK-PADDING)
|
||||||
|
(loop pct
|
||||||
|
(cdr ticks)
|
||||||
|
next-label-x
|
||||||
|
next-tick-x)]
|
||||||
|
[else (let* ([LABEL-PAD 2]
|
||||||
|
[VERT-PAD 3]
|
||||||
|
[cur-tick (car ticks)]
|
||||||
|
[cur-x (timeline-tick-x cur-tick)]
|
||||||
|
[tick-desc (format "~a ms" (real->decimal-string
|
||||||
|
(timeline-tick-rel-time cur-tick) 1))]
|
||||||
|
[t (text-block-pict tick-desc
|
||||||
|
#:backcolor (timeline-tick-label-backcolor)
|
||||||
|
#:forecolor (timeline-tick-label-forecolor)
|
||||||
|
#:padding 3)]
|
||||||
|
[text-width (pict-width t)]
|
||||||
|
[show-label? (<= (+ cur-x LABEL-PAD text-width) next-label-x)]
|
||||||
|
[pinnedline (pin-over pct
|
||||||
|
(- cur-x (viewable-region-x vregion))
|
||||||
|
0
|
||||||
|
(linestyle 'dot
|
||||||
|
(colorize (vline 1
|
||||||
|
(frame-info-adjusted-height frameinfo))
|
||||||
|
(if show-label?
|
||||||
|
(timeline-tick-bold-color)
|
||||||
|
(timeline-tick-color)))))])
|
||||||
|
(if show-label?
|
||||||
|
(loop (pin-over pinnedline
|
||||||
|
(- cur-x (viewable-region-x vregion))
|
||||||
|
VERT-PAD
|
||||||
|
t)
|
||||||
|
(cdr ticks)
|
||||||
|
cur-x
|
||||||
|
cur-x)
|
||||||
|
(loop pinnedline
|
||||||
|
(cdr ticks)
|
||||||
|
next-label-x
|
||||||
|
cur-x)))])))
|
||||||
|
|
||||||
|
;;draw-row-lines-on : pict viewable-region trace frameinfo -> pict
|
||||||
|
(define (draw-row-lines-on base vregion tr finfo opacity)
|
||||||
|
(pin-over base
|
||||||
|
0
|
||||||
|
0
|
||||||
|
(for/fold ([pct base]) ([tl (in-list (trace-proc-timelines tr))]
|
||||||
|
[i (in-naturals)])
|
||||||
|
(let* ([line-coords (list-ref (frame-info-process-line-coords finfo)
|
||||||
|
(process-timeline-proc-index tl))]
|
||||||
|
[line-start (car line-coords)]
|
||||||
|
[line-end (cdr line-coords)]
|
||||||
|
[vregion-start (viewable-region-x vregion)]
|
||||||
|
[vregion-end (viewable-region-x-extent vregion)]
|
||||||
|
[start-x (cond
|
||||||
|
[(< line-start vregion-start) 0]
|
||||||
|
[(between line-start vregion-start vregion-end)
|
||||||
|
(- line-start vregion-start)]
|
||||||
|
[else vregion-end])]
|
||||||
|
[end-x (cond
|
||||||
|
[(< line-end vregion-start) 0]
|
||||||
|
[(between line-end vregion-start vregion-end)
|
||||||
|
(- line-end vregion-start)]
|
||||||
|
[else vregion-end])]
|
||||||
|
[proc-name (if (zero? i)
|
||||||
|
"Thread 0 (Runtime Thread)"
|
||||||
|
(format "Thread ~a" (process-timeline-proc-id tl)))]
|
||||||
|
[proc-title (text-block-pict proc-name
|
||||||
|
#:backcolor (header-backcolor)
|
||||||
|
#:forecolor (header-forecolor)
|
||||||
|
#:padding HEADER-PADDING
|
||||||
|
#:opacity opacity
|
||||||
|
#:width (viewable-region-width vregion))])
|
||||||
|
(draw-stack-onto pct
|
||||||
|
(at 0
|
||||||
|
(- (* (add1 i) (frame-info-row-height finfo)) (viewable-region-y vregion))
|
||||||
|
(colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color)))
|
||||||
|
(at 0
|
||||||
|
(+ (+ (- (* i (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 (process-timeline-proc-index tl) (frame-info-row-height finfo))
|
||||||
|
(viewable-region-y vregion))
|
||||||
|
(colorize (hline (- end-x start-x) 1)
|
||||||
|
(timeline-event-baseline-color))))))))
|
||||||
|
|
||||||
|
;Magnifies a segment's pict (dot or square) to make
|
||||||
|
;it stand out when hovered over with the mouse pointer.
|
||||||
|
;;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)]))
|
||||||
|
|
||||||
|
;;frame-bg : viewable-region frame-info trace -> pict
|
||||||
|
(define (frame-bg vregion finfo tr)
|
||||||
|
(draw-frame-bg-onto (colorize (filled-rectangle (viewable-region-width vregion)
|
||||||
|
(frame-info-adjusted-height finfo))
|
||||||
|
(timeline-frame-bg-color))
|
||||||
|
vregion
|
||||||
|
finfo
|
||||||
|
tr
|
||||||
|
TIMELINE-HEADER-OPACITY))
|
||||||
|
|
||||||
|
;;draw-frame-bg-onto : pict viewable-region frameinfo trace -> pict
|
||||||
|
(define (draw-frame-bg-onto base vregion finfo tr opacity)
|
||||||
|
(let ([with-ruler (draw-ruler-on base vregion finfo)])
|
||||||
|
(draw-row-lines-on with-ruler vregion tr finfo opacity)))
|
||||||
|
|
||||||
|
;;draw-connection : viewable-region segment segment pict string [uint bool symbol] -> pict
|
||||||
|
(define (draw-connection vregion
|
||||||
|
start
|
||||||
|
end
|
||||||
|
base-pct
|
||||||
|
color
|
||||||
|
#:width [width 1]
|
||||||
|
#:with-arrow [with-arrow #f]
|
||||||
|
#:style [style 'solid])
|
||||||
|
(let*-values ([(midx midy) (calc-center (- (segment-x start) (viewable-region-x vregion))
|
||||||
|
(- (segment-y start) (viewable-region-y vregion))
|
||||||
|
MIN-SEG-WIDTH)]
|
||||||
|
[(nextx nexty) (calc-center (- (segment-x end) (viewable-region-x vregion))
|
||||||
|
(- (segment-y end) (viewable-region-y vregion))
|
||||||
|
MIN-SEG-WIDTH)]
|
||||||
|
[(dx dy) (values (- nextx midx) (- nexty midy))])
|
||||||
|
(if (and (zero? dy)
|
||||||
|
(or (not (eq? (segment-next-proc-seg start) end))
|
||||||
|
(< dx CONNECTION-LINE-HAT-THRESHOLD)))
|
||||||
|
(let* ([dxa (/ dx 2)]
|
||||||
|
[dya (- HAT-HEIGHT CONNECTION-LINE-HAT-THRESHOLD)]
|
||||||
|
[breakx (+ midx dxa)]
|
||||||
|
[breaky (+ midy dya)])
|
||||||
|
(draw-line-onto (draw-line-onto base-pct
|
||||||
|
midx
|
||||||
|
midy
|
||||||
|
breakx
|
||||||
|
breaky
|
||||||
|
color
|
||||||
|
#:width width
|
||||||
|
#:style style)
|
||||||
|
breakx
|
||||||
|
breaky
|
||||||
|
nextx
|
||||||
|
nexty
|
||||||
|
color
|
||||||
|
#:width width
|
||||||
|
#:with-arrow with-arrow
|
||||||
|
#:style style))
|
||||||
|
(draw-line-onto base-pct
|
||||||
|
midx
|
||||||
|
midy
|
||||||
|
nextx
|
||||||
|
nexty
|
||||||
|
color
|
||||||
|
#:width width
|
||||||
|
#:with-arrow with-arrow
|
||||||
|
#:style style))))
|
||||||
|
|
||||||
|
;;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 loop ([pct base-pct]
|
||||||
|
[cur-seg fst])
|
||||||
|
(if (not cur-seg)
|
||||||
|
pct
|
||||||
|
(let ([next (segment-next-future-seg cur-seg)])
|
||||||
|
(let* ([next-targ (segment-next-targ-future-seg cur-seg)]
|
||||||
|
[prev-targ (segment-prev-targ-future-seg cur-seg)]
|
||||||
|
[ftl-arrows (if (not next)
|
||||||
|
pct
|
||||||
|
(draw-connection vregion
|
||||||
|
cur-seg
|
||||||
|
next
|
||||||
|
pct
|
||||||
|
(event-connection-line-color)
|
||||||
|
#:width 2))]
|
||||||
|
[prev-targ-arr (if (not prev-targ)
|
||||||
|
ftl-arrows
|
||||||
|
(draw-connection vregion
|
||||||
|
prev-targ
|
||||||
|
cur-seg
|
||||||
|
ftl-arrows
|
||||||
|
(event-target-future-line-color)
|
||||||
|
#:with-arrow #t
|
||||||
|
#:style 'dot))]
|
||||||
|
[next-targ-arr (if (not next-targ)
|
||||||
|
prev-targ-arr
|
||||||
|
(draw-connection vregion
|
||||||
|
cur-seg
|
||||||
|
next-targ
|
||||||
|
prev-targ-arr
|
||||||
|
(event-target-future-line-color)
|
||||||
|
#:with-arrow #t
|
||||||
|
#:style 'dot))])
|
||||||
|
(loop next-targ-arr
|
||||||
|
next)))))))
|
||||||
|
|
||||||
|
;;timeline-bmp-from-log : (listof indexed-fevent) (or uint bool) (or uint bool) -> bitmap%
|
||||||
|
(define (build-timeline-bmp-from-log logs
|
||||||
|
#:max-width [max-width #f]
|
||||||
|
#:max-height [max-height #f])
|
||||||
|
(define vregion (if (or (not max-width) (not max-height))
|
||||||
|
#f
|
||||||
|
(viewable-region 0
|
||||||
|
0
|
||||||
|
max-width
|
||||||
|
max-height)))
|
||||||
|
|
||||||
|
(define p (build-timeline-pict-from-log logs vregion))
|
||||||
|
(pict->bitmap p))
|
||||||
|
|
||||||
|
(define (truncate-bmp bmp width height)
|
||||||
|
(define w (min width (send bmp get-width)))
|
||||||
|
(define h (min height (send bmp get-height)))
|
||||||
|
(let ([buf (make-bytes (* width height 4))])
|
||||||
|
(send bmp
|
||||||
|
get-argb-pixels
|
||||||
|
0
|
||||||
|
0
|
||||||
|
w
|
||||||
|
h
|
||||||
|
buf)
|
||||||
|
(let ([new-b (make-bitmap w h)])
|
||||||
|
(send new-b
|
||||||
|
set-argb-pixels
|
||||||
|
0
|
||||||
|
0
|
||||||
|
w
|
||||||
|
h
|
||||||
|
buf)
|
||||||
|
new-b)))
|
||||||
|
|
||||||
|
;;build-timeline-bmp-with-overlay : (listof indexed-fevent) uint [uint] [uint] -> bitmap%
|
||||||
|
(define (build-timeline-bmp-with-overlay logs
|
||||||
|
event-index
|
||||||
|
#:max-width [max-width #f]
|
||||||
|
#:max-height [max-height #f])
|
||||||
|
(define p (build-timeline-with-overlay logs event-index))
|
||||||
|
(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))))
|
||||||
|
(truncate-bmp (pict->bitmap p) w h))
|
||||||
|
|
||||||
|
|
||||||
|
;;build-timeline-pict-from-trace : trace viewable-region -> pict
|
||||||
|
(define (build-timeline-pict-from-trace tr vregion)
|
||||||
|
(define-values (finfo segments) (calc-segments tr))
|
||||||
|
(build-timeline-pict vregion
|
||||||
|
tr
|
||||||
|
finfo
|
||||||
|
segments))
|
||||||
|
|
||||||
|
;;build-timeline-pict : (or viewable-region #f) trace frame-info (listof segment) -> pict
|
||||||
|
(define (build-timeline-pict vregion tr finfo segments)
|
||||||
|
(define vr (if (not vregion)
|
||||||
|
(viewable-region 0
|
||||||
|
0
|
||||||
|
(frame-info-adjusted-width finfo)
|
||||||
|
(frame-info-adjusted-height finfo))
|
||||||
|
vregion))
|
||||||
|
(for/fold ([pct (frame-bg vr finfo tr)])
|
||||||
|
([seg (in-list (filter (seg-in-vregion vr) segments))])
|
||||||
|
(pin-over pct
|
||||||
|
(- (segment-x seg) (viewable-region-x vr))
|
||||||
|
(- (segment-y seg) (viewable-region-y vr))
|
||||||
|
(pict-for-segment seg))))
|
||||||
|
|
||||||
|
;;build-timeline-pict-from-log : (listof indexed-fevent) viewable-region -> pict
|
||||||
|
(define (build-timeline-pict-from-log logs vregion)
|
||||||
|
(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 tr (build-trace logs))
|
||||||
|
(define-values (finfo segments) (calc-segments tr))
|
||||||
|
(define vregion (viewable-region-from-frame finfo))
|
||||||
|
(define timeline-p (build-timeline-pict vregion
|
||||||
|
tr
|
||||||
|
finfo
|
||||||
|
segments))
|
||||||
|
(define overlay (build-timeline-overlay vregion
|
||||||
|
#f
|
||||||
|
(list-ref segments event-index)
|
||||||
|
finfo
|
||||||
|
tr))
|
||||||
|
(pin-over timeline-p
|
||||||
|
0
|
||||||
|
0
|
||||||
|
overlay))
|
||||||
|
|
||||||
|
;Draws the pict that is layered on top of the exec. timeline canvas
|
||||||
|
;to highlight a specific future's event sequence
|
||||||
|
;;build-timeline-overlay : uint uint (or segment #f) (or segment #f) frame-info trace -> pict
|
||||||
|
(define (build-timeline-overlay vregion tacked hovered finfo tr)
|
||||||
|
(define-values (width height) (values (viewable-region-width vregion)
|
||||||
|
(viewable-region-height vregion)))
|
||||||
|
(define base (blank (viewable-region-width vregion)
|
||||||
|
(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))
|
||||||
|
(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)))
|
||||||
|
p
|
||||||
|
(loop (pin-over p
|
||||||
|
(- (segment-x cur-seg) (viewable-region-x vregion))
|
||||||
|
(- (segment-y cur-seg) (viewable-region-y vregion))
|
||||||
|
(pict-for-segment cur-seg))
|
||||||
|
(segment-next-future-seg cur-seg))))]
|
||||||
|
[aseg-rel-x (- (segment-x seg-with-arrows) (viewable-region-x vregion))]
|
||||||
|
[aseg-rel-y (- (segment-y seg-with-arrows) (viewable-region-y vregion))]
|
||||||
|
[line (pin-over dots
|
||||||
|
(- (+ aseg-rel-x
|
||||||
|
(/ (segment-width seg-with-arrows) 2))
|
||||||
|
2)
|
||||||
|
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)]
|
||||||
|
[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)))
|
||||||
|
2)]
|
||||||
|
[hheight-dif (/ (- (pict-height hmag)
|
||||||
|
(pict-height (segment-p hovered)))
|
||||||
|
2)])
|
||||||
|
(pin-over magnified
|
||||||
|
(- (- (segment-x hovered) (viewable-region-x vregion)) hwidth-dif)
|
||||||
|
(- (- (segment-y hovered) (viewable-region-y vregion)) hheight-dif)
|
||||||
|
hmag))
|
||||||
|
magnified)]
|
||||||
|
[arrows (draw-arrows hover-magnified vregion seg-with-arrows)])
|
||||||
|
arrows)
|
||||||
|
base))
|
||||||
|
|
||||||
|
;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)))
|
||||||
|
|
||||||
|
;Draws a circle for a node on the creation graph
|
||||||
|
;;node-pict : drawable-node -> pict
|
||||||
|
(define (node-pict dnode)
|
||||||
|
(let* ([ndata (node-data (drawable-node-node dnode))]
|
||||||
|
[ntext (if (equal? ndata 'runtime-thread)
|
||||||
|
"RTT"
|
||||||
|
(format "~a" (event-user-data ndata)))])
|
||||||
|
(cc-superimpose (circle-pict (create-graph-node-backcolor)
|
||||||
|
(create-graph-node-strokecolor)
|
||||||
|
(drawable-node-width dnode))
|
||||||
|
(colorize (text ntext) (create-graph-node-forecolor)))))
|
||||||
|
|
||||||
|
;Cache the creation graph pict after first drawing
|
||||||
|
(define cg-pict #f)
|
||||||
|
|
||||||
|
;;draw-creategraph-pict : viewable-region tree-layout -> pict
|
||||||
|
(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 (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)
|
||||||
|
(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 block-ops (sort (hash-keys (rtcall-info-block-hash ri))
|
||||||
|
>
|
||||||
|
#:key (λ (p)
|
||||||
|
(hash-ref (rtcall-info-block-hash ri) p))))
|
||||||
|
(define sync-ops (sort (hash-keys (rtcall-info-sync-hash ri))
|
||||||
|
>
|
||||||
|
#: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))))
|
||||||
|
(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))))
|
||||||
|
(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))]
|
||||||
|
[yacc node-origin-y])
|
||||||
|
([rtcall (in-list (append (map (λ (op) (cons 'block op)) block-ops)
|
||||||
|
(map (λ (op) (cons 'sync op)) sync-ops)))])
|
||||||
|
(define evt-type (car rtcall))
|
||||||
|
(define prim (cdr rtcall))
|
||||||
|
(define the-hash (if (equal? evt-type 'block) (rtcall-info-block-hash ri) (rtcall-info-sync-hash ri)))
|
||||||
|
(define txtp (text-pict (format "~a (~a)"
|
||||||
|
(symbol->string prim)
|
||||||
|
(hash-ref the-hash prim))
|
||||||
|
#:color (get-event-forecolor evt-type)))
|
||||||
|
(define txtbg (rect-pict (get-event-color evt-type)
|
||||||
|
(create-graph-edge-color)
|
||||||
|
(+ (pict-width txtp) (* TOOLTIP-MARGIN 2))
|
||||||
|
(+ (pict-height txtp) (* TOOLTIP-MARGIN 2))
|
||||||
|
#:stroke-width .5))
|
||||||
|
(values
|
||||||
|
(pin-over (draw-line-onto p
|
||||||
|
center-x
|
||||||
|
center-y
|
||||||
|
x
|
||||||
|
yacc
|
||||||
|
(create-graph-edge-color))
|
||||||
|
x
|
||||||
|
yacc
|
||||||
|
(pin-over txtbg
|
||||||
|
TOOLTIP-MARGIN
|
||||||
|
TOOLTIP-MARGIN
|
||||||
|
txtp))
|
||||||
|
(+ yacc (pict-height txtbg) CREATE-GRAPH-PADDING))))
|
||||||
|
pct))))
|
||||||
|
|
||||||
361
collects/racket/future/private/visualizer-gui.rkt
Normal file
361
collects/racket/future/private/visualizer-gui.rkt
Normal file
|
|
@ -0,0 +1,361 @@
|
||||||
|
#lang racket/gui
|
||||||
|
(require framework
|
||||||
|
data/interval-map
|
||||||
|
mrlib/hierlist
|
||||||
|
"visualizer-drawing.rkt"
|
||||||
|
"visualizer-data.rkt"
|
||||||
|
"gui-helpers.rkt"
|
||||||
|
"graph-drawing.rkt"
|
||||||
|
"display.rkt"
|
||||||
|
"constants.rkt")
|
||||||
|
|
||||||
|
(provide (contract-out [show-visualizer (-> void?)])
|
||||||
|
show-visualizer-for-trace)
|
||||||
|
|
||||||
|
;;rebuild-mouse-index : frame-info trace (listof segment) -> interval-map of (range --> interval-map)
|
||||||
|
(define (rebuild-mouse-index frameinfo tr segs)
|
||||||
|
(let ([ym (make-interval-map)])
|
||||||
|
(for ([tl (in-list (trace-proc-timelines tr))])
|
||||||
|
(let* ([xm (make-interval-map)]
|
||||||
|
[midy (calc-row-mid-y (process-timeline-proc-index tl) (frame-info-row-height frameinfo))]
|
||||||
|
[miny (floor (- midy (/ MIN-SEG-WIDTH 2)))]
|
||||||
|
[maxy (floor (+ midy (/ MIN-SEG-WIDTH 2)))])
|
||||||
|
(interval-map-set! ym
|
||||||
|
miny
|
||||||
|
maxy
|
||||||
|
xm)
|
||||||
|
(for ([seg (in-list (filter (λ (s)
|
||||||
|
(= (event-proc-id (segment-event s))
|
||||||
|
(process-timeline-proc-id tl)))
|
||||||
|
segs))])
|
||||||
|
(interval-map-set! xm
|
||||||
|
(segment-x seg)
|
||||||
|
(+ (segment-x seg) (segment-width seg))
|
||||||
|
seg))))
|
||||||
|
ym))
|
||||||
|
|
||||||
|
;;display-evt-details : segment trace message message message message message message -> void
|
||||||
|
(define (display-evt-details seg
|
||||||
|
tr
|
||||||
|
selected-label
|
||||||
|
time-label
|
||||||
|
fid-label
|
||||||
|
pid-label
|
||||||
|
data-label1
|
||||||
|
data-label2)
|
||||||
|
(if seg
|
||||||
|
(let ([evt (segment-event seg)])
|
||||||
|
(send selected-label set-label (format "Event: ~a" (event-type evt)))
|
||||||
|
(send time-label set-label (format "Time: +~a" (get-time-string (- (event-start-time evt)
|
||||||
|
(trace-start-time tr)))))
|
||||||
|
(send fid-label set-label (format "Future ID: ~a" (if (not (event-future-id evt))
|
||||||
|
"None (top-level event)"
|
||||||
|
(event-future-id evt))))
|
||||||
|
(send pid-label set-label (format "Process ID: ~a" (event-proc-id evt)))
|
||||||
|
(case (event-type evt)
|
||||||
|
[(start-work start-0-work)
|
||||||
|
(send data-label1 set-label (format "Duration: ~a" (get-time-string (- (event-end-time evt)
|
||||||
|
(event-start-time evt)))))]
|
||||||
|
[(block sync)
|
||||||
|
(when (= (event-proc-id evt) RT-THREAD-ID)
|
||||||
|
(send data-label1 set-label (format "Primitive: ~a" (symbol->string (event-prim-name evt)))))
|
||||||
|
(when (equal? (event-prim-name evt) 'touch)
|
||||||
|
(send data-label2 set-label (format "Touching future ~a" (event-user-data evt))))
|
||||||
|
(when (equal? (event-prim-name evt) (string->symbol "[allocate memory]"))
|
||||||
|
(send data-label2 set-label (format "Size: ~a" (event-user-data evt))))]
|
||||||
|
[(create)
|
||||||
|
(send data-label1 set-label (format "Creating future ~a" (event-user-data evt)))]
|
||||||
|
[(touch)
|
||||||
|
(send data-label1 set-label (format "Touching future ~a" (event-user-data evt)))]
|
||||||
|
[else
|
||||||
|
(send data-label1 set-label "")]))
|
||||||
|
(begin
|
||||||
|
(send selected-label set-label "")
|
||||||
|
(send time-label set-label "")
|
||||||
|
(send fid-label set-label "")
|
||||||
|
(send pid-label set-label "")
|
||||||
|
(send data-label1 set-label "")
|
||||||
|
(send data-label2 set-label ""))))
|
||||||
|
|
||||||
|
(define (get-window-size)
|
||||||
|
(define-values (screen-w screen-h) (get-display-size))
|
||||||
|
(values (min screen-w DEF-WINDOW-WIDTH)
|
||||||
|
(min screen-h DEF-WINDOW-HEIGHT)))
|
||||||
|
|
||||||
|
(define (show-visualizer-for-trace logs)
|
||||||
|
;TODO: Just set initial sizes, not minimum sizes
|
||||||
|
;If for some reason the log is empty, error?
|
||||||
|
(when (empty? logs)
|
||||||
|
(error 'show-visualizer "No future log messages found."))
|
||||||
|
(define the-trace (build-trace logs))
|
||||||
|
(define-values (winw winh) (get-window-size))
|
||||||
|
;The event segment we are currently mousing over
|
||||||
|
(define hover-seg #f)
|
||||||
|
;The event segment we last clicked on (tacked) -- if any
|
||||||
|
(define tacked-seg #f)
|
||||||
|
;Table for broadcasting selection events to other controls
|
||||||
|
(define listener-table (make-listener-table))
|
||||||
|
|
||||||
|
(define f (new frame:standard-menus%
|
||||||
|
[label "Futures Performance"]
|
||||||
|
[width winw]
|
||||||
|
[height winh]))
|
||||||
|
(define main-panel (new panel:horizontal-dragable%
|
||||||
|
[parent (send f get-area-container)]))
|
||||||
|
(define left-panel (new panel:horizontal-dragable% [parent main-panel]
|
||||||
|
[stretchable-width #t]))
|
||||||
|
(define hlist-ctl (new hierarchical-list%
|
||||||
|
[parent left-panel]
|
||||||
|
[stretchable-width #t]
|
||||||
|
[stretchable-height #t]
|
||||||
|
[style '(control-border)]))
|
||||||
|
|
||||||
|
;Build up items in the hierlist
|
||||||
|
(define block-node (send hlist-ctl new-list))
|
||||||
|
(send (send block-node get-editor) insert "Blocks" 0)
|
||||||
|
(for ([prim (in-list (sort (hash-keys (trace-block-counts the-trace)) > #:key (λ (x) (hash-ref (trace-block-counts the-trace) x))))])
|
||||||
|
(define item (send block-node new-item))
|
||||||
|
(send (send item get-editor) insert (format "~a (~a)" prim (hash-ref (trace-block-counts the-trace) prim))))
|
||||||
|
|
||||||
|
(define sync-node (send hlist-ctl new-list))
|
||||||
|
(send (send sync-node get-editor) insert "Syncs" 0)
|
||||||
|
(for ([prim (in-list (sort (hash-keys (trace-sync-counts the-trace)) > #:key (λ (x) (hash-ref (trace-sync-counts the-trace) x))))])
|
||||||
|
(define item (send sync-node new-item))
|
||||||
|
(send (send item get-editor) insert (format "~a (~a)" prim (hash-ref (trace-sync-counts the-trace) prim))))
|
||||||
|
|
||||||
|
(define right-panel (new panel:vertical-dragable%
|
||||||
|
[parent main-panel]
|
||||||
|
[stretchable-width #t]))
|
||||||
|
(define graphic-panel (new panel:horizontal-dragable%
|
||||||
|
[parent right-panel]
|
||||||
|
[stretchable-height #t]
|
||||||
|
[min-width (inexact->exact (round (* winw .8)))]))
|
||||||
|
(define timeline-container (new vertical-panel%
|
||||||
|
[parent graphic-panel]
|
||||||
|
[stretchable-width #t]
|
||||||
|
[stretchable-height #t]))
|
||||||
|
(define graph-container (new vertical-panel%
|
||||||
|
[parent graphic-panel]
|
||||||
|
[stretchable-width #t]
|
||||||
|
[stretchable-height #t]))
|
||||||
|
(define timeline-header (section-header timeline-container "Execution Timeline" 'horizontal))
|
||||||
|
(define graph-header (section-header graph-container "Future Creation Tree" 'horizontal))
|
||||||
|
|
||||||
|
;Calculate required sizes, mouse hover index, and create timeline pict container
|
||||||
|
(define-values (frameinfo segments) (calc-segments the-trace))
|
||||||
|
(define timeline-mouse-index (rebuild-mouse-index frameinfo the-trace segments))
|
||||||
|
(define timeline-panel (new pict-canvas%
|
||||||
|
[parent timeline-container]
|
||||||
|
[redraw-on-resize #f]
|
||||||
|
[pict-builder (λ (vregion) (build-timeline-pict vregion the-trace frameinfo segments))]
|
||||||
|
[hover-handler (λ (x y vregion)
|
||||||
|
(let ([seg (find-seg-for-coords x y timeline-mouse-index)])
|
||||||
|
(set! hover-seg seg)
|
||||||
|
;(send timeline-panel set-redraw-overlay! #t)
|
||||||
|
(post-event listener-table 'segment-hover timeline-panel seg)))]
|
||||||
|
[click-handler (λ (x y vregion)
|
||||||
|
(let ([seg (find-seg-for-coords x y timeline-mouse-index)])
|
||||||
|
(set! tacked-seg seg)
|
||||||
|
;(send timeline-panel set-redraw-overlay! #t)
|
||||||
|
(post-event listener-table 'segment-click timeline-panel seg)))]
|
||||||
|
[overlay-builder (λ (vregion)
|
||||||
|
(build-timeline-overlay vregion
|
||||||
|
tacked-seg
|
||||||
|
hover-seg
|
||||||
|
frameinfo
|
||||||
|
the-trace))]
|
||||||
|
[min-width 500]
|
||||||
|
[min-height (inexact->exact (round (* winh .7)))]
|
||||||
|
[style '(hscroll vscroll)]
|
||||||
|
[stretchable-width #t]))
|
||||||
|
(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)
|
||||||
|
#:node-width CREATE-GRAPH-NODE-DIAMETER
|
||||||
|
#:padding CREATE-GRAPH-PADDING
|
||||||
|
#:zoom CREATE-GRAPH-DEFAULT-ZOOM))
|
||||||
|
|
||||||
|
(define hovered-graph-node #f)
|
||||||
|
(define creategraph-panel (new pict-canvas%
|
||||||
|
[parent graph-container]
|
||||||
|
[redraw-on-resize #f]
|
||||||
|
[pict-builder (λ (vregion)
|
||||||
|
(build-creategraph-pict vregion
|
||||||
|
creation-tree-layout
|
||||||
|
cg-zoom-level))]
|
||||||
|
[hover-handler (λ (x y vregion)
|
||||||
|
(set! hovered-graph-node
|
||||||
|
(find-node-for-coords x
|
||||||
|
y
|
||||||
|
(graph-layout-nodes creation-tree-layout))))]
|
||||||
|
[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)
|
||||||
|
(graph-overlay-pict hovered-graph-node
|
||||||
|
the-trace
|
||||||
|
creation-tree-layout
|
||||||
|
vregion))]
|
||||||
|
[min-width 500]
|
||||||
|
[min-height 500]
|
||||||
|
[style '(hscroll vscroll)]
|
||||||
|
[stretchable-width #t]))
|
||||||
|
|
||||||
|
(send creategraph-panel show-scrollbars #t #t)
|
||||||
|
(send creategraph-panel init-auto-scrollbars
|
||||||
|
(inexact->exact (floor (graph-layout-width creation-tree-layout)))
|
||||||
|
(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%
|
||||||
|
[parent graph-container]
|
||||||
|
[stretchable-width #t]
|
||||||
|
[stretchable-height #f]
|
||||||
|
[style '(border)]))
|
||||||
|
(define cg-zoom-level CREATE-GRAPH-DEFAULT-ZOOM)
|
||||||
|
|
||||||
|
;;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 redraw-everything))
|
||||||
|
|
||||||
|
(define zoom-slider (new slider%
|
||||||
|
[parent graph-footer]
|
||||||
|
[label "Zoom:"]
|
||||||
|
[min-value CREATE-GRAPH-MIN-ZOOM]
|
||||||
|
[max-value CREATE-GRAPH-MAX-ZOOM]
|
||||||
|
[init-value CREATE-GRAPH-DEFAULT-ZOOM]
|
||||||
|
[style '(horizontal plain)]
|
||||||
|
[callback on-zoom]))
|
||||||
|
(define bottom-panel (new horizontal-panel%
|
||||||
|
[parent right-panel]
|
||||||
|
[style '(border)]
|
||||||
|
[stretchable-height #t]))
|
||||||
|
|
||||||
|
(define left-container (new horizontal-panel%
|
||||||
|
[parent bottom-panel]
|
||||||
|
[style '(border)]
|
||||||
|
[stretchable-height #t]))
|
||||||
|
(define mid-container (new horizontal-panel%
|
||||||
|
[parent bottom-panel]
|
||||||
|
[stretchable-height #t]))
|
||||||
|
(define right-container (new horizontal-panel%
|
||||||
|
[parent bottom-panel]
|
||||||
|
[stretchable-height #t]))
|
||||||
|
(define left-bot-header (section-header left-container "Execution Statistics" 'vertical))
|
||||||
|
(define left-bot-panel (new vertical-panel%
|
||||||
|
[parent left-container]
|
||||||
|
[stretchable-height #t]))
|
||||||
|
(define mid-bot-header (section-header mid-container "Event Details" 'vertical))
|
||||||
|
(define mid-bot-panel (new vertical-panel%
|
||||||
|
[parent mid-container]
|
||||||
|
[stretchable-height #t]))
|
||||||
|
(define right-bot-header (section-header right-container "Log Viewer" 'vertical))
|
||||||
|
(define right-bot-panel (new vertical-panel%
|
||||||
|
[parent right-container]
|
||||||
|
[stretchable-height #t]))
|
||||||
|
|
||||||
|
(bold-label left-bot-panel "Program Statistics")
|
||||||
|
(define runtime-label (label left-bot-panel
|
||||||
|
(format "Real time: ~a" (get-time-string (trace-real-time the-trace)))))
|
||||||
|
(define fcount-label (label left-bot-panel
|
||||||
|
(format "Total futures: ~a" (trace-num-futures the-trace))))
|
||||||
|
(define blocks-label (label left-bot-panel
|
||||||
|
(format "Barricades: ~a" (trace-num-blocks the-trace))))
|
||||||
|
(define syncs-label (label left-bot-panel
|
||||||
|
(format "Syncs: ~a" (trace-num-syncs the-trace))))
|
||||||
|
|
||||||
|
;Selected-event-specific labels
|
||||||
|
(define hover-label (mt-bold-label mid-bot-panel))
|
||||||
|
(define hover-time-label (mt-label mid-bot-panel))
|
||||||
|
(define hover-fid-label (mt-label mid-bot-panel))
|
||||||
|
(define hover-pid-label (mt-label mid-bot-panel))
|
||||||
|
(define hover-data-label1 (mt-label mid-bot-panel))
|
||||||
|
(define hover-data-label2 (mt-label mid-bot-panel))
|
||||||
|
|
||||||
|
(define tacked-label (mt-bold-label mid-bot-panel))
|
||||||
|
(define tacked-time-lbl (mt-label mid-bot-panel))
|
||||||
|
(define tacked-fid-lbl (mt-label mid-bot-panel))
|
||||||
|
(define tacked-pid-lbl (mt-label mid-bot-panel))
|
||||||
|
(define tacked-data-lbl (mt-label mid-bot-panel))
|
||||||
|
(define tacked-data-lbl2 (mt-label mid-bot-panel))
|
||||||
|
|
||||||
|
(define (update-event-details-panel seg)
|
||||||
|
(display-evt-details hover-seg
|
||||||
|
the-trace
|
||||||
|
hover-label
|
||||||
|
hover-time-label
|
||||||
|
hover-fid-label
|
||||||
|
hover-pid-label
|
||||||
|
hover-data-label1
|
||||||
|
hover-data-label2)
|
||||||
|
(display-evt-details tacked-seg
|
||||||
|
the-trace
|
||||||
|
tacked-label
|
||||||
|
tacked-time-lbl
|
||||||
|
tacked-fid-lbl
|
||||||
|
tacked-pid-lbl
|
||||||
|
tacked-data-lbl
|
||||||
|
tacked-data-lbl2))
|
||||||
|
|
||||||
|
;Wire up events so selection, etc. in one panel is communicated to others
|
||||||
|
(define (on-future-selected fid)
|
||||||
|
0)
|
||||||
|
|
||||||
|
(define (on-segment-hover seg)
|
||||||
|
0)
|
||||||
|
|
||||||
|
(define (on-segment-click seg)
|
||||||
|
0)
|
||||||
|
|
||||||
|
(define (on-segment-unclick seg)
|
||||||
|
0)
|
||||||
|
|
||||||
|
;Wire up event handlers for selection, etc.
|
||||||
|
(add-receiver listener-table 'future-selected timeline-panel on-future-selected)
|
||||||
|
(add-receiver listener-table 'segment-hover creategraph-panel on-segment-hover)
|
||||||
|
(add-receiver listener-table 'segment-click creategraph-panel on-segment-click)
|
||||||
|
(add-receiver listener-table 'segment-click mid-bot-panel update-event-details-panel)
|
||||||
|
(add-receiver listener-table 'segment-hover mid-bot-panel update-event-details-panel)
|
||||||
|
(add-receiver listener-table 'segment-unclick mid-bot-panel update-event-details-panel)
|
||||||
|
(add-receiver listener-table 'segment-unclick creategraph-panel on-segment-unclick)
|
||||||
|
|
||||||
|
;Additional menus/items
|
||||||
|
(define showing-create-graph #t)
|
||||||
|
(define view-menu (new menu% [label "View"] [parent (send f get-menu-bar)]))
|
||||||
|
(new menu-item%
|
||||||
|
[label "Hide Creation Tree"]
|
||||||
|
[parent view-menu]
|
||||||
|
[callback (λ (item evt)
|
||||||
|
(if showing-create-graph
|
||||||
|
(begin
|
||||||
|
(send graphic-panel delete-child graph-container)
|
||||||
|
(send item set-label "Show Creation Tree"))
|
||||||
|
(begin
|
||||||
|
(send graphic-panel add-child graph-container)
|
||||||
|
(send item set-label "Hide Creation Tree")))
|
||||||
|
(set! showing-create-graph (not showing-create-graph)))])
|
||||||
|
|
||||||
|
(send f show #t))
|
||||||
|
|
||||||
|
(define (show-visualizer)
|
||||||
|
(show-visualizer-for-trace (raw-log-output 0)))
|
||||||
5
collects/racket/future/visualizer.rkt
Normal file
5
collects/racket/future/visualizer.rkt
Normal file
|
|
@ -0,0 +1,5 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require "private/visualizer-gui.rkt"
|
||||||
|
"private/visualizer-data.rkt")
|
||||||
|
(provide start-performance-tracking!
|
||||||
|
show-visualizer)
|
||||||
|
|
@ -1,7 +1,12 @@
|
||||||
#lang scribble/doc
|
#lang scribble/doc
|
||||||
@(require scribble/manual "guide-utils.rkt"
|
@(require scribble/manual scribble/eval "guide-utils.rkt"
|
||||||
(for-label racket/flonum racket/future))
|
(for-label racket/flonum racket/future))
|
||||||
|
|
||||||
|
@(define future-eval (make-base-eval))
|
||||||
|
@(interaction-eval #:eval future-eval (require racket/future
|
||||||
|
racket/future/private/visualizer-drawing
|
||||||
|
racket/future/private/visualizer-data))
|
||||||
|
|
||||||
@title[#:tag "effective-futures"]{Parallelism with Futures}
|
@title[#:tag "effective-futures"]{Parallelism with Futures}
|
||||||
|
|
||||||
The @racketmodname[racket/future] library provides support for
|
The @racketmodname[racket/future] library provides support for
|
||||||
|
|
@ -56,9 +61,12 @@ l2)] becomes available about the same time that it is demanded by
|
||||||
@racket[(touch f)].
|
@racket[(touch f)].
|
||||||
|
|
||||||
Futures run in parallel as long as they can do so safely, but the
|
Futures run in parallel as long as they can do so safely, but the
|
||||||
notion of ``safe'' for parallelism is inherently tied to the system
|
notion of ``future safe'' is inherently tied to the
|
||||||
implementation. The distinction between ``safe'' and ``unsafe''
|
implementation. The distinction between ``future safe'' and ``future unsafe''
|
||||||
operations may be far from apparent at the level of a Racket program.
|
operations may be far from apparent at the level of a Racket program.
|
||||||
|
The remainder of this section works through an example to illustrate
|
||||||
|
this distinction and to show how to use the future visualizer
|
||||||
|
can help shed light on it.
|
||||||
|
|
||||||
Consider the following core of a Mandelbrot-set computation:
|
Consider the following core of a Mandelbrot-set computation:
|
||||||
|
|
||||||
|
|
@ -72,10 +80,10 @@ Consider the following core of a Mandelbrot-set computation:
|
||||||
(let ([zrq (* zr zr)]
|
(let ([zrq (* zr zr)]
|
||||||
[ziq (* zi zi)])
|
[ziq (* zi zi)])
|
||||||
(cond
|
(cond
|
||||||
[(> (+ zrq ziq) 4.0) i]
|
[(> (+ zrq ziq) 4) i]
|
||||||
[else (loop (add1 i)
|
[else (loop (add1 i)
|
||||||
(+ (- zrq ziq) cr)
|
(+ (- zrq ziq) cr)
|
||||||
(+ (* 2.0 zr zi) ci))]))))))
|
(+ (* 2 zr zi) ci))]))))))
|
||||||
]
|
]
|
||||||
|
|
||||||
The expressions @racket[(mandelbrot 10000000 62 500 1000)] and
|
The expressions @racket[(mandelbrot 10000000 62 500 1000)] and
|
||||||
|
|
@ -97,35 +105,332 @@ Unfortunately, attempting to run the two computations in parallel with
|
||||||
(touch f)))
|
(touch f)))
|
||||||
]
|
]
|
||||||
|
|
||||||
One problem is that the @racket[*] and @racket[/] operations in the
|
To see why, use the @racketmodname[racket/future/visualizer], like this:
|
||||||
first two lines of @racket[mandelbrot] involve a mixture of exact and
|
|
||||||
inexact real numbers. Such mixtures typically trigger a slow path in
|
|
||||||
execution, and the general slow path is not safe for
|
|
||||||
parallelism. Consequently, the future created in this example is
|
|
||||||
almost immediately suspended, and it cannot resume until
|
|
||||||
@racket[touch] is called.
|
|
||||||
|
|
||||||
Changing the first two lines of @racket[mandelbrot] addresses that
|
@racketblock[
|
||||||
first the problem:
|
(require racket/future/visualizer)
|
||||||
|
(start-performance-tracking!)
|
||||||
|
|
||||||
|
(let ([f (future (lambda () (mandelbrot 10000000 62 501 1000)))])
|
||||||
|
(list (mandelbrot 10000000 62 500 1000)
|
||||||
|
(touch f)))
|
||||||
|
|
||||||
|
(show-visualizer)]
|
||||||
|
|
||||||
|
This opens a window showing a graphical view of a trace of the computation.
|
||||||
|
The upper-left portion of the window contains an execution timeline:
|
||||||
|
|
||||||
|
@(interaction-eval
|
||||||
|
#:eval future-eval
|
||||||
|
(define bad-log
|
||||||
|
(list (indexed-fevent 0 '#s(future-event #f 0 create 1334778390997.936 #f 1))
|
||||||
|
(indexed-fevent 1 '#s(future-event 1 1 start-work 1334778390998.137 #f #f))
|
||||||
|
(indexed-fevent 2 '#s(future-event 1 1 sync 1334778390998.145 #f #f))
|
||||||
|
(indexed-fevent 3 '#s(future-event 1 0 sync 1334778391001.616 [allocate memory] #f))
|
||||||
|
(indexed-fevent 4 '#s(future-event 1 0 result 1334778391001.629 #f #f))
|
||||||
|
(indexed-fevent 5 '#s(future-event 1 1 result 1334778391001.643 #f #f))
|
||||||
|
(indexed-fevent 6 '#s(future-event 1 1 block 1334778391001.653 #f #f))
|
||||||
|
(indexed-fevent 7 '#s(future-event 1 1 suspend 1334778391001.658 #f #f))
|
||||||
|
(indexed-fevent 8 '#s(future-event 1 1 end-work 1334778391001.658 #f #f))
|
||||||
|
(indexed-fevent 9 '#s(future-event 1 0 block 1334778392134.226 > #f))
|
||||||
|
(indexed-fevent 10 '#s(future-event 1 0 result 1334778392134.241 #f #f))
|
||||||
|
(indexed-fevent 11 '#s(future-event 1 1 start-work 1334778392134.254 #f #f))
|
||||||
|
(indexed-fevent 12 '#s(future-event 1 1 sync 1334778392134.339 #f #f))
|
||||||
|
(indexed-fevent 13 '#s(future-event 1 0 sync 1334778392134.375 [allocate memory] #f))
|
||||||
|
(indexed-fevent 14 '#s(future-event 1 0 result 1334778392134.38 #f #f))
|
||||||
|
(indexed-fevent 15 '#s(future-event 1 1 result 1334778392134.387 #f #f))
|
||||||
|
(indexed-fevent 16 '#s(future-event 1 1 block 1334778392134.39 #f #f))
|
||||||
|
(indexed-fevent 17 '#s(future-event 1 1 suspend 1334778392134.391 #f #f))
|
||||||
|
(indexed-fevent 18 '#s(future-event 1 1 end-work 1334778392134.391 #f #f))
|
||||||
|
(indexed-fevent 19 '#s(future-event 1 0 touch-pause 1334778392134.432 #f #f))
|
||||||
|
(indexed-fevent 20 '#s(future-event 1 0 touch-resume 1334778392134.433 #f #f))
|
||||||
|
(indexed-fevent 21 '#s(future-event 1 0 block 1334778392134.533 * #f))
|
||||||
|
(indexed-fevent 22 '#s(future-event 1 0 result 1334778392134.537 #f #f))
|
||||||
|
(indexed-fevent 23 '#s(future-event 1 2 start-work 1334778392134.568 #f #f))
|
||||||
|
(indexed-fevent 24 '#s(future-event 1 2 sync 1334778392134.57 #f #f))
|
||||||
|
(indexed-fevent 25 '#s(future-event 1 0 touch-pause 1334778392134.587 #f #f))
|
||||||
|
(indexed-fevent 26 '#s(future-event 1 0 touch-resume 1334778392134.587 #f #f))
|
||||||
|
(indexed-fevent 27 '#s(future-event 1 0 block 1334778392134.6 [allocate memory] #f))
|
||||||
|
(indexed-fevent 28 '#s(future-event 1 0 result 1334778392134.604 #f #f))
|
||||||
|
(indexed-fevent 29 '#s(future-event 1 2 result 1334778392134.627 #f #f))
|
||||||
|
(indexed-fevent 30 '#s(future-event 1 2 block 1334778392134.629 #f #f))
|
||||||
|
(indexed-fevent 31 '#s(future-event 1 2 suspend 1334778392134.632 #f #f))
|
||||||
|
(indexed-fevent 32 '#s(future-event 1 2 end-work 1334778392134.633 #f #f))
|
||||||
|
(indexed-fevent 33 '#s(future-event 1 0 touch-pause 1334778392134.64 #f #f))
|
||||||
|
(indexed-fevent 34 '#s(future-event 1 0 touch-resume 1334778392134.64 #f #f))
|
||||||
|
(indexed-fevent 35 '#s(future-event 1 0 block 1334778392134.663 > #f))
|
||||||
|
(indexed-fevent 36 '#s(future-event 1 0 result 1334778392134.666 #f #f))
|
||||||
|
(indexed-fevent 37 '#s(future-event 1 1 start-work 1334778392134.673 #f #f))
|
||||||
|
(indexed-fevent 38 '#s(future-event 1 1 block 1334778392134.676 #f #f))
|
||||||
|
(indexed-fevent 39 '#s(future-event 1 1 suspend 1334778392134.677 #f #f))
|
||||||
|
(indexed-fevent 40 '#s(future-event 1 1 end-work 1334778392134.677 #f #f))
|
||||||
|
(indexed-fevent 41 '#s(future-event 1 0 touch-pause 1334778392134.704 #f #f))
|
||||||
|
(indexed-fevent 42 '#s(future-event 1 0 touch-resume 1334778392134.704 #f #f))
|
||||||
|
(indexed-fevent 43 '#s(future-event 1 0 block 1334778392134.727 * #f))
|
||||||
|
(indexed-fevent 44 '#s(future-event 1 0 result 1334778392134.73 #f #f))
|
||||||
|
(indexed-fevent 45 '#s(future-event 1 2 start-work 1334778392134.737 #f #f))
|
||||||
|
(indexed-fevent 46 '#s(future-event 1 2 block 1334778392134.739 #f #f))
|
||||||
|
(indexed-fevent 47 '#s(future-event 1 2 suspend 1334778392134.74 #f #f))
|
||||||
|
(indexed-fevent 48 '#s(future-event 1 2 end-work 1334778392134.741 #f #f))
|
||||||
|
(indexed-fevent 49 '#s(future-event 1 0 touch-pause 1334778392134.767 #f #f))
|
||||||
|
(indexed-fevent 50 '#s(future-event 1 0 touch-resume 1334778392134.767 #f #f))
|
||||||
|
(indexed-fevent 51 '#s(future-event 1 0 block 1334778392134.79 > #f))
|
||||||
|
(indexed-fevent 52 '#s(future-event 1 0 result 1334778392134.793 #f #f))
|
||||||
|
(indexed-fevent 53 '#s(future-event 1 1 start-work 1334778392134.799 #f #f))
|
||||||
|
(indexed-fevent 54 '#s(future-event 1 1 block 1334778392134.801 #f #f))
|
||||||
|
(indexed-fevent 55 '#s(future-event 1 1 suspend 1334778392134.802 #f #f))
|
||||||
|
(indexed-fevent 56 '#s(future-event 1 1 end-work 1334778392134.803 #f #f))
|
||||||
|
(indexed-fevent 57 '#s(future-event 1 0 touch-pause 1334778392134.832 #f #f))
|
||||||
|
(indexed-fevent 58 '#s(future-event 1 0 touch-resume 1334778392134.832 #f #f))
|
||||||
|
(indexed-fevent 59 '#s(future-event 1 0 block 1334778392134.854 * #f))
|
||||||
|
(indexed-fevent 60 '#s(future-event 1 0 result 1334778392134.858 #f #f))
|
||||||
|
(indexed-fevent 61 '#s(future-event 1 2 start-work 1334778392134.864 #f #f))
|
||||||
|
(indexed-fevent 62 '#s(future-event 1 2 block 1334778392134.876 #f #f))
|
||||||
|
(indexed-fevent 63 '#s(future-event 1 2 suspend 1334778392134.877 #f #f))
|
||||||
|
(indexed-fevent 64 '#s(future-event 1 2 end-work 1334778392134.882 #f #f))
|
||||||
|
(indexed-fevent 65 '#s(future-event 1 0 touch-pause 1334778392134.918 #f #f))
|
||||||
|
(indexed-fevent 66 '#s(future-event 1 0 touch-resume 1334778392134.918 #f #f))
|
||||||
|
(indexed-fevent 67 '#s(future-event 1 0 block 1334778392134.94 > #f))
|
||||||
|
(indexed-fevent 68 '#s(future-event 1 0 result 1334778392134.943 #f #f))
|
||||||
|
(indexed-fevent 69 '#s(future-event 1 1 start-work 1334778392134.949 #f #f))
|
||||||
|
(indexed-fevent 70 '#s(future-event 1 1 block 1334778392134.952 #f #f))
|
||||||
|
(indexed-fevent 71 '#s(future-event 1 1 suspend 1334778392134.953 #f #f))
|
||||||
|
(indexed-fevent 72 '#s(future-event 1 1 end-work 1334778392134.96 #f #f))
|
||||||
|
(indexed-fevent 73 '#s(future-event 1 0 touch-pause 1334778392134.991 #f #f))
|
||||||
|
(indexed-fevent 74 '#s(future-event 1 0 touch-resume 1334778392134.991 #f #f))
|
||||||
|
(indexed-fevent 75 '#s(future-event 1 0 block 1334778392135.013 * #f))
|
||||||
|
(indexed-fevent 76 '#s(future-event 1 0 result 1334778392135.016 #f #f))
|
||||||
|
(indexed-fevent 77 '#s(future-event 1 2 start-work 1334778392135.027 #f #f))
|
||||||
|
(indexed-fevent 78 '#s(future-event 1 2 block 1334778392135.033 #f #f))
|
||||||
|
(indexed-fevent 79 '#s(future-event 1 2 suspend 1334778392135.034 #f #f))
|
||||||
|
(indexed-fevent 80 '#s(future-event 1 2 end-work 1334778392135.04 #f #f))
|
||||||
|
(indexed-fevent 81 '#s(future-event 1 0 touch-pause 1334778392135.075 #f #f))
|
||||||
|
(indexed-fevent 82 '#s(future-event 1 0 touch-resume 1334778392135.075 #f #f))
|
||||||
|
(indexed-fevent 83 '#s(future-event 1 0 block 1334778392135.098 > #f))
|
||||||
|
(indexed-fevent 84 '#s(future-event 1 0 result 1334778392135.101 #f #f))
|
||||||
|
(indexed-fevent 85 '#s(future-event 1 1 start-work 1334778392135.107 #f #f))
|
||||||
|
(indexed-fevent 86 '#s(future-event 1 1 block 1334778392135.117 #f #f))
|
||||||
|
(indexed-fevent 87 '#s(future-event 1 1 suspend 1334778392135.118 #f #f))
|
||||||
|
(indexed-fevent 88 '#s(future-event 1 1 end-work 1334778392135.123 #f #f))
|
||||||
|
(indexed-fevent 89 '#s(future-event 1 0 touch-pause 1334778392135.159 #f #f))
|
||||||
|
(indexed-fevent 90 '#s(future-event 1 0 touch-resume 1334778392135.159 #f #f))
|
||||||
|
(indexed-fevent 91 '#s(future-event 1 0 block 1334778392135.181 * #f))
|
||||||
|
(indexed-fevent 92 '#s(future-event 1 0 result 1334778392135.184 #f #f))
|
||||||
|
(indexed-fevent 93 '#s(future-event 1 2 start-work 1334778392135.19 #f #f))
|
||||||
|
(indexed-fevent 94 '#s(future-event 1 2 block 1334778392135.191 #f #f))
|
||||||
|
(indexed-fevent 95 '#s(future-event 1 2 suspend 1334778392135.192 #f #f))
|
||||||
|
(indexed-fevent 96 '#s(future-event 1 2 end-work 1334778392135.192 #f #f))
|
||||||
|
(indexed-fevent 97 '#s(future-event 1 0 touch-pause 1334778392135.221 #f #f))
|
||||||
|
(indexed-fevent 98 '#s(future-event 1 0 touch-resume 1334778392135.221 #f #f))
|
||||||
|
(indexed-fevent 99 '#s(future-event 1 0 block 1334778392135.243 > #f))
|
||||||
|
)))
|
||||||
|
|
||||||
|
@interaction-eval-show[
|
||||||
|
#:eval future-eval
|
||||||
|
(build-timeline-bmp-from-log bad-log
|
||||||
|
#:max-width 600
|
||||||
|
#:max-height 300)
|
||||||
|
]
|
||||||
|
|
||||||
|
Each horizontal row represents an OS-level thread, and the colored
|
||||||
|
dots represent important events in the execution of the program (they are
|
||||||
|
color-coded to distinguish one event type from another). The upper-left blue
|
||||||
|
dot in the timeline represents the future's creation. The future
|
||||||
|
executes for a brief period (represented by a green bar in the second line) on thread
|
||||||
|
1, and then pauses to allow the runtime thread to perform a future-unsafe operation.
|
||||||
|
|
||||||
|
In the Racket implementation, future-unsafe operations fall into one of two categories.
|
||||||
|
A @deftech{blocking} operation halts the evaluation of the future, and will not allow
|
||||||
|
it to continue until it is touched. After the operation completes within @racket[touch],
|
||||||
|
the remainder of the future's work will be evaluated sequentially by the runtime
|
||||||
|
thread. A @deftech{synchronized} operation also halts the future, but the runtime thread
|
||||||
|
may perform the operation at any time and, once completed, the future may continue
|
||||||
|
running in parallel. Memory allocation and JIT compilation are two common examples
|
||||||
|
of synchronized operations.
|
||||||
|
|
||||||
|
In the timeline, we see an orange dot just to the right of the green bar on thread 1 --
|
||||||
|
this dot represents a synchronized operation (memory allocation). The first orange
|
||||||
|
dot on thread 0 shows that the runtime thread performed the allocation shortly after
|
||||||
|
the future paused. A short time later, the future halts on a blocking operation
|
||||||
|
(the first red dot) and must wait until the @racket[touch] for it to be evaluated
|
||||||
|
(slightly after the 1049ms mark).
|
||||||
|
|
||||||
|
When you move your mouse over an event, the visualizer shows you
|
||||||
|
detailed information about the event and draws arrows
|
||||||
|
connecting all of the events in the corresponding future.
|
||||||
|
This image shows those connections for our future.
|
||||||
|
|
||||||
|
@interaction-eval-show[
|
||||||
|
#:eval future-eval
|
||||||
|
(build-timeline-bmp-with-overlay bad-log
|
||||||
|
6
|
||||||
|
#:max-width 600
|
||||||
|
#:max-height 300)
|
||||||
|
]
|
||||||
|
|
||||||
|
The dotted orange line connects the first event in the future to
|
||||||
|
the future that created it, and the purple lines connect adjacent
|
||||||
|
events within the future.
|
||||||
|
|
||||||
|
The reason that we see no parallelism is that the @racket[<] and @racket[*] operations
|
||||||
|
in the lower portion of the loop in @racket[mandelbrot] involve a mixture of
|
||||||
|
floating-point and fixed (integer) values. Such mixtures typically trigger a slow
|
||||||
|
path in execution, and the general slow path will usually be blocking.
|
||||||
|
|
||||||
|
Changing constants to be floating-points numbers in @racket[mandelbrot] addresses that
|
||||||
|
first problem:
|
||||||
|
|
||||||
@racketblock[
|
@racketblock[
|
||||||
(define (mandelbrot iterations x y n)
|
(define (mandelbrot iterations x y n)
|
||||||
(let ([ci (- (/ (* 2.0 (->fl y)) (->fl n)) 1.0)]
|
(let ([ci (- (/ (* 2.0 y) n) 1.0)]
|
||||||
[cr (- (/ (* 2.0 (->fl x)) (->fl n)) 1.5)])
|
[cr (- (/ (* 2.0 x) n) 1.5)])
|
||||||
....))
|
(let loop ([i 0] [zr 0.0] [zi 0.0])
|
||||||
|
(if (> i iterations)
|
||||||
|
i
|
||||||
|
(let ([zrq (* zr zr)]
|
||||||
|
[ziq (* zi zi)])
|
||||||
|
(cond
|
||||||
|
[(> (+ zrq ziq) 4.0) i]
|
||||||
|
[else (loop (add1 i)
|
||||||
|
(+ (- zrq ziq) cr)
|
||||||
|
(+ (* 2.0 zr zi) ci))]))))))
|
||||||
]
|
]
|
||||||
|
|
||||||
With that change, @racket[mandelbrot] computations can run in
|
With that change, @racket[mandelbrot] computations can run in
|
||||||
parallel. Nevertheless, performance still does not improve. The
|
parallel. Nevertheless, we still see a special type of
|
||||||
problem is that most every arithmetic operation in this example
|
slow-path operation limiting our parallelism (orange dots):
|
||||||
produces an inexact number whose storage must be allocated. Especially
|
|
||||||
frequent allocation triggers communication between parallel tasks that
|
@interaction-eval[
|
||||||
defeats any performance improvement.
|
#:eval future-eval
|
||||||
|
(define better-log
|
||||||
|
(list (indexed-fevent 0 '#s(future-event #f 0 create 1334779296782.22 #f 2))
|
||||||
|
(indexed-fevent 1 '#s(future-event 2 2 start-work 1334779296782.265 #f #f))
|
||||||
|
(indexed-fevent 2 '#s(future-event 2 2 sync 1334779296782.378 #f #f))
|
||||||
|
(indexed-fevent 3 '#s(future-event 2 0 sync 1334779296795.582 [allocate memory] #f))
|
||||||
|
(indexed-fevent 4 '#s(future-event 2 0 result 1334779296795.587 #f #f))
|
||||||
|
(indexed-fevent 5 '#s(future-event 2 2 result 1334779296795.6 #f #f))
|
||||||
|
(indexed-fevent 6 '#s(future-event 2 2 sync 1334779296795.689 #f #f))
|
||||||
|
(indexed-fevent 7 '#s(future-event 2 0 sync 1334779296795.807 [allocate memory] #f))
|
||||||
|
(indexed-fevent 8 '#s(future-event 2 0 result 1334779296795.812 #f #f))
|
||||||
|
(indexed-fevent 9 '#s(future-event 2 2 result 1334779296795.818 #f #f))
|
||||||
|
(indexed-fevent 10 '#s(future-event 2 2 sync 1334779296795.827 #f #f))
|
||||||
|
(indexed-fevent 11 '#s(future-event 2 0 sync 1334779296806.627 [allocate memory] #f))
|
||||||
|
(indexed-fevent 12 '#s(future-event 2 0 result 1334779296806.635 #f #f))
|
||||||
|
(indexed-fevent 13 '#s(future-event 2 2 result 1334779296806.646 #f #f))
|
||||||
|
(indexed-fevent 14 '#s(future-event 2 2 sync 1334779296806.879 #f #f))
|
||||||
|
(indexed-fevent 15 '#s(future-event 2 0 sync 1334779296806.994 [allocate memory] #f))
|
||||||
|
(indexed-fevent 16 '#s(future-event 2 0 result 1334779296806.999 #f #f))
|
||||||
|
(indexed-fevent 17 '#s(future-event 2 2 result 1334779296807.007 #f #f))
|
||||||
|
(indexed-fevent 18 '#s(future-event 2 2 sync 1334779296807.023 #f #f))
|
||||||
|
(indexed-fevent 19 '#s(future-event 2 0 sync 1334779296814.198 [allocate memory] #f))
|
||||||
|
(indexed-fevent 20 '#s(future-event 2 0 result 1334779296814.206 #f #f))
|
||||||
|
(indexed-fevent 21 '#s(future-event 2 2 result 1334779296814.221 #f #f))
|
||||||
|
(indexed-fevent 22 '#s(future-event 2 2 sync 1334779296814.29 #f #f))
|
||||||
|
(indexed-fevent 23 '#s(future-event 2 0 sync 1334779296820.796 [allocate memory] #f))
|
||||||
|
(indexed-fevent 24 '#s(future-event 2 0 result 1334779296820.81 #f #f))
|
||||||
|
(indexed-fevent 25 '#s(future-event 2 2 result 1334779296820.835 #f #f))
|
||||||
|
(indexed-fevent 26 '#s(future-event 2 2 sync 1334779296821.089 #f #f))
|
||||||
|
(indexed-fevent 27 '#s(future-event 2 0 sync 1334779296825.217 [allocate memory] #f))
|
||||||
|
(indexed-fevent 28 '#s(future-event 2 0 result 1334779296825.226 #f #f))
|
||||||
|
(indexed-fevent 29 '#s(future-event 2 2 result 1334779296825.242 #f #f))
|
||||||
|
(indexed-fevent 30 '#s(future-event 2 2 sync 1334779296825.305 #f #f))
|
||||||
|
(indexed-fevent 31 '#s(future-event 2 0 sync 1334779296832.541 [allocate memory] #f))
|
||||||
|
(indexed-fevent 32 '#s(future-event 2 0 result 1334779296832.549 #f #f))
|
||||||
|
(indexed-fevent 33 '#s(future-event 2 2 result 1334779296832.562 #f #f))
|
||||||
|
(indexed-fevent 34 '#s(future-event 2 2 sync 1334779296832.667 #f #f))
|
||||||
|
(indexed-fevent 35 '#s(future-event 2 0 sync 1334779296836.269 [allocate memory] #f))
|
||||||
|
(indexed-fevent 36 '#s(future-event 2 0 result 1334779296836.278 #f #f))
|
||||||
|
(indexed-fevent 37 '#s(future-event 2 2 result 1334779296836.326 #f #f))
|
||||||
|
(indexed-fevent 38 '#s(future-event 2 2 sync 1334779296836.396 #f #f))
|
||||||
|
(indexed-fevent 39 '#s(future-event 2 0 sync 1334779296843.481 [allocate memory] #f))
|
||||||
|
(indexed-fevent 40 '#s(future-event 2 0 result 1334779296843.49 #f #f))
|
||||||
|
(indexed-fevent 41 '#s(future-event 2 2 result 1334779296843.501 #f #f))
|
||||||
|
(indexed-fevent 42 '#s(future-event 2 2 sync 1334779296843.807 #f #f))
|
||||||
|
(indexed-fevent 43 '#s(future-event 2 0 sync 1334779296847.291 [allocate memory] #f))
|
||||||
|
(indexed-fevent 44 '#s(future-event 2 0 result 1334779296847.3 #f #f))
|
||||||
|
(indexed-fevent 45 '#s(future-event 2 2 result 1334779296847.312 #f #f))
|
||||||
|
(indexed-fevent 46 '#s(future-event 2 2 sync 1334779296847.375 #f #f))
|
||||||
|
(indexed-fevent 47 '#s(future-event 2 0 sync 1334779296854.487 [allocate memory] #f))
|
||||||
|
(indexed-fevent 48 '#s(future-event 2 0 result 1334779296854.495 #f #f))
|
||||||
|
(indexed-fevent 49 '#s(future-event 2 2 result 1334779296854.507 #f #f))
|
||||||
|
(indexed-fevent 50 '#s(future-event 2 2 sync 1334779296854.656 #f #f))
|
||||||
|
(indexed-fevent 51 '#s(future-event 2 0 sync 1334779296857.374 [allocate memory] #f))
|
||||||
|
(indexed-fevent 52 '#s(future-event 2 0 result 1334779296857.383 #f #f))
|
||||||
|
(indexed-fevent 53 '#s(future-event 2 2 result 1334779296857.421 #f #f))
|
||||||
|
(indexed-fevent 54 '#s(future-event 2 2 sync 1334779296857.488 #f #f))
|
||||||
|
(indexed-fevent 55 '#s(future-event 2 0 sync 1334779296869.919 [allocate memory] #f))
|
||||||
|
(indexed-fevent 56 '#s(future-event 2 0 result 1334779296869.947 #f #f))
|
||||||
|
(indexed-fevent 57 '#s(future-event 2 2 result 1334779296869.981 #f #f))
|
||||||
|
(indexed-fevent 58 '#s(future-event 2 2 sync 1334779296870.32 #f #f))
|
||||||
|
(indexed-fevent 59 '#s(future-event 2 0 sync 1334779296879.438 [allocate memory] #f))
|
||||||
|
(indexed-fevent 60 '#s(future-event 2 0 result 1334779296879.446 #f #f))
|
||||||
|
(indexed-fevent 61 '#s(future-event 2 2 result 1334779296879.463 #f #f))
|
||||||
|
(indexed-fevent 62 '#s(future-event 2 2 sync 1334779296879.526 #f #f))
|
||||||
|
(indexed-fevent 63 '#s(future-event 2 0 sync 1334779296882.928 [allocate memory] #f))
|
||||||
|
(indexed-fevent 64 '#s(future-event 2 0 result 1334779296882.935 #f #f))
|
||||||
|
(indexed-fevent 65 '#s(future-event 2 2 result 1334779296882.944 #f #f))
|
||||||
|
(indexed-fevent 66 '#s(future-event 2 2 sync 1334779296883.311 #f #f))
|
||||||
|
(indexed-fevent 67 '#s(future-event 2 0 sync 1334779296890.471 [allocate memory] #f))
|
||||||
|
(indexed-fevent 68 '#s(future-event 2 0 result 1334779296890.479 #f #f))
|
||||||
|
(indexed-fevent 69 '#s(future-event 2 2 result 1334779296890.517 #f #f))
|
||||||
|
(indexed-fevent 70 '#s(future-event 2 2 sync 1334779296890.581 #f #f))
|
||||||
|
(indexed-fevent 71 '#s(future-event 2 0 sync 1334779296894.362 [allocate memory] #f))
|
||||||
|
(indexed-fevent 72 '#s(future-event 2 0 result 1334779296894.369 #f #f))
|
||||||
|
(indexed-fevent 73 '#s(future-event 2 2 result 1334779296894.382 #f #f))
|
||||||
|
(indexed-fevent 74 '#s(future-event 2 2 sync 1334779296894.769 #f #f))
|
||||||
|
(indexed-fevent 75 '#s(future-event 2 0 sync 1334779296901.501 [allocate memory] #f))
|
||||||
|
(indexed-fevent 76 '#s(future-event 2 0 result 1334779296901.51 #f #f))
|
||||||
|
(indexed-fevent 77 '#s(future-event 2 2 result 1334779296901.556 #f #f))
|
||||||
|
(indexed-fevent 78 '#s(future-event 2 2 sync 1334779296901.62 #f #f))
|
||||||
|
(indexed-fevent 79 '#s(future-event 2 0 sync 1334779296905.428 [allocate memory] #f))
|
||||||
|
(indexed-fevent 80 '#s(future-event 2 0 result 1334779296905.434 #f #f))
|
||||||
|
(indexed-fevent 81 '#s(future-event 2 2 result 1334779296905.447 #f #f))
|
||||||
|
(indexed-fevent 82 '#s(future-event 2 2 sync 1334779296905.743 #f #f))
|
||||||
|
(indexed-fevent 83 '#s(future-event 2 0 sync 1334779296912.538 [allocate memory] #f))
|
||||||
|
(indexed-fevent 84 '#s(future-event 2 0 result 1334779296912.547 #f #f))
|
||||||
|
(indexed-fevent 85 '#s(future-event 2 2 result 1334779296912.564 #f #f))
|
||||||
|
(indexed-fevent 86 '#s(future-event 2 2 sync 1334779296912.625 #f #f))
|
||||||
|
(indexed-fevent 87 '#s(future-event 2 0 sync 1334779296916.094 [allocate memory] #f))
|
||||||
|
(indexed-fevent 88 '#s(future-event 2 0 result 1334779296916.1 #f #f))
|
||||||
|
(indexed-fevent 89 '#s(future-event 2 2 result 1334779296916.108 #f #f))
|
||||||
|
(indexed-fevent 90 '#s(future-event 2 2 sync 1334779296916.243 #f #f))
|
||||||
|
(indexed-fevent 91 '#s(future-event 2 0 sync 1334779296927.233 [allocate memory] #f))
|
||||||
|
(indexed-fevent 92 '#s(future-event 2 0 result 1334779296927.242 #f #f))
|
||||||
|
(indexed-fevent 93 '#s(future-event 2 2 result 1334779296927.262 #f #f))
|
||||||
|
(indexed-fevent 94 '#s(future-event 2 2 sync 1334779296927.59 #f #f))
|
||||||
|
(indexed-fevent 95 '#s(future-event 2 0 sync 1334779296934.603 [allocate memory] #f))
|
||||||
|
(indexed-fevent 96 '#s(future-event 2 0 result 1334779296934.612 #f #f))
|
||||||
|
(indexed-fevent 97 '#s(future-event 2 2 result 1334779296934.655 #f #f))
|
||||||
|
(indexed-fevent 98 '#s(future-event 2 2 sync 1334779296934.72 #f #f))
|
||||||
|
(indexed-fevent 99 '#s(future-event 2 0 sync 1334779296938.773 [allocate memory] #f))
|
||||||
|
))
|
||||||
|
]
|
||||||
|
|
||||||
|
@interaction-eval-show[
|
||||||
|
#:eval future-eval
|
||||||
|
(build-timeline-bmp-from-log better-log #:max-width 600 #:max-height 300)
|
||||||
|
]
|
||||||
|
|
||||||
|
The problem is that most every arithmetic operation in this example
|
||||||
|
produces an inexact number whose storage must be allocated. While some allocation
|
||||||
|
can safely be performed exclusively without the aid of the runtime thread, especially
|
||||||
|
frequent allocation requires synchronized operations which defeat any performance
|
||||||
|
improvement.
|
||||||
|
|
||||||
By using @tech{flonum}-specific operations (see
|
By using @tech{flonum}-specific operations (see
|
||||||
@secref["fixnums+flonums"]), we can re-write @racket[mandelbot] to use
|
@secref["fixnums+flonums"]), we can re-write @racket[mandelbrot] to use
|
||||||
much less allocation:
|
much less allocation:
|
||||||
|
|
||||||
|
@interaction-eval[
|
||||||
|
#:eval future-eval
|
||||||
|
(define good-log
|
||||||
|
(list (indexed-fevent 0 '#s(future-event #f 0 create 1334778395768.733 #f 3))
|
||||||
|
(indexed-fevent 1 '#s(future-event 3 2 start-work 1334778395768.771 #f #f))
|
||||||
|
(indexed-fevent 2 '#s(future-event 3 2 complete 1334778395864.648 #f #f))
|
||||||
|
(indexed-fevent 3 '#s(future-event 3 2 end-work 1334778395864.652 #f #f))
|
||||||
|
))
|
||||||
|
]
|
||||||
|
|
||||||
@racketblock[
|
@racketblock[
|
||||||
(define (mandelbrot iterations x y n)
|
(define (mandelbrot iterations x y n)
|
||||||
(let ([ci (fl- (fl/ (* 2.0 (->fl y)) (->fl n)) 1.0)]
|
(let ([ci (fl- (fl/ (* 2.0 (->fl y)) (->fl n)) 1.0)]
|
||||||
|
|
@ -145,42 +450,23 @@ much less allocation:
|
||||||
This conversion can speed @racket[mandelbrot] by a factor of 8, even
|
This conversion can speed @racket[mandelbrot] by a factor of 8, even
|
||||||
in sequential mode, but avoiding allocation also allows
|
in sequential mode, but avoiding allocation also allows
|
||||||
@racket[mandelbrot] to run usefully faster in parallel.
|
@racket[mandelbrot] to run usefully faster in parallel.
|
||||||
|
Executing this program yields the following in the visualizer:
|
||||||
|
|
||||||
|
@interaction-eval-show[
|
||||||
|
#:eval future-eval
|
||||||
|
(build-timeline-bmp-from-log good-log
|
||||||
|
#:max-width 600
|
||||||
|
#:max-height 300)
|
||||||
|
]
|
||||||
|
|
||||||
|
Notice that only one green bar is shown here because one of the
|
||||||
|
mandelbrot computations is not being evaluated by a future (on
|
||||||
|
the runtime thread).
|
||||||
|
|
||||||
As a general guideline, any operation that is inlined by the
|
As a general guideline, any operation that is inlined by the
|
||||||
@tech{JIT} compiler runs safely in parallel, while other operations
|
@tech{JIT} compiler runs safely in parallel, while other operations
|
||||||
that are not inlined (including all operations if the JIT compiler is
|
that are not inlined (including all operations if the JIT compiler is
|
||||||
disabled) are considered unsafe. The @exec{mzc} decompiler tool
|
disabled) are considered unsafe. The @exec{raco decompile} tool
|
||||||
annotates operations that can be inlined by the compiler (see
|
annotates operations that can be inlined by the compiler (see
|
||||||
@secref[#:doc '(lib "scribblings/raco/raco.scrbl") "decompile"]), so the
|
@secref[#:doc '(lib "scribblings/raco/raco.scrbl") "decompile"]), so the
|
||||||
decompiler can be used to help predict parallel performance.
|
decompiler can be used to help predict parallel performance.
|
||||||
|
|
||||||
To more directly report what is happening in a program that uses
|
|
||||||
@racket[future] and @racket[touch], operations are logged when they
|
|
||||||
suspend a computation or synchronize with the main computation. For
|
|
||||||
example, running the original @racket[mandelbrot] in a future produces
|
|
||||||
the following output in the @racket['debug] log level:
|
|
||||||
|
|
||||||
@margin-note{To see @racket['debug] logging output on stderr, set the
|
|
||||||
@envvar{PLTSTDERR} environment variable to @tt{debug} or start
|
|
||||||
@exec{racket} with @Flag{W} @tt{debug}.}
|
|
||||||
|
|
||||||
@verbatim[#:indent 2]|{
|
|
||||||
future 1, process 1: BLOCKING on process 0; time: ....
|
|
||||||
....
|
|
||||||
future 1, process 0: HANDLING: *; time: ....
|
|
||||||
}|
|
|
||||||
|
|
||||||
The messages indicate which internal future-running task became
|
|
||||||
blocked on an unsafe operation, the time it blocked (in terms of
|
|
||||||
@racket[current-inexact-miliseconds]), and the operation that caused
|
|
||||||
the computation it to block.
|
|
||||||
|
|
||||||
The first revision to @racket[mandelbrot] avoids suspending at
|
|
||||||
@racket[*], but produces many log entries of the form
|
|
||||||
|
|
||||||
@verbatim[#:indent 2]|{
|
|
||||||
future 1, process 0: synchronizing: [allocate memory]; time: ....
|
|
||||||
}|
|
|
||||||
|
|
||||||
The @tt{[allocate memory]} part of the message indicates that
|
|
||||||
synchronization was needed for memory allocation.
|
|
||||||
|
|
|
||||||
BIN
collects/scribblings/guide/mand-bad-hover.png
Normal file
BIN
collects/scribblings/guide/mand-bad-hover.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 27 KiB |
BIN
collects/scribblings/guide/mand-bad.png
Normal file
BIN
collects/scribblings/guide/mand-bad.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 24 KiB |
BIN
collects/scribblings/guide/mand-good.png
Normal file
BIN
collects/scribblings/guide/mand-good.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 25 KiB |
BIN
collects/scribblings/guide/vis-main.png
Normal file
BIN
collects/scribblings/guide/vis-main.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 24 KiB |
|
|
@ -17,5 +17,6 @@ support for parallelism to improve performance.
|
||||||
@include-section["sync.scrbl"]
|
@include-section["sync.scrbl"]
|
||||||
@include-section["thread-local.scrbl"]
|
@include-section["thread-local.scrbl"]
|
||||||
@include-section["futures.scrbl"]
|
@include-section["futures.scrbl"]
|
||||||
|
@include-section["futures-visualizer.scrbl"]
|
||||||
@include-section["places.scrbl"]
|
@include-section["places.scrbl"]
|
||||||
@include-section["distributed.scrbl"]
|
@include-section["distributed.scrbl"]
|
||||||
|
|
|
||||||
86
collects/scribblings/reference/futures-visualizer.scrbl
Normal file
86
collects/scribblings/reference/futures-visualizer.scrbl
Normal file
|
|
@ -0,0 +1,86 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require "mz.rkt" #;(for-label racket/future/visualizer))
|
||||||
|
|
||||||
|
@title[#:tag "futures-visualizer"]{Futures Visualizer}
|
||||||
|
|
||||||
|
@guideintro["effective-futures"]{the future visualizer}
|
||||||
|
|
||||||
|
@defmodule[racket/future/visualizer]
|
||||||
|
|
||||||
|
The @deftech{futures visualizer} is a graphical profiling tool
|
||||||
|
for parallel programs written using @racket[future]. The tool
|
||||||
|
shows a timeline of a program's execution including all future-related
|
||||||
|
events, as well as the overall amount of processor utilization
|
||||||
|
at any point during the program's lifetime.
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
|
@defproc[(start-performance-tracking!) void?]
|
||||||
|
@defproc[(show-visualizer) void?]
|
||||||
|
)]{
|
||||||
|
The @racket[start-performance-tracking!] procedure enables the collection
|
||||||
|
of data required by the visualizer. This function should be called immediately
|
||||||
|
prior to executing code the programmer wishes to profile.
|
||||||
|
|
||||||
|
The @racket[show-visualizer] procedure displays the profiler window.
|
||||||
|
|
||||||
|
A typical program using profiling might look like the following:
|
||||||
|
|
||||||
|
@racketblock[
|
||||||
|
(require racket/future
|
||||||
|
racket/future/visualizer)
|
||||||
|
|
||||||
|
(start-performance-tracking!)
|
||||||
|
(let ([f (future (lambda () ...))])
|
||||||
|
...
|
||||||
|
(touch f))
|
||||||
|
|
||||||
|
(show-visualizer)
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
|
@section[#:tag "future-visualizer-timeline"]{Execution Timeline}
|
||||||
|
|
||||||
|
The @deftech{execution timeline}, shown in the top left-hand corner of the
|
||||||
|
profiler window, displays a history of the program
|
||||||
|
and all events associated with its futures, with OS-level threads
|
||||||
|
or @deftech{processes} organized along the y-axis and time increasing along
|
||||||
|
the x-axis. A coloring convention is used to distinguish between
|
||||||
|
different types of events (see @secref["future-logging"] for a full
|
||||||
|
description of these event types):
|
||||||
|
|
||||||
|
@itemlist[
|
||||||
|
@item{Blue dot: @racket['create]}
|
||||||
|
|
||||||
|
@item{Green bar: @racket['start-work], @racket['start-0-work]}
|
||||||
|
|
||||||
|
@item{Orange dot: @racket['sync]}
|
||||||
|
|
||||||
|
@item{Red dot: @racket['block], @racket['touch]}
|
||||||
|
|
||||||
|
@item{White dot: @racket['result], @racket['end-work]}
|
||||||
|
|
||||||
|
@item{Green dot: @racket['touch-pause], @racket['touch-resume]}
|
||||||
|
]
|
||||||
|
|
||||||
|
Mousing over any event connects it via purple lines to the sequence
|
||||||
|
of events for its future. Additionally, orange dotted lines
|
||||||
|
with arrowheads may be shown to indicate operations performed from
|
||||||
|
one future to another (e.g. @racket['create] or @racket['touch] actions).
|
||||||
|
To view details about two events simultaneously, a selection
|
||||||
|
can be tacked by clicking the mouse.
|
||||||
|
|
||||||
|
The timeline displays vertical lines at 100-microsecond intervals. Note that
|
||||||
|
though the time interval is fixed, the pixel distance between lines varies
|
||||||
|
based on the event density for any given time range to prevent overlapping
|
||||||
|
event circles.
|
||||||
|
|
||||||
|
@section[#:tag "future-visualizer-tree"]{Future Creation Tree}
|
||||||
|
|
||||||
|
The @deftech{creation tree} shows a tree with a single node per
|
||||||
|
future created by the program. This display can be particularly useful
|
||||||
|
for programs which spawn futures in nested fashion (futures within futures).
|
||||||
|
For any given future node, the children
|
||||||
|
of that node represent futures which were created by that future (within
|
||||||
|
the scope of its thunk). For all programs, the root of the tree
|
||||||
|
is a special node representing the main computation thread (the runtime thread),
|
||||||
|
and is denoted @deftech{RTT}.
|
||||||
|
|
@ -183,16 +183,16 @@ Racket futures use logging (see @secref["logging"]) extensively to
|
||||||
report information about how futures are evaluated. Logging output is
|
report information about how futures are evaluated. Logging output is
|
||||||
useful for debugging the performance of programs that use futures.
|
useful for debugging the performance of programs that use futures.
|
||||||
|
|
||||||
|
Though textual log output can be viewed directly, it is much
|
||||||
|
easier to use the graphical profiler tool provided by
|
||||||
|
@racketmodname[racket/future/visualizer].
|
||||||
|
|
||||||
In addition to its string message, each event logged for a future has
|
In addition to its string message, each event logged for a future has
|
||||||
a data value that is an instance of a @racket[future-event]
|
a data value that is an instance of a @racket[future-event]
|
||||||
@tech{prefab} structure:
|
@tech{prefab} structure:
|
||||||
|
|
||||||
@racketblock[
|
@racketblock[
|
||||||
(define-struct future-event (future-id
|
(define-struct future-event (future-id proc-id action time unsafe-op-name target-fid)
|
||||||
proc-id
|
|
||||||
action
|
|
||||||
time
|
|
||||||
unsafe-op-name)
|
|
||||||
#:prefab)
|
#:prefab)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
@ -281,7 +281,13 @@ In process 0, some event pairs can be nested within other event pairs:
|
||||||
An @racket[block] in process 0 is generated when an unsafe operation
|
An @racket[block] in process 0 is generated when an unsafe operation
|
||||||
is handled. This type of event will contain a symbol in the
|
is handled. This type of event will contain a symbol in the
|
||||||
@racket[unsafe-op-name] field that is the name of the operation. In all
|
@racket[unsafe-op-name] field that is the name of the operation. In all
|
||||||
other cases, this field contains @racket[#f].}
|
other cases, this field contains @racket[#f].
|
||||||
|
|
||||||
|
The @racket[target-fid] field contains an exact integer value in certain
|
||||||
|
cases where the @racket[action] occurs in one future but is being
|
||||||
|
performed on another (e.g. @racket['create] or @racket['touch]). In such
|
||||||
|
cases, the integer value is the identifier of the future on which the action
|
||||||
|
is being performed. In all other cases, this field contains @racket[#f].
|
||||||
|
|
||||||
@; ----------------------------------------------------------------------
|
@; ----------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
|
||||||
105
collects/tests/future/bad-trace1.rkt
Normal file
105
collects/tests/future/bad-trace1.rkt
Normal file
|
|
@ -0,0 +1,105 @@
|
||||||
|
#lang racket
|
||||||
|
(require racket/future/private/visualizer-data)
|
||||||
|
(provide BAD-TRACE-1)
|
||||||
|
|
||||||
|
(define BAD-TRACE-1 (list (indexed-fevent 0 '#s(future-event #f 0 create 1334779294212.415 #f 1))
|
||||||
|
(indexed-fevent 1 '#s(future-event 1 1 start-work 1334779294212.495 #f #f))
|
||||||
|
(indexed-fevent 2 '#s(future-event 1 1 sync 1334779294212.501 #f #f))
|
||||||
|
(indexed-fevent 3 (future-event 1 0 'sync 1334779294221.128 'allocate_memory #f))
|
||||||
|
(indexed-fevent 4 '#s(future-event 1 0 result 1334779294221.138 #f #f))
|
||||||
|
(indexed-fevent 5 '#s(future-event 1 1 result 1334779294221.15 #f #f))
|
||||||
|
(indexed-fevent 6 '#s(future-event 1 1 block 1334779294221.158 #f #f))
|
||||||
|
(indexed-fevent 7 '#s(future-event 1 1 suspend 1334779294221.164 #f #f))
|
||||||
|
(indexed-fevent 8 '#s(future-event 1 1 end-work 1334779294221.165 #f #f))
|
||||||
|
(indexed-fevent 9 '#s(future-event 1 0 block 1334779295356.267 > #f))
|
||||||
|
(indexed-fevent 10 '#s(future-event 1 0 result 1334779295356.293 #f #f))
|
||||||
|
(indexed-fevent 11 '#s(future-event 1 1 start-work 1334779295356.316 #f #f))
|
||||||
|
(indexed-fevent 12 '#s(future-event 1 1 sync 1334779295356.448 #f #f))
|
||||||
|
(indexed-fevent 13 '#s(future-event 1 0 touch-pause 1334779295356.451 #f #f))
|
||||||
|
(indexed-fevent 14 '#s(future-event 1 0 touch-resume 1334779295356.472 #f #f))
|
||||||
|
(indexed-fevent 15 (future-event 1 0 'block 1334779295356.936 'allocate_memory #f))
|
||||||
|
(indexed-fevent 16 '#s(future-event 1 0 result 1334779295356.959 #f #f))
|
||||||
|
(indexed-fevent 17 '#s(future-event 1 1 result 1334779295356.97 #f #f))
|
||||||
|
(indexed-fevent 18 '#s(future-event 1 1 block 1334779295356.988 #f #f))
|
||||||
|
(indexed-fevent 19 '#s(future-event 1 1 suspend 1334779295356.99 #f #f))
|
||||||
|
(indexed-fevent 20 '#s(future-event 1 1 end-work 1334779295357.0 #f #f))
|
||||||
|
(indexed-fevent 21 '#s(future-event 1 0 touch-pause 1334779295357.066 #f #f))
|
||||||
|
(indexed-fevent 22 '#s(future-event 1 0 touch-resume 1334779295357.066 #f #f))
|
||||||
|
(indexed-fevent 23 '#s(future-event 1 0 block 1334779295357.104 * #f))
|
||||||
|
(indexed-fevent 24 '#s(future-event 1 0 result 1334779295357.11 #f #f))
|
||||||
|
(indexed-fevent 25 '#s(future-event 1 1 start-work 1334779295357.119 #f #f))
|
||||||
|
(indexed-fevent 26 '#s(future-event 1 1 block 1334779295357.122 #f #f))
|
||||||
|
(indexed-fevent 27 '#s(future-event 1 1 suspend 1334779295357.123 #f #f))
|
||||||
|
(indexed-fevent 28 '#s(future-event 1 1 end-work 1334779295357.124 #f #f))
|
||||||
|
(indexed-fevent 29 '#s(future-event 1 0 touch-pause 1334779295357.174 #f #f))
|
||||||
|
(indexed-fevent 30 '#s(future-event 1 0 touch-resume 1334779295357.174 #f #f))
|
||||||
|
(indexed-fevent 31 '#s(future-event 1 0 block 1334779295357.21 > #f))
|
||||||
|
(indexed-fevent 32 '#s(future-event 1 0 result 1334779295357.216 #f #f))
|
||||||
|
(indexed-fevent 33 '#s(future-event 1 1 start-work 1334779295357.224 #f #f))
|
||||||
|
(indexed-fevent 34 '#s(future-event 1 1 block 1334779295357.226 #f #f))
|
||||||
|
(indexed-fevent 35 '#s(future-event 1 1 suspend 1334779295357.227 #f #f))
|
||||||
|
(indexed-fevent 36 '#s(future-event 1 1 end-work 1334779295357.228 #f #f))
|
||||||
|
(indexed-fevent 37 '#s(future-event 1 0 touch-pause 1334779295357.278 #f #f))
|
||||||
|
(indexed-fevent 38 '#s(future-event 1 0 touch-resume 1334779295357.279 #f #f))
|
||||||
|
(indexed-fevent 39 '#s(future-event 1 0 block 1334779295357.315 * #f))
|
||||||
|
(indexed-fevent 40 '#s(future-event 1 0 result 1334779295357.32 #f #f))
|
||||||
|
(indexed-fevent 41 '#s(future-event 1 1 start-work 1334779295357.328 #f #f))
|
||||||
|
(indexed-fevent 42 '#s(future-event 1 1 block 1334779295357.337 #f #f))
|
||||||
|
(indexed-fevent 43 '#s(future-event 1 1 suspend 1334779295357.338 #f #f))
|
||||||
|
(indexed-fevent 44 '#s(future-event 1 1 end-work 1334779295357.347 #f #f))
|
||||||
|
(indexed-fevent 45 '#s(future-event 1 0 touch-pause 1334779295357.407 #f #f))
|
||||||
|
(indexed-fevent 46 '#s(future-event 1 0 touch-resume 1334779295357.408 #f #f))
|
||||||
|
(indexed-fevent 47 '#s(future-event 1 0 block 1334779295357.445 > #f))
|
||||||
|
(indexed-fevent 48 '#s(future-event 1 0 result 1334779295357.45 #f #f))
|
||||||
|
(indexed-fevent 49 '#s(future-event 1 1 start-work 1334779295357.458 #f #f))
|
||||||
|
(indexed-fevent 50 '#s(future-event 1 1 block 1334779295357.46 #f #f))
|
||||||
|
(indexed-fevent 51 '#s(future-event 1 1 suspend 1334779295357.461 #f #f))
|
||||||
|
(indexed-fevent 52 '#s(future-event 1 1 end-work 1334779295357.477 #f #f))
|
||||||
|
(indexed-fevent 53 '#s(future-event 1 0 touch-pause 1334779295357.536 #f #f))
|
||||||
|
(indexed-fevent 54 '#s(future-event 1 0 touch-resume 1334779295357.537 #f #f))
|
||||||
|
(indexed-fevent 55 '#s(future-event 1 0 block 1334779295357.573 * #f))
|
||||||
|
(indexed-fevent 56 '#s(future-event 1 0 result 1334779295357.579 #f #f))
|
||||||
|
(indexed-fevent 57 '#s(future-event 1 1 start-work 1334779295357.587 #f #f))
|
||||||
|
(indexed-fevent 58 '#s(future-event 1 1 block 1334779295357.595 #f #f))
|
||||||
|
(indexed-fevent 59 '#s(future-event 1 1 suspend 1334779295357.596 #f #f))
|
||||||
|
(indexed-fevent 60 '#s(future-event 1 1 end-work 1334779295357.597 #f #f))
|
||||||
|
(indexed-fevent 61 '#s(future-event 1 0 touch-pause 1334779295357.644 #f #f))
|
||||||
|
(indexed-fevent 62 '#s(future-event 1 0 touch-resume 1334779295357.645 #f #f))
|
||||||
|
(indexed-fevent 63 '#s(future-event 1 0 block 1334779295357.68 > #f))
|
||||||
|
(indexed-fevent 64 '#s(future-event 1 0 result 1334779295357.685 #f #f))
|
||||||
|
(indexed-fevent 65 '#s(future-event 1 1 start-work 1334779295357.693 #f #f))
|
||||||
|
(indexed-fevent 66 '#s(future-event 1 1 block 1334779295357.695 #f #f))
|
||||||
|
(indexed-fevent 67 '#s(future-event 1 1 suspend 1334779295357.697 #f #f))
|
||||||
|
(indexed-fevent 68 '#s(future-event 1 1 end-work 1334779295357.712 #f #f))
|
||||||
|
(indexed-fevent 69 '#s(future-event 1 0 touch-pause 1334779295357.771 #f #f))
|
||||||
|
(indexed-fevent 70 '#s(future-event 1 0 touch-resume 1334779295357.771 #f #f))
|
||||||
|
(indexed-fevent 71 '#s(future-event 1 0 block 1334779295357.807 * #f))
|
||||||
|
(indexed-fevent 72 '#s(future-event 1 0 result 1334779295357.813 #f #f))
|
||||||
|
(indexed-fevent 73 '#s(future-event 1 1 start-work 1334779295357.821 #f #f))
|
||||||
|
(indexed-fevent 74 '#s(future-event 1 1 block 1334779295357.823 #f #f))
|
||||||
|
(indexed-fevent 75 '#s(future-event 1 1 suspend 1334779295357.824 #f #f))
|
||||||
|
(indexed-fevent 76 '#s(future-event 1 1 end-work 1334779295357.84 #f #f))
|
||||||
|
(indexed-fevent 77 '#s(future-event 1 0 touch-pause 1334779295357.899 #f #f))
|
||||||
|
(indexed-fevent 78 '#s(future-event 1 0 touch-resume 1334779295357.899 #f #f))
|
||||||
|
(indexed-fevent 79 '#s(future-event 1 0 block 1334779295357.936 > #f))
|
||||||
|
(indexed-fevent 80 '#s(future-event 1 0 result 1334779295357.941 #f #f))
|
||||||
|
(indexed-fevent 81 '#s(future-event 1 1 start-work 1334779295357.949 #f #f))
|
||||||
|
(indexed-fevent 82 '#s(future-event 1 1 block 1334779295357.957 #f #f))
|
||||||
|
(indexed-fevent 83 '#s(future-event 1 1 suspend 1334779295357.958 #f #f))
|
||||||
|
(indexed-fevent 84 '#s(future-event 1 1 end-work 1334779295357.971 #f #f))
|
||||||
|
(indexed-fevent 85 '#s(future-event 1 0 touch-pause 1334779295358.03 #f #f))
|
||||||
|
(indexed-fevent 86 '#s(future-event 1 0 touch-resume 1334779295358.03 #f #f))
|
||||||
|
(indexed-fevent 87 '#s(future-event 1 0 block 1334779295358.067 * #f))
|
||||||
|
(indexed-fevent 88 '#s(future-event 1 0 result 1334779295358.072 #f #f))
|
||||||
|
(indexed-fevent 89 '#s(future-event 1 1 start-work 1334779295358.08 #f #f))
|
||||||
|
(indexed-fevent 90 '#s(future-event 1 1 block 1334779295358.088 #f #f))
|
||||||
|
(indexed-fevent 91 '#s(future-event 1 1 suspend 1334779295358.09 #f #f))
|
||||||
|
(indexed-fevent 92 '#s(future-event 1 1 end-work 1334779295358.099 #f #f))
|
||||||
|
(indexed-fevent 93 '#s(future-event 1 0 touch-pause 1334779295358.15 #f #f))
|
||||||
|
(indexed-fevent 94 '#s(future-event 1 0 touch-resume 1334779295358.15 #f #f))
|
||||||
|
(indexed-fevent 95 '#s(future-event 1 0 block 1334779295358.187 > #f))
|
||||||
|
(indexed-fevent 96 '#s(future-event 1 0 result 1334779295358.192 #f #f))
|
||||||
|
(indexed-fevent 97 '#s(future-event 1 1 start-work 1334779295358.2 #f #f))
|
||||||
|
(indexed-fevent 98 '#s(future-event 1 1 block 1334779295358.209 #f #f))
|
||||||
|
(indexed-fevent 99 '#s(future-event 1 1 suspend 1334779295358.21 #f #f))
|
||||||
|
))
|
||||||
|
|
@ -15,7 +15,7 @@ We should also test deep continuations.
|
||||||
|#
|
|#
|
||||||
|
|
||||||
;Tests specific to would-be-future
|
;Tests specific to would-be-future
|
||||||
(define-struct future-event (future-id process-id what time prim-name)
|
(define-struct future-event (future-id process-id what time prim-name target-fid)
|
||||||
#:prefab)
|
#:prefab)
|
||||||
|
|
||||||
(define (get-events-of-type type log)
|
(define (get-events-of-type type log)
|
||||||
|
|
|
||||||
273
collects/tests/future/visualizer.rkt
Normal file
273
collects/tests/future/visualizer.rkt
Normal file
|
|
@ -0,0 +1,273 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require rackunit
|
||||||
|
racket/vector
|
||||||
|
racket/future/private/visualizer-drawing
|
||||||
|
racket/future/private/visualizer-data
|
||||||
|
racket/future/private/display
|
||||||
|
"bad-trace1.rkt")
|
||||||
|
|
||||||
|
(define (compile-trace-data logs)
|
||||||
|
(define tr (build-trace logs))
|
||||||
|
(define-values (finfo segs) (calc-segments tr))
|
||||||
|
(values tr
|
||||||
|
finfo
|
||||||
|
segs
|
||||||
|
(frame-info-timeline-ticks finfo)))
|
||||||
|
|
||||||
|
;Display tests
|
||||||
|
(let ([vr (viewable-region 3 3 500 500)])
|
||||||
|
(for ([i (in-range 4 503)])
|
||||||
|
(check-true (in-viewable-region-horiz vr i)
|
||||||
|
(format "~a should be in ~a"
|
||||||
|
i
|
||||||
|
vr)))
|
||||||
|
(for ([i (in-range 0 2)])
|
||||||
|
(check-false (in-viewable-region-horiz vr i)
|
||||||
|
(format "~a should not be in ~a"
|
||||||
|
i
|
||||||
|
vr))
|
||||||
|
(for ([i (in-range 504 1000)])
|
||||||
|
(check-false (in-viewable-region-horiz vr i)
|
||||||
|
(format "~a should not be in ~a"
|
||||||
|
i
|
||||||
|
vr)))))
|
||||||
|
|
||||||
|
(let ([vr (viewable-region 0 0 732 685)])
|
||||||
|
(check-true (in-viewable-region-horiz vr 10))
|
||||||
|
(check-true (in-viewable-region-horiz vr 63.0))
|
||||||
|
(check-true (in-viewable-region-horiz vr 116.0))
|
||||||
|
(check-true (in-viewable-region-horiz vr 169.0))
|
||||||
|
(check-true (in-viewable-region-horiz vr 222)))
|
||||||
|
|
||||||
|
(let ([vr (viewable-region 0 0 732 685)]
|
||||||
|
[ticks (list (timeline-tick 222.0 #f 0.4999999999999982)
|
||||||
|
(timeline-tick 169.0 #f 0.3999999999999986)
|
||||||
|
(timeline-tick 116.0 #f 0.29999999999999893)
|
||||||
|
(timeline-tick 63.0 #f 0.1999999999999993)
|
||||||
|
(timeline-tick 10 #f 0.09999999999999964))])
|
||||||
|
(define in-vr (filter (λ (t)
|
||||||
|
(in-viewable-region-horiz vr (timeline-tick-x t)))
|
||||||
|
ticks))
|
||||||
|
(check-equal? (length in-vr) 5))
|
||||||
|
|
||||||
|
;Trace compilation tests
|
||||||
|
(let* ([future-log (list (indexed-fevent 0 (future-event 0 0 'create 0 #f 0))
|
||||||
|
(indexed-fevent 1 (future-event 0 1 'start-work 1 #f #f))
|
||||||
|
(indexed-fevent 2 (future-event 0 1 'end-work 2 #f #f))
|
||||||
|
(indexed-fevent 3 (future-event 0 0 'complete 3 #f #f)))]
|
||||||
|
[organized (organize-output future-log)])
|
||||||
|
(check-equal? (vector-length organized) 2)
|
||||||
|
(let ([proc0log (vector-ref organized 0)]
|
||||||
|
[proc1log (vector-ref organized 1)])
|
||||||
|
(check-equal? (vector-length proc0log) 2)
|
||||||
|
(check-equal? (vector-length proc1log) 2)))
|
||||||
|
|
||||||
|
(let* ([future-log (list (indexed-fevent 0 (future-event #f 0 'create 0 #f 0))
|
||||||
|
(indexed-fevent 1 (future-event 0 1 'start-work 1 #f #f))
|
||||||
|
(indexed-fevent 2 (future-event 0 1 'end-work 2 #f #f))
|
||||||
|
(indexed-fevent 3 (future-event 0 0 'complete 3 #f #f)))]
|
||||||
|
[trace (build-trace future-log)]
|
||||||
|
[evts (trace-all-events trace)])
|
||||||
|
(check-equal? (length evts) 4)
|
||||||
|
(check-equal? (length (filter (λ (e) (event-next-future-event e)) evts)) 2)
|
||||||
|
(check-equal? (length (filter (λ (e) (event-next-targ-future-event e)) evts)) 1)
|
||||||
|
(check-equal? (length (filter (λ (e) (event-prev-targ-future-event e)) evts)) 1))
|
||||||
|
|
||||||
|
(let* ([future-log (list (indexed-fevent 0 (future-event 0 0 'create 0 #f 0))
|
||||||
|
(indexed-fevent 1 (future-event 1 0 'create 1 #f 1))
|
||||||
|
(indexed-fevent 2 (future-event 0 1 'start-work 2 #f #f))
|
||||||
|
(indexed-fevent 3 (future-event 1 2 'start-work 2 #f #f))
|
||||||
|
(indexed-fevent 4 (future-event 0 1 'end-work 4 #f #f))
|
||||||
|
(indexed-fevent 5 (future-event 0 0 'complete 5 #f #f))
|
||||||
|
(indexed-fevent 6 (future-event 1 2 'end-work 5 #f #f))
|
||||||
|
(indexed-fevent 7 (future-event 1 0 'complete 7 #f #f)))]
|
||||||
|
[organized (organize-output future-log)])
|
||||||
|
(check-equal? (vector-length organized) 3)
|
||||||
|
(let ([proc0log (vector-ref organized 0)]
|
||||||
|
[proc1log (vector-ref organized 1)]
|
||||||
|
[proc2log (vector-ref organized 2)])
|
||||||
|
(check-equal? (vector-length proc0log) 4)
|
||||||
|
(check-equal? (vector-length proc1log) 2)
|
||||||
|
(check-equal? (vector-length proc2log) 2)
|
||||||
|
(for ([msg (in-vector (vector-map indexed-fevent-fevent proc0log))])
|
||||||
|
(check-equal? (future-event-process-id msg) 0))
|
||||||
|
(for ([msg (in-vector (vector-map indexed-fevent-fevent proc1log))])
|
||||||
|
(check-equal? (future-event-process-id msg) 1))
|
||||||
|
(for ([msg (in-vector (vector-map indexed-fevent-fevent proc2log))])
|
||||||
|
(check-equal? (future-event-process-id msg) 2))))
|
||||||
|
|
||||||
|
;Drawing calculation tests
|
||||||
|
(let* ([future-log (list (indexed-fevent 0 (future-event #f 0 'create 0 #f 0))
|
||||||
|
(indexed-fevent 1 (future-event 0 1 'start-work 1 #f #f))
|
||||||
|
(indexed-fevent 2 (future-event 0 1 'end-work 2 #f #f))
|
||||||
|
(indexed-fevent 3 (future-event 0 0 'complete 3 #f #f)))]
|
||||||
|
[trace (build-trace future-log)])
|
||||||
|
(let-values ([(finfo segments) (calc-segments trace)])
|
||||||
|
(check-equal? (length segments) 4)
|
||||||
|
(check-equal? (length (filter (λ (s) (segment-next-future-seg s)) segments)) 2)
|
||||||
|
(check-equal? (length (filter (λ (s) (segment-next-targ-future-seg s)) segments)) 1)
|
||||||
|
(check-equal? (length (filter (λ (s) (segment-prev-targ-future-seg s)) segments)) 1)))
|
||||||
|
|
||||||
|
;Future=42
|
||||||
|
(let* ([future-log (list (indexed-fevent 0 (future-event #f 0 'create 0.05 #f 42))
|
||||||
|
(indexed-fevent 1 (future-event 42 1 'start-work 0.07 #f #f))
|
||||||
|
(indexed-fevent 2 (future-event 42 1 'end-work 0.3 #f #f))
|
||||||
|
(indexed-fevent 3 (future-event 42 0 'complete 1.2 #f #f)))]
|
||||||
|
[tr (build-trace future-log)])
|
||||||
|
(define-values (finfo segs) (calc-segments tr))
|
||||||
|
(define ticks (frame-info-timeline-ticks finfo))
|
||||||
|
(check-equal? (length ticks) 11))
|
||||||
|
|
||||||
|
(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 ([tick (in-list ticks)])
|
||||||
|
(let ([ttime (timeline-tick-rel-time tick)])
|
||||||
|
(cond
|
||||||
|
[(< evt-rel-time ttime)
|
||||||
|
(do-seg-check seg tick <= "before")]
|
||||||
|
[(= evt-rel-time ttime)
|
||||||
|
(do-seg-check seg tick = "equal to")]
|
||||||
|
[(> evt-rel-time ttime)
|
||||||
|
(do-seg-check seg tick >= "after")]))))))
|
||||||
|
|
||||||
|
;Test layout for 'bad' mandelbrot trace
|
||||||
|
(let-values ([(tr finfo segs ticks) (compile-trace-data BAD-TRACE-1)])
|
||||||
|
(check-seg-layout tr segs ticks))
|
||||||
|
|
||||||
|
(let* ([future-log (list (indexed-fevent 0 (future-event #f 0 'create 0.05 #f 42))
|
||||||
|
(indexed-fevent 1 (future-event 42 1 'start-work 0.09 #f #f))
|
||||||
|
(indexed-fevent 2 (future-event 42 1 'suspend 1.1 #f #f))
|
||||||
|
(indexed-fevent 3 (future-event 42 1 'resume 1.101 #f #f))
|
||||||
|
(indexed-fevent 4 (future-event 42 1 'suspend 1.102 #f #f))
|
||||||
|
(indexed-fevent 5 (future-event 42 1 'resume 1.103 #f #f))
|
||||||
|
(indexed-fevent 6 (future-event 42 1 'start-work 1.104 #f #f))
|
||||||
|
(indexed-fevent 7 (future-event 42 1 'complete 1.41 #f #f))
|
||||||
|
(indexed-fevent 8 (future-event 42 1 'end-work 1.42 #f #f))
|
||||||
|
(indexed-fevent 9 (future-event 42 0 'result 1.43 #f #f)))]
|
||||||
|
[tr (build-trace future-log)])
|
||||||
|
(define-values (finfo segs) (calc-segments tr))
|
||||||
|
(define ticks (frame-info-timeline-ticks finfo))
|
||||||
|
(check-seg-layout tr segs ticks))
|
||||||
|
|
||||||
|
(let* ([future-log (list (indexed-fevent 0 (future-event #f 0 'create 0 #f 0))
|
||||||
|
(indexed-fevent 1 (future-event 0 1 'start-work 1 #f #f))
|
||||||
|
(indexed-fevent 2 (future-event 0 1 'end-work 2 #f #f))
|
||||||
|
(indexed-fevent 3 (future-event 0 0 'complete 3 #f #f)))]
|
||||||
|
[trace (build-trace future-log)])
|
||||||
|
(check-equal? (trace-start-time trace) 0)
|
||||||
|
(check-equal? (trace-end-time trace) 3)
|
||||||
|
(check-equal? (length (trace-proc-timelines trace)) 2)
|
||||||
|
(check-equal? (trace-real-time trace) 3)
|
||||||
|
(check-equal? (trace-num-futures trace) 1)
|
||||||
|
(check-equal? (trace-num-blocks trace) 0)
|
||||||
|
(check-equal? (trace-num-syncs trace) 0)
|
||||||
|
(let ([proc0tl (list-ref (trace-proc-timelines trace) 0)]
|
||||||
|
[proc1tl (list-ref (trace-proc-timelines trace) 1)])
|
||||||
|
(check-equal? (process-timeline-start-time proc0tl) 0)
|
||||||
|
(check-equal? (process-timeline-end-time proc0tl) 3)
|
||||||
|
(check-equal? (process-timeline-start-time proc1tl) 1)
|
||||||
|
(check-equal? (process-timeline-end-time proc1tl) 2)
|
||||||
|
(let ([proc0segs (process-timeline-events proc0tl)]
|
||||||
|
[proc1segs (process-timeline-events proc1tl)])
|
||||||
|
(check-equal? (length proc0segs) 2)
|
||||||
|
(check-equal? (length proc1segs) 2)
|
||||||
|
(check-equal? (event-timeline-position (list-ref proc0segs 0)) 'start)
|
||||||
|
(check-equal? (event-timeline-position (list-ref proc0segs 1)) 'end))))
|
||||||
|
|
||||||
|
;Viewable region tests
|
||||||
|
(define (make-seg-at x y w h)
|
||||||
|
(segment #f x y w h #f #f #f #f #f #f #f #f))
|
||||||
|
|
||||||
|
;;make-segs-with-times : (listof (or float (float . float))) -> (listof segment)
|
||||||
|
(define (make-segs-with-times . times)
|
||||||
|
(for/list ([t (in-list times)] [i (in-naturals)])
|
||||||
|
(if (pair? t)
|
||||||
|
(make-seg-with-time i (car t) #:end-time (cdr t))
|
||||||
|
(make-seg-with-time i t))))
|
||||||
|
|
||||||
|
;;make-seg-with-time : fixnum float [float] -> segment
|
||||||
|
(define (make-seg-with-time index real-start-time #:end-time [real-end-time real-start-time])
|
||||||
|
(segment (event index
|
||||||
|
real-start-time
|
||||||
|
real-end-time
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 #f)
|
||||||
|
0 0 0 0 #f #f #f #f #f #f #f #f))
|
||||||
|
|
||||||
|
|
||||||
|
(let ([vregion (viewable-region 20 30 100 100)]
|
||||||
|
[seg1 (make-seg-at 0 5 10 10)]
|
||||||
|
[seg2 (make-seg-at 20 30 5 5)]
|
||||||
|
[seg3 (make-seg-at 150 35 5 5)])
|
||||||
|
(check-false ((seg-in-vregion vregion) seg1))
|
||||||
|
(check-true ((seg-in-vregion vregion) seg2))
|
||||||
|
(check-false ((seg-in-vregion vregion) seg3)))
|
||||||
|
|
||||||
|
;segs-equal-or-later
|
||||||
|
(let ([segs (make-segs-with-times 0.1
|
||||||
|
0.3
|
||||||
|
1.2
|
||||||
|
(cons 1.4 1.9)
|
||||||
|
2.4
|
||||||
|
2.8
|
||||||
|
3.1)])
|
||||||
|
(check-equal? (length (segs-equal-or-later 0.1 segs)) 7)
|
||||||
|
(check-equal? (length (segs-equal-or-later 0.3 segs)) 6)
|
||||||
|
(check-equal? (length (segs-equal-or-later 1.2 segs)) 5)
|
||||||
|
(check-equal? (length (segs-equal-or-later 1.4 segs)) 4)
|
||||||
|
(check-equal? (length (segs-equal-or-later 2.4 segs)) 3)
|
||||||
|
(check-equal? (length (segs-equal-or-later 2.8 segs)) 2)
|
||||||
|
(check-equal? (length (segs-equal-or-later 3.1 segs)) 1)
|
||||||
|
(check-equal? (length (segs-equal-or-later 4.0 segs)) 0))
|
||||||
|
|
||||||
|
;Tick drawing
|
||||||
|
(let ([l (list (indexed-fevent 0 (future-event #f 0 'create 10.0 #f 0))
|
||||||
|
(indexed-fevent 1 (future-event 0 0 'start-work 11.0 #f #f))
|
||||||
|
(indexed-fevent 2 (future-event 0 0 'end-work 20.0 #f #f)))])
|
||||||
|
(define-values (tr finfo segs ticks) (compile-trace-data l))
|
||||||
|
;Check that number of ticks stays constant whatever the time->pixel modifier
|
||||||
|
(check-equal? (length ticks) 100)
|
||||||
|
(check-equal? (length (calc-ticks segs 700 tr)) 100)
|
||||||
|
(for ([i (in-range 0.1 20)])
|
||||||
|
(check-equal? (length (calc-ticks segs i tr))
|
||||||
|
100
|
||||||
|
(format "Wrong number of ticks for time->pix mod ~a\n" i)))
|
||||||
|
(check-seg-layout tr segs ticks))
|
||||||
|
|
||||||
|
(let ([l (list (indexed-fevent 0 '#s(future-event #f 0 create 1334778395768.733 #f 3))
|
||||||
|
(indexed-fevent 1 '#s(future-event 3 2 start-work 1334778395768.771 #f #f))
|
||||||
|
(indexed-fevent 2 '#s(future-event 3 2 complete 1334778395864.648 #f #f))
|
||||||
|
(indexed-fevent 3 '#s(future-event 3 2 end-work 1334778395864.652 #f #f)))])
|
||||||
|
(define-values (tr finfo segs ticks) (compile-trace-data l))
|
||||||
|
(define last-evt (indexed-fevent-fevent (list-ref l 3)))
|
||||||
|
(define first-evt (indexed-fevent-fevent (list-ref l 0)))
|
||||||
|
(define total-time (- (future-event-time last-evt) (future-event-time first-evt)))
|
||||||
|
(check-equal? (length ticks) (inexact->exact (floor (* 10 total-time)))))
|
||||||
|
|
||||||
|
(define mand-first
|
||||||
|
(list (indexed-fevent 0 '#s(future-event #f 0 create 1334779294212.415 #f 1))
|
||||||
|
(indexed-fevent 1 '#s(future-event 1 1 start-work 1334779294212.495 #f #f))
|
||||||
|
(indexed-fevent 2 '#s(future-event 1 1 sync 1334779294212.501 #f #f))
|
||||||
|
(indexed-fevent 3 (future-event 1 0 'sync 1334779294221.128 'allocate_memory #f))
|
||||||
|
(indexed-fevent 4 '#s(future-event 1 0 result 1334779294221.138 #f #f))
|
||||||
|
(indexed-fevent 5 '#s(future-event 1 1 result 1334779294221.15 #f #f))))
|
||||||
|
(let-values ([(tr finfo segs ticks) (compile-trace-data mand-first)])
|
||||||
|
(check-seg-layout tr segs ticks))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
98
qsort2.rkt
Normal file
98
qsort2.rkt
Normal file
|
|
@ -0,0 +1,98 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require racket/future
|
||||||
|
racket/future/visualizer
|
||||||
|
rackunit
|
||||||
|
racket/fixnum
|
||||||
|
racket/unsafe/ops
|
||||||
|
(only-in racket/list empty?)
|
||||||
|
racket/vector
|
||||||
|
rackunit)
|
||||||
|
|
||||||
|
(define (qsort v)
|
||||||
|
(define length (vector-length v))
|
||||||
|
(qsort-h v 0 (sub1 length)))
|
||||||
|
|
||||||
|
(define (qsort-h v l r)
|
||||||
|
(when (unsafe-fx> (unsafe-fx- r l) 0)
|
||||||
|
(define m (partition v l r))
|
||||||
|
(qsort-h v l (unsafe-fx- m 1))
|
||||||
|
(qsort-h v (unsafe-fx+ 1 m) r)))
|
||||||
|
|
||||||
|
(define (swap! v i j)
|
||||||
|
(define temp (unsafe-vector-ref v j))
|
||||||
|
(unsafe-vector-set! v j (unsafe-vector-ref v i))
|
||||||
|
(unsafe-vector-set! v i temp))
|
||||||
|
|
||||||
|
(define (partition v l r)
|
||||||
|
(swap! v l r)
|
||||||
|
(define p (unsafe-vector-ref v r))
|
||||||
|
;moving this inline eliminates jit copilations
|
||||||
|
;but slows things down and makes things less parallel (factor of ~1.5)
|
||||||
|
(let recur
|
||||||
|
([i l]
|
||||||
|
[p-i l])
|
||||||
|
(cond
|
||||||
|
[(unsafe-fx= i r)
|
||||||
|
(swap! v r p-i)
|
||||||
|
p-i]
|
||||||
|
[(unsafe-fx< (unsafe-vector-ref v i) p)
|
||||||
|
(swap! v i p-i)
|
||||||
|
(recur (unsafe-fx+ 1 i) (unsafe-fx+ p-i 1))]
|
||||||
|
[else
|
||||||
|
(recur (unsafe-fx+ 1 i) p-i)])))
|
||||||
|
|
||||||
|
;(define (partition v l r)
|
||||||
|
; (let recur ([i (fx- l 1)]
|
||||||
|
; [j l])
|
||||||
|
; (cond
|
||||||
|
; [(fx= j (fx- r 1))
|
||||||
|
; (swap! v (fx+ i 1) r)
|
||||||
|
; (fx+ i 1)]
|
||||||
|
; [(fx< (unsafe-vector-ref v j) (unsafe-vector-ref v r))
|
||||||
|
; (swap! v (fx+ i 1) j)
|
||||||
|
; (recur (fx+ i 1) (fx+ j 1))]
|
||||||
|
; [else
|
||||||
|
; (recur i (fx+ j 1))])))
|
||||||
|
|
||||||
|
(define (qsort-f v)
|
||||||
|
(define length (vector-length v))
|
||||||
|
(qsort-f-h v 0 (sub1 length) 6))
|
||||||
|
|
||||||
|
(define (qsort-f-h v l r d)
|
||||||
|
(when (unsafe-fx> (unsafe-fx- r l) 0)
|
||||||
|
;(define m (partition v l r))
|
||||||
|
(if (unsafe-fx= d 0)
|
||||||
|
(let ([m (partition v l r)])
|
||||||
|
(qsort-h v l (unsafe-fx- m 1))
|
||||||
|
(qsort-h v (unsafe-fx+ 1 m) r))
|
||||||
|
(let* ([m (partition v l r)]
|
||||||
|
[f1 (future (λ () (qsort-f-h v l (unsafe-fx- m 1) (unsafe-fx- d 1))))]
|
||||||
|
[f2 (future (λ () (qsort-f-h v (unsafe-fx+ 1 m) r (unsafe-fx- d 1))))])
|
||||||
|
(touch f1)
|
||||||
|
(touch f2)))))
|
||||||
|
|
||||||
|
(define (check-sorting v)
|
||||||
|
(define l (vector->list v))
|
||||||
|
(define v1 (list->vector (sort l <)))
|
||||||
|
(qsort-f v)
|
||||||
|
(check-equal? v1 v))
|
||||||
|
|
||||||
|
(define (rand-v size) (build-vector size (λ (_) (random 30))))
|
||||||
|
|
||||||
|
;(check-sorting (rand-v 100))
|
||||||
|
|
||||||
|
(random-seed 2)
|
||||||
|
|
||||||
|
(define v1 (rand-v 50000))
|
||||||
|
(define v2 (vector-copy v1))
|
||||||
|
|
||||||
|
#;(time (begin (sort (vector->list v1) <)
|
||||||
|
'a))
|
||||||
|
#;(time (begin (qsort v1)
|
||||||
|
'b))
|
||||||
|
(let ()
|
||||||
|
(start-performance-tracking!)
|
||||||
|
(time (qsort-f v2))
|
||||||
|
(show-visualizer)
|
||||||
|
'c)
|
||||||
|
|
@ -39,7 +39,7 @@ Scheme_Object *scheme_fsemaphore_p(int argc, Scheme_Object *argv[])
|
||||||
|
|
||||||
static Scheme_Object *futures_enabled(int argc, Scheme_Object *argv[])
|
static Scheme_Object *futures_enabled(int argc, Scheme_Object *argv[])
|
||||||
{
|
{
|
||||||
#ifdef MZ_USE_FUTURES
|
#ifdef MZ_USE_FUTURESRACKET
|
||||||
return scheme_true;
|
return scheme_true;
|
||||||
#else
|
#else
|
||||||
return scheme_false;
|
return scheme_false;
|
||||||
|
|
@ -312,6 +312,7 @@ static int capture_future_continuation(struct Scheme_Future_State *fs, future_t
|
||||||
#define FUTURE_RUNSTACK_SIZE 2000
|
#define FUTURE_RUNSTACK_SIZE 2000
|
||||||
|
|
||||||
#define FEVENT_BUFFER_SIZE 512
|
#define FEVENT_BUFFER_SIZE 512
|
||||||
|
#define NO_FUTURE_ID -1
|
||||||
|
|
||||||
enum {
|
enum {
|
||||||
FEVENT_CREATE,
|
FEVENT_CREATE,
|
||||||
|
|
@ -589,6 +590,7 @@ void futures_init(void)
|
||||||
rt_fts->is_runtime_thread = 1;
|
rt_fts->is_runtime_thread = 1;
|
||||||
rt_fts->gen0_size = 1;
|
rt_fts->gen0_size = 1;
|
||||||
scheme_future_thread_state = rt_fts;
|
scheme_future_thread_state = rt_fts;
|
||||||
|
rt_fts->thread = scheme_current_thread;
|
||||||
|
|
||||||
REGISTER_SO(fs->future_queue);
|
REGISTER_SO(fs->future_queue);
|
||||||
REGISTER_SO(fs->future_queue_end);
|
REGISTER_SO(fs->future_queue_end);
|
||||||
|
|
@ -617,7 +619,7 @@ void futures_init(void)
|
||||||
syms[FEVENT_HANDLE_RTCALL] = sym;
|
syms[FEVENT_HANDLE_RTCALL] = sym;
|
||||||
|
|
||||||
sym = scheme_intern_symbol("future-event");
|
sym = scheme_intern_symbol("future-event");
|
||||||
stype = scheme_lookup_prefab_type(sym, 5);
|
stype = scheme_lookup_prefab_type(sym, 6);
|
||||||
fs->fevent_prefab = stype;
|
fs->fevent_prefab = stype;
|
||||||
|
|
||||||
init_fevent(&fs->runtime_fevents);
|
init_fevent(&fs->runtime_fevents);
|
||||||
|
|
@ -968,8 +970,8 @@ static void free_fevent(Fevent_Buffer *b)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
static void record_fevent(int what, int fid) XFORM_SKIP_PROC
|
static void record_fevent_with_data(int what, int fid, int data)
|
||||||
/* call with the lock or in the runtime thread */
|
XFORM_SKIP_PROC
|
||||||
{
|
{
|
||||||
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
|
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
|
||||||
Fevent_Buffer *b;
|
Fevent_Buffer *b;
|
||||||
|
|
@ -985,6 +987,7 @@ static void record_fevent(int what, int fid) XFORM_SKIP_PROC
|
||||||
b->a[b->pos].timestamp = get_future_timestamp();
|
b->a[b->pos].timestamp = get_future_timestamp();
|
||||||
b->a[b->pos].what = what;
|
b->a[b->pos].what = what;
|
||||||
b->a[b->pos].fid = fid;
|
b->a[b->pos].fid = fid;
|
||||||
|
b->a[b->pos].data = data;
|
||||||
|
|
||||||
b->pos++;
|
b->pos++;
|
||||||
if (b->pos == FEVENT_BUFFER_SIZE) {
|
if (b->pos == FEVENT_BUFFER_SIZE) {
|
||||||
|
|
@ -993,6 +996,12 @@ static void record_fevent(int what, int fid) XFORM_SKIP_PROC
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
static void record_fevent(int what, int fid) XFORM_SKIP_PROC
|
||||||
|
/* call with the lock or in the runtime thread */
|
||||||
|
{
|
||||||
|
record_fevent_with_data(what, fid, 0);
|
||||||
|
}
|
||||||
|
|
||||||
static void init_traversal(Fevent_Buffer *b)
|
static void init_traversal(Fevent_Buffer *b)
|
||||||
{
|
{
|
||||||
if (b->overflow) {
|
if (b->overflow) {
|
||||||
|
|
@ -1010,18 +1019,19 @@ static void end_traversal(Fevent_Buffer *b)
|
||||||
b->pos = 0;
|
b->pos = 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
static void log_future_event(Scheme_Future_State *fs,
|
static void log_future_event_with_data(Scheme_Future_State *fs,
|
||||||
const char *msg_str,
|
const char *msg_str,
|
||||||
const char *extra_str,
|
const char *extra_str,
|
||||||
int which,
|
int which,
|
||||||
int what,
|
int what,
|
||||||
double timestamp,
|
double timestamp,
|
||||||
int fid)
|
int fid,
|
||||||
|
int user_data)
|
||||||
{
|
{
|
||||||
Scheme_Object *data, *v;
|
Scheme_Object *data, *v;
|
||||||
|
|
||||||
data = scheme_make_blank_prefab_struct_instance(fs->fevent_prefab);
|
data = scheme_make_blank_prefab_struct_instance(fs->fevent_prefab);
|
||||||
if (what == FEVENT_MISSING)
|
if (what == FEVENT_MISSING || fid == NO_FUTURE_ID)
|
||||||
((Scheme_Structure *)data)->slots[0] = scheme_false;
|
((Scheme_Structure *)data)->slots[0] = scheme_false;
|
||||||
else
|
else
|
||||||
((Scheme_Structure *)data)->slots[0] = scheme_make_integer(fid);
|
((Scheme_Structure *)data)->slots[0] = scheme_make_integer(fid);
|
||||||
|
|
@ -1034,12 +1044,15 @@ static void log_future_event(Scheme_Future_State *fs,
|
||||||
((Scheme_Structure *)data)->slots[2] = v;
|
((Scheme_Structure *)data)->slots[2] = v;
|
||||||
v = scheme_make_double(timestamp);
|
v = scheme_make_double(timestamp);
|
||||||
((Scheme_Structure *)data)->slots[3] = v;
|
((Scheme_Structure *)data)->slots[3] = v;
|
||||||
if (what == FEVENT_HANDLE_RTCALL) {
|
if (what == FEVENT_HANDLE_RTCALL || what == FEVENT_HANDLE_RTCALL_ATOMIC) {
|
||||||
v = scheme_intern_symbol(extra_str);
|
v = scheme_intern_symbol(extra_str);
|
||||||
((Scheme_Structure *)data)->slots[4] = v;
|
((Scheme_Structure *)data)->slots[4] = v;
|
||||||
} else
|
} else
|
||||||
((Scheme_Structure *)data)->slots[4] = scheme_false;
|
((Scheme_Structure *)data)->slots[4] = scheme_false;
|
||||||
|
|
||||||
|
/* User data (target fid for creates, alloc amount for allocation */
|
||||||
|
((Scheme_Structure *)data)->slots[5] = scheme_make_integer(user_data);
|
||||||
|
|
||||||
scheme_log_w_data(scheme_main_logger, SCHEME_LOG_DEBUG, 0,
|
scheme_log_w_data(scheme_main_logger, SCHEME_LOG_DEBUG, 0,
|
||||||
data,
|
data,
|
||||||
msg_str,
|
msg_str,
|
||||||
|
|
@ -1048,6 +1061,25 @@ static void log_future_event(Scheme_Future_State *fs,
|
||||||
fevent_long_strs[what],
|
fevent_long_strs[what],
|
||||||
extra_str,
|
extra_str,
|
||||||
timestamp);
|
timestamp);
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
static void log_future_event(Scheme_Future_State *fs,
|
||||||
|
const char *msg_str,
|
||||||
|
const char *extra_str,
|
||||||
|
int which,
|
||||||
|
int what,
|
||||||
|
double timestamp,
|
||||||
|
int fid)
|
||||||
|
{
|
||||||
|
log_future_event_with_data(fs,
|
||||||
|
msg_str,
|
||||||
|
extra_str,
|
||||||
|
which,
|
||||||
|
what,
|
||||||
|
timestamp,
|
||||||
|
fid,
|
||||||
|
0);
|
||||||
}
|
}
|
||||||
|
|
||||||
static void log_overflow_event(Scheme_Future_State *fs, int which, double timestamp)
|
static void log_overflow_event(Scheme_Future_State *fs, int which, double timestamp)
|
||||||
|
|
@ -1135,13 +1167,14 @@ static void flush_future_logs(Scheme_Future_State *fs)
|
||||||
if (!min_b)
|
if (!min_b)
|
||||||
break;
|
break;
|
||||||
|
|
||||||
log_future_event(fs,
|
log_future_event_with_data(fs,
|
||||||
"future %d, process %d: %s%s; time: %f",
|
"future %d, process %d: %s%s; time: %f",
|
||||||
"",
|
"",
|
||||||
min_which,
|
min_which,
|
||||||
min_b->a[min_b->i].what,
|
min_b->a[min_b->i].what,
|
||||||
min_b->a[min_b->i].timestamp,
|
min_b->a[min_b->i].timestamp,
|
||||||
min_b->a[min_b->i].fid);
|
min_b->a[min_b->i].fid,
|
||||||
|
min_b->a[min_b->i].data);
|
||||||
|
|
||||||
--min_b->count;
|
--min_b->count;
|
||||||
min_b->i++;
|
min_b->i++;
|
||||||
|
|
@ -1176,7 +1209,7 @@ void scheme_wrong_contract_from_ft(const char *who, const char *expected_type, i
|
||||||
scheme_wrong_contract(who, expected_type, what, argc, argv);
|
scheme_wrong_contract(who, expected_type, what, argc, argv);
|
||||||
|
|
||||||
|
|
||||||
static Scheme_Object *make_future(Scheme_Object *lambda, int enqueue)
|
static Scheme_Object *make_future(Scheme_Object *lambda, int enqueue, future_t *cur_ft)
|
||||||
/* Called in runtime thread --- as atomic on behalf of a future thread
|
/* Called in runtime thread --- as atomic on behalf of a future thread
|
||||||
if `lambda' is known to be a thunk */
|
if `lambda' is known to be a thunk */
|
||||||
{
|
{
|
||||||
|
|
@ -1225,7 +1258,7 @@ static Scheme_Object *make_future(Scheme_Object *lambda, int enqueue)
|
||||||
mzrt_mutex_lock(fs->future_mutex);
|
mzrt_mutex_lock(fs->future_mutex);
|
||||||
futureid = ++fs->next_futureid;
|
futureid = ++fs->next_futureid;
|
||||||
ft->id = futureid;
|
ft->id = futureid;
|
||||||
record_fevent(FEVENT_CREATE, futureid);
|
record_fevent_with_data(FEVENT_CREATE, (cur_ft ? cur_ft->id : NO_FUTURE_ID), futureid);
|
||||||
if (enqueue) {
|
if (enqueue) {
|
||||||
if (ft->status != PENDING_OVERSIZE)
|
if (ft->status != PENDING_OVERSIZE)
|
||||||
enqueue_future(fs, ft);
|
enqueue_future(fs, ft);
|
||||||
|
|
@ -1244,18 +1277,24 @@ int scheme_can_apply_native_in_future(Scheme_Object *proc)
|
||||||
return (((Scheme_Native_Closure *)proc)->code->max_let_depth < FUTURE_RUNSTACK_SIZE * sizeof(void*));
|
return (((Scheme_Native_Closure *)proc)->code->max_let_depth < FUTURE_RUNSTACK_SIZE * sizeof(void*));
|
||||||
}
|
}
|
||||||
|
|
||||||
static Scheme_Object *do_make_future(int argc, Scheme_Object *argv[])
|
static Scheme_Object *do_make_future(int argc, Scheme_Object *argv[], future_t *cur_ft)
|
||||||
{
|
{
|
||||||
|
Scheme_Future_State *fs;
|
||||||
scheme_check_proc_arity("future", 0, 0, argc, argv);
|
scheme_check_proc_arity("future", 0, 0, argc, argv);
|
||||||
return make_future(argv[0], 1);
|
|
||||||
|
fs = scheme_future_state;
|
||||||
|
flush_future_logs(fs);
|
||||||
|
|
||||||
|
return make_future(argv[0], 1, cur_ft);
|
||||||
}
|
}
|
||||||
|
|
||||||
Scheme_Object *scheme_future(int argc, Scheme_Object *argv[])
|
Scheme_Object *scheme_future(int argc, Scheme_Object *argv[])
|
||||||
XFORM_SKIP_PROC /* can be called from future thread */
|
XFORM_SKIP_PROC /* can be called from future thread */
|
||||||
{
|
{
|
||||||
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
|
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
|
||||||
if (fts->is_runtime_thread)
|
if (fts->is_runtime_thread) {
|
||||||
return do_make_future(argc, argv);
|
return do_make_future(argc, argv, (scheme_current_thread ? scheme_current_thread->current_ft : NULL));
|
||||||
|
}
|
||||||
else {
|
else {
|
||||||
Scheme_Object *proc = argv[0];
|
Scheme_Object *proc = argv[0];
|
||||||
#ifdef MZ_PRECISE_GC
|
#ifdef MZ_PRECISE_GC
|
||||||
|
|
@ -1267,6 +1306,7 @@ Scheme_Object *scheme_future(int argc, Scheme_Object *argv[])
|
||||||
future_t *ft;
|
future_t *ft;
|
||||||
ft = MALLOC_ONE_TAGGED(future_t);
|
ft = MALLOC_ONE_TAGGED(future_t);
|
||||||
if (ft) {
|
if (ft) {
|
||||||
|
future_t *cur_ft = scheme_current_thread->current_ft;
|
||||||
Scheme_Future_State *fs = scheme_future_state;
|
Scheme_Future_State *fs = scheme_future_state;
|
||||||
|
|
||||||
ft->so.type = scheme_future_type;
|
ft->so.type = scheme_future_type;
|
||||||
|
|
@ -1276,7 +1316,7 @@ Scheme_Object *scheme_future(int argc, Scheme_Object *argv[])
|
||||||
|
|
||||||
mzrt_mutex_lock(fs->future_mutex);
|
mzrt_mutex_lock(fs->future_mutex);
|
||||||
ft->id = ++fs->next_futureid;
|
ft->id = ++fs->next_futureid;
|
||||||
record_fevent(FEVENT_CREATE, ft->id);
|
record_fevent_with_data(FEVENT_CREATE, (cur_ft ? cur_ft->id : NO_FUTURE_ID), ft->id);
|
||||||
enqueue_future(fs, ft);
|
enqueue_future(fs, ft);
|
||||||
mzrt_mutex_unlock(fs->future_mutex);
|
mzrt_mutex_unlock(fs->future_mutex);
|
||||||
|
|
||||||
|
|
@ -1301,9 +1341,11 @@ static Scheme_Object *would_be_future(int argc, Scheme_Object *argv[])
|
||||||
/* Called in runtime thread */
|
/* Called in runtime thread */
|
||||||
{
|
{
|
||||||
future_t *ft;
|
future_t *ft;
|
||||||
|
Scheme_Future_Thread_State *fts;
|
||||||
scheme_check_proc_arity("would-be-future", 0, 0, argc, argv);
|
scheme_check_proc_arity("would-be-future", 0, 0, argc, argv);
|
||||||
|
fts = scheme_future_thread_state;
|
||||||
|
|
||||||
ft = (future_t*)make_future(argv[0], 0);
|
ft = (future_t*)make_future(argv[0], 0, (fts->thread ? fts->thread->current_ft : NULL));
|
||||||
ft->in_tracing_mode = 1;
|
ft->in_tracing_mode = 1;
|
||||||
ft->fts = scheme_future_thread_state;
|
ft->fts = scheme_future_thread_state;
|
||||||
|
|
||||||
|
|
@ -1784,6 +1826,10 @@ static int future_in_runtime(Scheme_Future_State *fs, future_t * volatile ft, in
|
||||||
future_t * volatile old_ft;
|
future_t * volatile old_ft;
|
||||||
int done;
|
int done;
|
||||||
|
|
||||||
|
//FUTURE_ASSERT((!scheme_future_thread_state && !p->current_ft) || scheme_future_thread_state);
|
||||||
|
//FUTURE_ASSERT(scheme_future_thread_state->thread == p);
|
||||||
|
//FUTURE_ASSERT(scheme_future_thread_state->thread->current_ft == p->current_ft);
|
||||||
|
|
||||||
old_ft = p->current_ft;
|
old_ft = p->current_ft;
|
||||||
p->current_ft = ft;
|
p->current_ft = ft;
|
||||||
|
|
||||||
|
|
@ -1990,17 +2036,20 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
|
||||||
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
|
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
|
||||||
if (fts->is_runtime_thread) {
|
if (fts->is_runtime_thread) {
|
||||||
future_t *ft;
|
future_t *ft;
|
||||||
|
future_t *targ_ft;
|
||||||
if (fts->thread
|
if (fts->thread
|
||||||
&& (ft = fts->thread->current_ft)
|
&& (ft = fts->thread->current_ft)
|
||||||
&& ft->in_tracing_mode) {
|
&& ft->in_tracing_mode) {
|
||||||
|
targ_ft = (future_t*)argv[0];
|
||||||
Scheme_Future_State *fs = scheme_future_state;
|
Scheme_Future_State *fs = scheme_future_state;
|
||||||
log_future_event( fs,
|
log_future_event_with_data( fs,
|
||||||
"future %d, process %d: %s: %s; time: %f",
|
"future %d, process %d: %s: %s; time: %f",
|
||||||
"touch",
|
"touch",
|
||||||
-1,
|
-1,
|
||||||
FEVENT_RTCALL_TOUCH,
|
FEVENT_RTCALL_TOUCH,
|
||||||
get_future_timestamp(),
|
get_future_timestamp(),
|
||||||
ft->id);
|
ft->id,
|
||||||
|
targ_ft->id);
|
||||||
}
|
}
|
||||||
|
|
||||||
return general_touch(argc, argv);
|
return general_touch(argc, argv);
|
||||||
|
|
@ -2658,6 +2707,8 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts,
|
||||||
runtime thread so we can log all of its primitive applications). */
|
runtime thread so we can log all of its primitive applications). */
|
||||||
{
|
{
|
||||||
future_t *future;
|
future_t *future;
|
||||||
|
future_t *targ_future;
|
||||||
|
Scheme_Object **prim_argv;
|
||||||
Scheme_Future_State *fs = scheme_future_state;
|
Scheme_Future_State *fs = scheme_future_state;
|
||||||
void *storage[4];
|
void *storage[4];
|
||||||
int insist_to_suspend, prefer_to_suspend, fid;
|
int insist_to_suspend, prefer_to_suspend, fid;
|
||||||
|
|
@ -2836,6 +2887,7 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts,
|
||||||
scheme_future_longjmp(*scheme_current_thread->error_buf, 1);
|
scheme_future_longjmp(*scheme_current_thread->error_buf, 1);
|
||||||
} else {
|
} else {
|
||||||
FUTURE_ASSERT(future->status == RUNNING);
|
FUTURE_ASSERT(future->status == RUNNING);
|
||||||
|
record_fevent(FEVENT_START_WORK, fid);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -3270,14 +3322,25 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future)
|
||||||
|
|
||||||
flush_future_logs(fs);
|
flush_future_logs(fs);
|
||||||
|
|
||||||
/* use log_future_event so we can include `str' in the message: */
|
/* use lg_future_event so we can include `str' in the message: */
|
||||||
log_future_event(fs,
|
if (future->prim_protocol == SIG_ALLOC) {
|
||||||
"future %d, process %d: %s: %s; time: %f",
|
log_future_event_with_data(fs,
|
||||||
src,
|
"future %d, process %d: %s: %s; time: %f",
|
||||||
-1,
|
src,
|
||||||
(future->rt_prim_is_atomic ? FEVENT_HANDLE_RTCALL_ATOMIC : FEVENT_HANDLE_RTCALL),
|
-1,
|
||||||
get_future_timestamp(),
|
(future->rt_prim_is_atomic ? FEVENT_HANDLE_RTCALL_ATOMIC : FEVENT_HANDLE_RTCALL),
|
||||||
future->id);
|
get_future_timestamp(),
|
||||||
|
future->id,
|
||||||
|
future->arg_i0);
|
||||||
|
} else {
|
||||||
|
log_future_event(fs,
|
||||||
|
"future %d, process %d: %s: %s; time: %f",
|
||||||
|
src,
|
||||||
|
-1,
|
||||||
|
(future->rt_prim_is_atomic ? FEVENT_HANDLE_RTCALL_ATOMIC : FEVENT_HANDLE_RTCALL),
|
||||||
|
get_future_timestamp(),
|
||||||
|
future->id);
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
if (((future->source_type == FSRC_RATOR)
|
if (((future->source_type == FSRC_RATOR)
|
||||||
|
|
@ -3336,7 +3399,7 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future)
|
||||||
{
|
{
|
||||||
Scheme_Object *s = future->arg_s1;
|
Scheme_Object *s = future->arg_s1;
|
||||||
future->arg_s1 = NULL;
|
future->arg_s1 = NULL;
|
||||||
s = make_future(s, 1);
|
s = make_future(s, 1, future);
|
||||||
future->retval_s = s;
|
future->retval_s = s;
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -45,7 +45,7 @@ typedef void* (*prim_pvoid_pvoid_pvoid_t)(void*, void*);
|
||||||
|
|
||||||
typedef struct Fevent {
|
typedef struct Fevent {
|
||||||
double timestamp;
|
double timestamp;
|
||||||
int what, fid;
|
int what, fid, data;
|
||||||
} Fevent;
|
} Fevent;
|
||||||
|
|
||||||
typedef struct Fevent_Buffer {
|
typedef struct Fevent_Buffer {
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user