1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license
3 USING: accessors compiler.tree.builder compiler.cfg compiler.cfg.rpo
4 compiler.cfg.dominance compiler.cfg.dominance.private
5 compiler.cfg.predecessors compiler.cfg.debugger compiler.cfg.optimizer
6 compiler.cfg.utilities compiler.tree.recursive images.viewer
7 images.png io io.encodings.ascii io.files io.files.unique io.launcher
8 kernel math.parser sequences assocs arrays make math namespaces
9 quotations combinators locals words ;
12 : quotes ( str -- str' ) "\"" "\"" surround ;
14 : graph, ( quot title -- )
16 quotes "digraph " " {" surround ,
21 : render-graph ( quot -- name )
23 "cfg" ".dot" make-unique-file
24 dup "Wrote " prepend print
25 [ [ concat ] dip ascii set-file-lines ]
26 [ { "dot" "-Tpng" "-O" } swap suffix try-process ]
30 : display-graph ( name -- )
31 "open" swap 2array try-process ;
33 : attrs>string ( seq -- str )
34 [ "" ] [ "," join "[" "]" surround ] if-empty ;
36 : edge,* ( from to attrs -- )
38 [ quotes % " -> " % ] [ quotes % " " % ] [ attrs>string % ] tri*
42 : edge, ( from to -- )
45 : bb-edge, ( from to -- )
46 [ number>> number>string ] bi@ edge, ;
48 : node-style, ( str attrs -- )
49 [ [ quotes % " " % ] [ attrs>string % ";" % ] bi* ] "" make , ;
51 : cfg-title ( cfg/mr -- string )
54 [ word>> name>> % ", label: " % ]
59 : cfg-vertex, ( bb -- )
60 [ number>> number>string ]
61 [ kill-block? { "color=grey" "style=filled" } { } ? ]
67 [ [ cfg-vertex, ] each-basic-block ]
75 ] over cfg-title graph,
78 : optimized-cfg ( quot -- cfgs )
80 { [ dup cfg? ] [ 1array ] }
81 { [ dup quotation? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
82 { [ dup word? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
86 : render-cfg ( cfg -- name )
87 optimized-cfg [ cfgs ] render-graph ;
89 : dom-trees ( cfgs -- )
98 ] over cfg-title graph,
101 : render-dom ( cfg -- name )
102 optimized-cfg [ dom-trees ] render-graph ;
107 : vertex-name ( call-graph-node -- string )
108 label>> vertex-names get [
110 dup word-counts get [ 0 or 1 + dup ] change-at number>string " #" glue
113 : vertex-attrs ( obj -- string )
114 tail?>> { "style=bold,label=\"tail\"" } { } ? ;
116 : call-graph-edge, ( from to attrs -- )
117 [ [ vertex-name ] [ vertex-attrs ] bi ] dip append edge,* ;
119 : (call-graph-back-edges) ( string calls -- )
120 [ { "color=red" } call-graph-edge, ] with each ;
122 : (call-graph-edges) ( string children -- )
125 [ { } call-graph-edge, ]
126 [ [ vertex-name ] [ label>> loop?>> { "shape=box" } { } ? ] bi node-style, ]
127 [ [ vertex-name ] [ calls>> ] bi (call-graph-back-edges) ]
128 [ [ vertex-name ] [ children>> ] bi (call-graph-edges) ]
132 : call-graph-edges ( call-graph-node -- )
133 H{ } clone word-counts set
134 H{ } clone vertex-names set
135 [ "ROOT" ] dip (call-graph-edges) ;
137 : render-call-graph ( tree -- name )
138 dup quotation? [ build-tree ] when
139 analyze-recursive drop
140 [ [ call-graph get call-graph-edges ] "Call graph" graph, ]