compiler.graphviz: add high-level IR call graph rendering

basis/compiler/tree/recursive/recursive.factor

@@ -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
+        [ label>> ] [ child>> build-call-graph ] bi
-        call-tree-node boa children get push
+        call-graph-node boa children get push
     ] bi ;
 
-M: #branch node-call-tree
+M: #branch node-call-graph
-    children>> [ (build-call-tree) ] with each ;
+    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
+    dup build-call-graph drop
-    [ detect-loops ] [ mark-loops ] bi ;
+    [ call-graph set ]
+    [ detect-loops ]
+    [ mark-loops ]
+    tri ;

extra/compiler/cfg/graphviz/graphviz.factor

@@ -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 ;

extra/compiler/graphviz/graphviz.factor

@@ -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 ;