compiler.graphviz: this vocab can be removed I think
The compiler.cfg.graphviz vocab implements all its features and is more complete.db4
Björn Lindqvist
parent
df93e4533d
commit
2f1b7bf9e1
|
|
@ -1,6 +0,0 @@
|
|||
IN: compiler.graphviz.tests
|
||||
USING: compiler.graphviz io.files kernel tools.test ;
|
||||
|
||||
{ t } [ [ [ 1 ] [ 2 ] if ] render-cfg exists? ] unit-test
|
||||
{ t } [ [ [ 1 ] [ 2 ] if ] render-dom exists? ] unit-test
|
||||
{ t } [ [ [ 1 ] [ 2 ] if ] render-call-graph exists? ] unit-test
|
||||
|
|
@ -1,142 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
USING: accessors arrays assocs combinators compiler.cfg
|
||||
compiler.cfg.debugger compiler.cfg.dominance
|
||||
compiler.cfg.dominance.private compiler.cfg.rpo
|
||||
compiler.tree.builder compiler.tree.recursive graphviz.render io
|
||||
io.encodings.ascii io.files io.files.unique io.launcher kernel
|
||||
make math math.parser namespaces quotations sequences words ;
|
||||
QUALIFIED: assocs
|
||||
IN: compiler.graphviz
|
||||
|
||||
: quotes ( str -- str' ) "\"" "\"" surround ;
|
||||
|
||||
: graph, ( quot title -- )
|
||||
[
|
||||
quotes "digraph " " {" surround ,
|
||||
call
|
||||
"}" ,
|
||||
] { } make , ; inline
|
||||
|
||||
: render-graph ( quot -- name )
|
||||
{ } make
|
||||
"cfg" ".dot" make-unique-file
|
||||
dup "Wrote " prepend print
|
||||
[ [ concat ] dip ascii set-file-lines ]
|
||||
[ [ ?default-graphviz-program "-Tpng" "-O" ] dip 4array try-process ]
|
||||
[ ".png" append ]
|
||||
tri ; inline
|
||||
|
||||
: display-graph ( name -- )
|
||||
"open" swap 2array try-process ;
|
||||
|
||||
: 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-ssa ] }
|
||||
{ [ dup word? ] [ test-ssa ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
: render-cfg ( cfg -- name )
|
||||
optimized-cfg [ cfgs ] render-graph ;
|
||||
|
||||
: dom-trees ( cfgs -- )
|
||||
[
|
||||
[
|
||||
needs-dominance
|
||||
dom-childrens get [
|
||||
[
|
||||
bb-edge,
|
||||
] with each
|
||||
] assoc-each
|
||||
] over cfg-title graph,
|
||||
] each ;
|
||||
|
||||
: render-dom ( cfg -- name )
|
||||
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 ] assocs: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 -- name )
|
||||
dup quotation? [ build-tree ] when
|
||||
analyze-recursive drop
|
||||
[ [ call-graph get call-graph-edges ] "Call graph" graph, ]
|
||||
render-graph ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
unix
|
||||
Loading…
Reference in New Issue