diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index 3746046bea..bc6243e138 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/basis/compiler/tree/recursive/recursive.factor @@ -11,7 +11,7 @@ TUPLE: call-site tail? node 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 ; diff --git a/extra/compiler/cfg/graphviz/graphviz.factor b/extra/compiler/cfg/graphviz/graphviz.factor deleted file mode 100644 index 0aade1301f..0000000000 --- a/extra/compiler/cfg/graphviz/graphviz.factor +++ /dev/null @@ -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 ; \ No newline at end of file diff --git a/extra/compiler/graphviz/graphviz.factor b/extra/compiler/graphviz/graphviz.factor new file mode 100644 index 0000000000..353a134375 --- /dev/null +++ b/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 ; \ No newline at end of file