compiler.graphviz: add high-level IR call graph rendering
Slava Pestov
parent
fb03a93763
commit
97ec3ea1b4
|
|
@ -11,7 +11,7 @@ TUPLE: call-site tail? node label ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: call-tree-node tail? label children calls ;
|
||||
TUPLE: call-graph-node tail? label children calls ;
|
||||
|
||||
: (tail-calls) ( tail? seq -- seq' )
|
||||
reverse [ swap [ and ] keep ] map nip reverse ;
|
||||
|
|
@ -27,40 +27,40 @@ TUPLE: call-tree-node tail? label children calls ;
|
|||
|
||||
SYMBOLS: children calls ;
|
||||
|
||||
GENERIC: node-call-tree ( tail? node -- )
|
||||
GENERIC: node-call-graph ( tail? node -- )
|
||||
|
||||
: (build-call-tree) ( tail? nodes -- )
|
||||
: (build-call-graph) ( tail? nodes -- )
|
||||
[ tail-calls ] keep
|
||||
[ node-call-tree ] 2each ;
|
||||
[ node-call-graph ] 2each ;
|
||||
|
||||
: build-call-tree ( nodes -- labels calls )
|
||||
: build-call-graph ( nodes -- labels calls )
|
||||
[
|
||||
V{ } clone children set
|
||||
V{ } clone calls set
|
||||
[ t ] dip (build-call-tree)
|
||||
[ t ] dip (build-call-graph)
|
||||
children get
|
||||
calls get
|
||||
] with-scope ;
|
||||
|
||||
M: #return-recursive node-call-tree
|
||||
M: #return-recursive node-call-graph
|
||||
nip dup label>> (>>return) ;
|
||||
|
||||
M: #call-recursive node-call-tree
|
||||
M: #call-recursive node-call-graph
|
||||
[ dup label>> call-site boa ] keep
|
||||
[ drop calls get push ]
|
||||
[ label>> calls>> push ] 2bi ;
|
||||
|
||||
M: #recursive node-call-tree
|
||||
M: #recursive node-call-graph
|
||||
[ label>> V{ } clone >>calls drop ]
|
||||
[
|
||||
[ label>> ] [ child>> build-call-tree ] bi
|
||||
call-tree-node boa children get push
|
||||
[ label>> ] [ child>> build-call-graph ] bi
|
||||
call-graph-node boa children get push
|
||||
] bi ;
|
||||
|
||||
M: #branch node-call-tree
|
||||
children>> [ (build-call-tree) ] with each ;
|
||||
M: #branch node-call-graph
|
||||
children>> [ (build-call-graph) ] with each ;
|
||||
|
||||
M: node node-call-tree 2drop ;
|
||||
M: node node-call-graph 2drop ;
|
||||
|
||||
SYMBOLS: not-loops recursive-nesting ;
|
||||
|
||||
|
|
@ -68,10 +68,10 @@ SYMBOLS: not-loops recursive-nesting ;
|
|||
|
||||
: not-a-loop? ( label -- ? ) not-loops get key? ;
|
||||
|
||||
: non-tail-calls ( call-tree-node -- seq )
|
||||
: non-tail-calls ( call-graph-node -- seq )
|
||||
calls>> [ tail?>> not ] filter ;
|
||||
|
||||
: visit-back-edges ( call-tree -- )
|
||||
: visit-back-edges ( call-graph -- )
|
||||
[
|
||||
[ non-tail-calls [ label>> not-a-loop ] each ]
|
||||
[ children>> visit-back-edges ]
|
||||
|
|
@ -90,7 +90,7 @@ SYMBOL: changed?
|
|||
] with all? drop
|
||||
] if ;
|
||||
|
||||
: detect-cross-frame-calls ( call-tree -- )
|
||||
: detect-cross-frame-calls ( call-graph -- )
|
||||
! Suppose we have a nesting of recursives A --> B --> C
|
||||
! B tail-calls A, and C non-tail-calls B. Then A cannot be
|
||||
! a loop, it needs its own procedure, since the call from
|
||||
|
|
@ -107,14 +107,14 @@ SYMBOL: changed?
|
|||
[ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
|
||||
inline recursive
|
||||
|
||||
: detect-loops ( call-tree -- )
|
||||
: detect-loops ( call-graph -- )
|
||||
H{ } clone not-loops set
|
||||
V{ } clone recursive-nesting set
|
||||
[ visit-back-edges ]
|
||||
[ '[ _ detect-cross-frame-calls ] while-changing ]
|
||||
bi ;
|
||||
|
||||
: mark-loops ( call-tree -- )
|
||||
: mark-loops ( call-graph -- )
|
||||
[
|
||||
[ label>> dup not-a-loop? [ t >>loop? ] unless drop ]
|
||||
[ children>> mark-loops ]
|
||||
|
|
@ -123,6 +123,11 @@ SYMBOL: changed?
|
|||
|
||||
PRIVATE>
|
||||
|
||||
SYMBOL: call-graph
|
||||
|
||||
: analyze-recursive ( nodes -- nodes )
|
||||
dup build-call-tree drop
|
||||
[ detect-loops ] [ mark-loops ] bi ;
|
||||
dup build-call-graph drop
|
||||
[ call-graph set ]
|
||||
[ detect-loops ]
|
||||
[ mark-loops ]
|
||||
tri ;
|
||||
|
|
|
|||
|
|
@ -1,44 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
USING: accessors compiler.cfg.rpo compiler.cfg.dominance
|
||||
compiler.cfg.dominance.private compiler.cfg.predecessors images.viewer
|
||||
io io.encodings.ascii io.files io.files.unique io.launcher kernel
|
||||
math.parser sequences assocs arrays make namespaces ;
|
||||
IN: compiler.cfg.graphviz
|
||||
|
||||
: render-graph ( edges -- )
|
||||
"cfg" "dot" make-unique-file
|
||||
[
|
||||
ascii [
|
||||
"digraph CFG {" print
|
||||
[ [ number>> number>string ] bi@ " -> " glue write ";" print ] assoc-each
|
||||
"}" print
|
||||
] with-file-writer
|
||||
]
|
||||
[ { "dot" "-Tpng" "-O" } swap suffix try-process ]
|
||||
[ ".png" append { "open" } swap suffix try-process ]
|
||||
tri ;
|
||||
|
||||
: cfg-edges ( cfg -- edges )
|
||||
[
|
||||
[
|
||||
dup successors>> [
|
||||
2array ,
|
||||
] with each
|
||||
] each-basic-block
|
||||
] { } make ;
|
||||
|
||||
: render-cfg ( cfg -- ) cfg-edges render-graph ;
|
||||
|
||||
: dom-edges ( cfg -- edges )
|
||||
[
|
||||
compute-predecessors
|
||||
compute-dominance
|
||||
dom-childrens get [
|
||||
[
|
||||
2array ,
|
||||
] with each
|
||||
] assoc-each
|
||||
] { } make ;
|
||||
|
||||
: render-dom ( cfg -- ) dom-edges render-graph ;
|
||||
|
|
@ -0,0 +1,139 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
USING: accessors compiler.tree.builder compiler.cfg compiler.cfg.rpo
|
||||
compiler.cfg.dominance compiler.cfg.dominance.private
|
||||
compiler.cfg.predecessors compiler.cfg.debugger compiler.cfg.optimizer
|
||||
compiler.cfg.utilities compiler.tree.recursive images.viewer
|
||||
images.png io io.encodings.ascii io.files io.files.unique io.launcher
|
||||
kernel math.parser sequences assocs arrays make math namespaces
|
||||
quotations combinators locals words ;
|
||||
IN: compiler.graphviz
|
||||
|
||||
: quotes ( str -- str' ) "\"" "\"" surround ;
|
||||
|
||||
: graph, ( quot title -- )
|
||||
[
|
||||
quotes "digraph " " {" surround ,
|
||||
call
|
||||
"}" ,
|
||||
] { } make , ; inline
|
||||
|
||||
: render-graph ( quot -- )
|
||||
{ } make
|
||||
"cfg" ".dot" make-unique-file
|
||||
dup "Wrote " prepend print
|
||||
[ [ concat ] dip ascii set-file-lines ]
|
||||
[ { "dot" "-Tpng" "-O" } swap suffix try-process ]
|
||||
[ ".png" append image. ]
|
||||
tri ; inline
|
||||
|
||||
: attrs>string ( seq -- str )
|
||||
[ "" ] [ "," join "[" "]" surround ] if-empty ;
|
||||
|
||||
: edge,* ( from to attrs -- )
|
||||
[
|
||||
[ quotes % " -> " % ] [ quotes % " " % ] [ attrs>string % ] tri*
|
||||
";" %
|
||||
] "" make , ;
|
||||
|
||||
: edge, ( from to -- )
|
||||
{ } edge,* ;
|
||||
|
||||
: bb-edge, ( from to -- )
|
||||
[ number>> number>string ] bi@ edge, ;
|
||||
|
||||
: node-style, ( str attrs -- )
|
||||
[ [ quotes % " " % ] [ attrs>string % ";" % ] bi* ] "" make , ;
|
||||
|
||||
: cfg-title ( cfg/mr -- string )
|
||||
[
|
||||
"=== word: " %
|
||||
[ word>> name>> % ", label: " % ]
|
||||
[ label>> name>> % ]
|
||||
bi
|
||||
] "" make ;
|
||||
|
||||
: cfg-vertex, ( bb -- )
|
||||
[ number>> number>string ]
|
||||
[ kill-block? { "color=grey" "style=filled" } { } ? ]
|
||||
bi node-style, ;
|
||||
|
||||
: cfgs ( cfgs -- )
|
||||
[
|
||||
[
|
||||
[ [ cfg-vertex, ] each-basic-block ]
|
||||
[
|
||||
[
|
||||
dup successors>> [
|
||||
bb-edge,
|
||||
] with each
|
||||
] each-basic-block
|
||||
] bi
|
||||
] over cfg-title graph,
|
||||
] each ;
|
||||
|
||||
: optimized-cfg ( quot -- cfgs )
|
||||
{
|
||||
{ [ dup cfg? ] [ 1array ] }
|
||||
{ [ dup quotation? ] [ test-cfg [ optimize-cfg ] map ] }
|
||||
{ [ dup word? ] [ test-cfg [ optimize-cfg ] map ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
: render-cfg ( cfg -- )
|
||||
optimized-cfg [ cfgs ] render-graph ;
|
||||
|
||||
: dom-trees ( cfgs -- )
|
||||
[
|
||||
[
|
||||
compute-predecessors
|
||||
compute-dominance
|
||||
dom-childrens get [
|
||||
[
|
||||
bb-edge,
|
||||
] with each
|
||||
] assoc-each
|
||||
] over cfg-title graph,
|
||||
] each ;
|
||||
|
||||
: render-dom ( cfg -- )
|
||||
optimized-cfg [ dom-trees ] render-graph ;
|
||||
|
||||
SYMBOL: word-counts
|
||||
SYMBOL: vertex-names
|
||||
|
||||
: vertex-name ( call-graph-node -- string )
|
||||
label>> vertex-names get [
|
||||
word>> name>>
|
||||
dup word-counts get [ 0 or 1 + dup ] change-at number>string " #" glue
|
||||
] cache ;
|
||||
|
||||
: vertex-attrs ( obj -- string )
|
||||
tail?>> { "style=bold,label=\"tail\"" } { } ? ;
|
||||
|
||||
: call-graph-edge, ( from to attrs -- )
|
||||
[ [ vertex-name ] [ vertex-attrs ] bi ] dip append edge,* ;
|
||||
|
||||
: (call-graph-back-edges) ( string calls -- )
|
||||
[ { "color=red" } call-graph-edge, ] with each ;
|
||||
|
||||
: (call-graph-edges) ( string children -- )
|
||||
[
|
||||
{
|
||||
[ { } call-graph-edge, ]
|
||||
[ [ vertex-name ] [ label>> loop?>> { "shape=box" } { } ? ] bi node-style, ]
|
||||
[ [ vertex-name ] [ calls>> ] bi (call-graph-back-edges) ]
|
||||
[ [ vertex-name ] [ children>> ] bi (call-graph-edges) ]
|
||||
} cleave
|
||||
] with each ;
|
||||
|
||||
: call-graph-edges ( call-graph-node -- )
|
||||
H{ } clone word-counts set
|
||||
H{ } clone vertex-names set
|
||||
[ "ROOT" ] dip (call-graph-edges) ;
|
||||
|
||||
: render-call-graph ( tree -- )
|
||||
dup quotation? [ build-tree ] when
|
||||
analyze-recursive drop
|
||||
[ [ call-graph get call-graph-edges ] "Call graph" graph, ]
|
||||
render-graph ;
|
||||
Loading…
Reference in New Issue