diff --git a/collects/racket/future/private/constants.rkt b/collects/racket/future/private/constants.rkt new file mode 100644 index 0000000000..6bd3a1ab68 --- /dev/null +++ b/collects/racket/future/private/constants.rkt @@ -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) \ No newline at end of file diff --git a/collects/racket/future/private/display.rkt b/collects/racket/future/private/display.rkt new file mode 100644 index 0000000000..21f75e6fea --- /dev/null +++ b/collects/racket/future/private/display.rkt @@ -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)))) + + + + + diff --git a/collects/racket/future/private/drawing-helpers.rkt b/collects/racket/future/private/drawing-helpers.rkt new file mode 100644 index 0000000000..1005705522 --- /dev/null +++ b/collects/racket/future/private/drawing-helpers.rkt @@ -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.")]))) \ No newline at end of file diff --git a/collects/racket/future/private/graph-drawing.rkt b/collects/racket/future/private/graph-drawing.rkt new file mode 100644 index 0000000000..31f9d8de71 --- /dev/null +++ b/collects/racket/future/private/graph-drawing.rkt @@ -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)) + + + + + + + + + + + + \ No newline at end of file diff --git a/collects/racket/future/private/gui-helpers.rkt b/collects/racket/future/private/gui-helpers.rkt new file mode 100644 index 0000000000..0214ed1f7e --- /dev/null +++ b/collects/racket/future/private/gui-helpers.rkt @@ -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)))))) + + + + + + + \ No newline at end of file diff --git a/collects/racket/future/private/visualizer-data.rkt b/collects/racket/future/private/visualizer-data.rkt new file mode 100644 index 0000000000..39168ca3da --- /dev/null +++ b/collects/racket/future/private/visualizer-data.rkt @@ -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)) \ No newline at end of file diff --git a/collects/racket/future/private/visualizer-drawing.rkt b/collects/racket/future/private/visualizer-drawing.rkt new file mode 100644 index 0000000000..f73fae56c9 --- /dev/null +++ b/collects/racket/future/private/visualizer-drawing.rkt @@ -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)))) + \ No newline at end of file diff --git a/collects/racket/future/private/visualizer-gui.rkt b/collects/racket/future/private/visualizer-gui.rkt new file mode 100644 index 0000000000..8204dd1ea0 --- /dev/null +++ b/collects/racket/future/private/visualizer-gui.rkt @@ -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))) diff --git a/collects/racket/future/visualizer.rkt b/collects/racket/future/visualizer.rkt new file mode 100644 index 0000000000..cbb8c5f7c4 --- /dev/null +++ b/collects/racket/future/visualizer.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "private/visualizer-gui.rkt" + "private/visualizer-data.rkt") +(provide start-performance-tracking! + show-visualizer) \ No newline at end of file diff --git a/collects/scribblings/guide/futures.scrbl b/collects/scribblings/guide/futures.scrbl index d3cffaa30d..5ba685e522 100644 --- a/collects/scribblings/guide/futures.scrbl +++ b/collects/scribblings/guide/futures.scrbl @@ -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. diff --git a/collects/scribblings/guide/mand-bad-hover.png b/collects/scribblings/guide/mand-bad-hover.png new file mode 100644 index 0000000000..5fa5300ba9 Binary files /dev/null and b/collects/scribblings/guide/mand-bad-hover.png differ diff --git a/collects/scribblings/guide/mand-bad.png b/collects/scribblings/guide/mand-bad.png new file mode 100644 index 0000000000..af747a73f6 Binary files /dev/null and b/collects/scribblings/guide/mand-bad.png differ diff --git a/collects/scribblings/guide/mand-good.png b/collects/scribblings/guide/mand-good.png new file mode 100644 index 0000000000..ed34b47c1a Binary files /dev/null and b/collects/scribblings/guide/mand-good.png differ diff --git a/collects/scribblings/guide/vis-main.png b/collects/scribblings/guide/vis-main.png new file mode 100644 index 0000000000..bdd529ec3b Binary files /dev/null and b/collects/scribblings/guide/vis-main.png differ diff --git a/collects/scribblings/reference/concurrency.scrbl b/collects/scribblings/reference/concurrency.scrbl index 15ac304602..bb544e7a20 100644 --- a/collects/scribblings/reference/concurrency.scrbl +++ b/collects/scribblings/reference/concurrency.scrbl @@ -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"] diff --git a/collects/scribblings/reference/futures-visualizer.scrbl b/collects/scribblings/reference/futures-visualizer.scrbl new file mode 100644 index 0000000000..0d33d4a29f --- /dev/null +++ b/collects/scribblings/reference/futures-visualizer.scrbl @@ -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}. diff --git a/collects/scribblings/reference/futures.scrbl b/collects/scribblings/reference/futures.scrbl index 35574cade0..eec3b5a565 100644 --- a/collects/scribblings/reference/futures.scrbl +++ b/collects/scribblings/reference/futures.scrbl @@ -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]. @; ---------------------------------------------------------------------- diff --git a/collects/tests/future/bad-trace1.rkt b/collects/tests/future/bad-trace1.rkt new file mode 100644 index 0000000000..63ee6eeae2 --- /dev/null +++ b/collects/tests/future/bad-trace1.rkt @@ -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)) +)) diff --git a/collects/tests/future/future.rkt b/collects/tests/future/future.rkt index d2ed59f75f..4bf15599f6 100644 --- a/collects/tests/future/future.rkt +++ b/collects/tests/future/future.rkt @@ -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) diff --git a/collects/tests/future/visualizer.rkt b/collects/tests/future/visualizer.rkt new file mode 100644 index 0000000000..8741a8f24d --- /dev/null +++ b/collects/tests/future/visualizer.rkt @@ -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)) + + + + + + + diff --git a/qsort2.rkt b/qsort2.rkt new file mode 100644 index 0000000000..a6bf7e37a9 --- /dev/null +++ b/qsort2.rkt @@ -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) diff --git a/src/racket/src/future.c b/src/racket/src/future.c index 9dc48c1095..49db9dfb01 100644 --- a/src/racket/src/future.c +++ b/src/racket/src/future.c @@ -39,7 +39,7 @@ Scheme_Object *scheme_fsemaphore_p(int argc, Scheme_Object *argv[]) static Scheme_Object *futures_enabled(int argc, Scheme_Object *argv[]) { -#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; } diff --git a/src/racket/src/future.h b/src/racket/src/future.h index 8787100ac3..7895ee122d 100644 --- a/src/racket/src/future.h +++ b/src/racket/src/future.h @@ -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 {