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

Add futures visualizer, improvements to futures logging

Browse Source
This commit is contained in:
James Swaine 2012-02-29 11:43:33 -06:00
parent 48e154e3cb
commit b6f71ec4be
23 changed files with 3520 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/racket/future/private/constants.rkt Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

@ -0,0 +1,5 @@
#lang racket/base
(require "private/visualizer-gui.rkt"
"private/visualizer-data.rkt")
(provide start-performance-tracking!
show-visualizer)

398
collects/scribblings/guide/futures.scrbl
View File

@ -1,7 +1,12 @@
#lang scribble/doc
@(require scribble/manual "guide-utils.rkt"
@(require scribble/manual scribble/eval "guide-utils.rkt"
(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}
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)].
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
implementation. The distinction between ``safe'' and ``unsafe''
notion of ``future safe'' is inherently tied to the
implementation. The distinction between ``future safe'' and ``future unsafe''
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:
@ -72,10 +80,10 @@ Consider the following core of a Mandelbrot-set computation:
(let ([zrq (* zr zr)]
[ziq (* zi zi)])
(cond
[(> (+ zrq ziq) 4.0) i]
[(> (+ zrq ziq) 4) i]
[else (loop (add1 i)
(+ (- zrq ziq) cr)
(+ (* 2.0 zr zi) ci))]))))))
(+ (* 2 zr zi) ci))]))))))
]
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)))
]
One problem is that the @racket[*] and @racket[/] operations in the
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.
To see why, use the @racketmodname[racket/future/visualizer], like this:
Changing the first two lines of @racket[mandelbrot] addresses that
first the problem:
@racketblock[
(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[
(define (mandelbrot iterations x y n)
(let ([ci (- (/ (* 2.0 (->fl y)) (->fl n)) 1.0)]
[cr (- (/ (* 2.0 (->fl x)) (->fl n)) 1.5)])
....))
(let ([ci (- (/ (* 2.0 y) n) 1.0)]
[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
parallel. Nevertheless, performance still does not improve. The
problem is that most every arithmetic operation in this example
produces an inexact number whose storage must be allocated. Especially
frequent allocation triggers communication between parallel tasks that
defeats any performance improvement.
With that change, @racket[mandelbrot] computations can run in
parallel. Nevertheless, we still see a special type of
slow-path operation limiting our parallelism (orange dots):
@interaction-eval[
#: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
@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:
@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[
(define (mandelbrot iterations x y n)
(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
in sequential mode, but avoiding allocation also allows
@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
@tech{JIT} compiler runs safely in parallel, while other operations
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
@secref[#:doc '(lib "scribblings/raco/raco.scrbl") "decompile"]), so the
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
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 27 KiB

BIN
collects/scribblings/guide/mand-bad.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 24 KiB

BIN
collects/scribblings/guide/mand-good.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 25 KiB

BIN
collects/scribblings/guide/vis-main.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 24 KiB

1
collects/scribblings/reference/concurrency.scrbl
View File

@ -17,5 +17,6 @@ support for parallelism to improve performance.
@include-section["sync.scrbl"]
@include-section["thread-local.scrbl"]
@include-section["futures.scrbl"]
@include-section["futures-visualizer.scrbl"]
@include-section["places.scrbl"]
@include-section["distributed.scrbl"]

86
collects/scribblings/reference/futures-visualizer.scrbl Normal file
View 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}.

18
collects/scribblings/reference/futures.scrbl
View File

@ -183,16 +183,16 @@ Racket futures use logging (see @secref["logging"]) extensively to
report information about how futures are evaluated. Logging output is
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
a data value that is an instance of a @racket[future-event]
@tech{prefab} structure:
@racketblock[
(define-struct future-event (future-id
proc-id
action
time
unsafe-op-name)
(define-struct future-event (future-id proc-id action time unsafe-op-name target-fid)
#: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
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
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
View 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))
))

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

@ -15,7 +15,7 @@ We should also test deep continuations.
|#
;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)
(define (get-events-of-type type log)

273
collects/tests/future/visualizer.rkt Normal file
View 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
View 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)

145
src/racket/src/future.c
View File

@ -39,7 +39,7 @@ Scheme_Object *scheme_fsemaphore_p(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;
#else
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 FEVENT_BUFFER_SIZE 512
#define NO_FUTURE_ID -1
enum {
FEVENT_CREATE,
@ -589,6 +590,7 @@ void futures_init(void)
rt_fts->is_runtime_thread = 1;
rt_fts->gen0_size = 1;
scheme_future_thread_state = rt_fts;
rt_fts->thread = scheme_current_thread;
REGISTER_SO(fs->future_queue);
REGISTER_SO(fs->future_queue_end);
@ -617,7 +619,7 @@ void futures_init(void)
syms[FEVENT_HANDLE_RTCALL] = sym;
sym = scheme_intern_symbol("future-event");
stype = scheme_lookup_prefab_type(sym, 5);
stype = scheme_lookup_prefab_type(sym, 6);
fs->fevent_prefab = stype;
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
/* call with the lock or in the runtime thread */
static void record_fevent_with_data(int what, int fid, int data)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
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].what = what;
b->a[b->pos].fid = fid;
b->a[b->pos].data = data;
b->pos++;
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)
{
if (b->overflow) {
@ -1010,18 +1019,19 @@ static void end_traversal(Fevent_Buffer *b)
b->pos = 0;
}
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)
static void log_future_event_with_data(Scheme_Future_State *fs,
const char *msg_str,
const char *extra_str,
int which,
int what,
double timestamp,
int fid,
int user_data)
{
Scheme_Object *data, *v;
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;
else
((Scheme_Structure *)data)->slots[0] = scheme_make_integer(fid);
@ -1034,11 +1044,14 @@ static void log_future_event(Scheme_Future_State *fs,
((Scheme_Structure *)data)->slots[2] = v;
v = scheme_make_double(timestamp);
((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);
((Scheme_Structure *)data)->slots[4] = v;
} else
((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,
data,
@ -1048,6 +1061,25 @@ static void log_future_event(Scheme_Future_State *fs,
fevent_long_strs[what],
extra_str,
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)
@ -1135,13 +1167,14 @@ static void flush_future_logs(Scheme_Future_State *fs)
if (!min_b)
break;
log_future_event(fs,
log_future_event_with_data(fs,
"future %d, process %d: %s%s; time: %f",
"",
min_which,
min_b->a[min_b->i].what,
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->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);
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
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);
futureid = ++fs->next_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 (ft->status != PENDING_OVERSIZE)
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*));
}
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);
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[])
XFORM_SKIP_PROC /* can be called from future thread */
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
if (fts->is_runtime_thread)
return do_make_future(argc, argv);
if (fts->is_runtime_thread) {
return do_make_future(argc, argv, (scheme_current_thread ? scheme_current_thread->current_ft : NULL));
}
else {
Scheme_Object *proc = argv[0];
#ifdef MZ_PRECISE_GC
@ -1267,6 +1306,7 @@ Scheme_Object *scheme_future(int argc, Scheme_Object *argv[])
future_t *ft;
ft = MALLOC_ONE_TAGGED(future_t);
if (ft) {
future_t *cur_ft = scheme_current_thread->current_ft;
Scheme_Future_State *fs = scheme_future_state;
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);
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);
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 */
{
future_t *ft;
Scheme_Future_Thread_State *fts;
scheme_check_proc_arity("would-be-future", 0, 0, argc, argv);
ft = (future_t*)make_future(argv[0], 0);
fts = scheme_future_thread_state;
ft = (future_t*)make_future(argv[0], 0, (fts->thread ? fts->thread->current_ft : NULL));
ft->in_tracing_mode = 1;
ft->fts = scheme_future_thread_state;
@ -1779,11 +1821,15 @@ static Scheme_Object *shallower_apply_future_lw_k(void)
static int future_in_runtime(Scheme_Future_State *fs, future_t * volatile ft, int what)
{
mz_jmp_buf newbuf, * volatile savebuf;
Scheme_Thread *p = scheme_current_thread;
Scheme_Thread *p = scheme_current_thread;
Scheme_Object * volatile retval;
future_t * volatile old_ft;
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;
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;
if (fts->is_runtime_thread) {
future_t *ft;
future_t *targ_ft;
if (fts->thread
&& (ft = fts->thread->current_ft)
&& ft->in_tracing_mode) {
targ_ft = (future_t*)argv[0];
Scheme_Future_State *fs = scheme_future_state;
log_future_event( fs,
"future %d, process %d: %s: %s; time: %f",
"touch",
-1,
FEVENT_RTCALL_TOUCH,
get_future_timestamp(),
ft->id);
log_future_event_with_data( fs,
"future %d, process %d: %s: %s; time: %f",
"touch",
-1,
FEVENT_RTCALL_TOUCH,
get_future_timestamp(),
ft->id,
targ_ft->id);
}
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). */
{
future_t *future;
future_t *targ_future;
Scheme_Object **prim_argv;
Scheme_Future_State *fs = scheme_future_state;
void *storage[4];
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);
} else {
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);
/* use log_future_event so we can include `str' in the message: */
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);
/* use lg_future_event so we can include `str' in the message: */
if (future->prim_protocol == SIG_ALLOC) {
log_future_event_with_data(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,
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)
@ -3336,7 +3399,7 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future)
{
Scheme_Object *s = future->arg_s1;
future->arg_s1 = NULL;
s = make_future(s, 1);
s = make_future(s, 1, future);
future->retval_s = s;
break;
}

2
src/racket/src/future.h
View File

@ -45,7 +45,7 @@ typedef void* (*prim_pvoid_pvoid_pvoid_t)(void*, void*);
typedef struct Fevent {
double timestamp;
int what, fid;
int what, fid, data;
} Fevent;
typedef struct Fevent_Buffer {