extra/compiler/graphviz/graphviz.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: accessors arrays assocs combinators compiler.cfg
   4 compiler.cfg.debugger compiler.cfg.dominance
   5 compiler.cfg.dominance.private compiler.cfg.rpo
   6 compiler.tree.builder compiler.tree.recursive graphviz.render io
   7 io.encodings.ascii io.files io.files.unique io.launcher kernel
   8 make math math.parser namespaces quotations sequences words ;
   9 QUALIFIED: assocs
  10 IN: compiler.graphviz
  11
  12 : quotes ( str -- str' ) "\"" "\"" surround ;
  13
  14 : graph, ( quot title -- )
  15     [
  16         quotes "digraph " " {" surround ,
  17         call
  18         "}" ,
  19     ] { } make , ; inline
  20
  21 : render-graph ( quot -- name )
  22     { } make
  23     "cfg" ".dot" make-unique-file
  24     dup "Wrote " prepend print
  25     [ [ concat ] dip ascii set-file-lines ]
  26     [ [ ?default-graphviz-program "-Tpng" "-O" ] dip 4array try-process ]
  27     [ ".png" append ]
  28     tri ; inline
  29
  30 : display-graph ( name -- )
  31     "open" swap 2array try-process ;
  32
  33 : attrs>string ( seq -- str )
  34     [ "" ] [ "," join "[" "]" surround ] if-empty ;
  35
  36 : edge,* ( from to attrs -- )
  37     [
  38         [ quotes % " -> " % ] [ quotes % " " % ] [ attrs>string % ] tri*
  39         ";" %
  40     ] "" make , ;
  41
  42 : edge, ( from to -- )
  43     { } edge,* ;
  44
  45 : bb-edge, ( from to -- )
  46     [ number>> number>string ] bi@ edge, ;
  47
  48 : node-style, ( str attrs -- )
  49     [ [ quotes % " " % ] [ attrs>string % ";" % ] bi* ] "" make , ;
  50
  51 : cfg-title ( cfg/mr -- string )
  52     [
  53         "=== word: " %
  54         [ word>> name>> % ", label: " % ]
  55         [ label>> name>> % ]
  56         bi
  57     ] "" make ;
  58
  59 : cfg-vertex, ( bb -- )
  60     [ number>> number>string ]
  61     [ kill-block?>> { "color=grey" "style=filled" } { } ? ]
  62     bi node-style, ;
  63
  64 : cfgs ( cfgs -- )
  65     [
  66         [
  67             [ [ cfg-vertex, ] each-basic-block ]
  68             [
  69                 [
  70                     dup successors>> [
  71                         bb-edge,
  72                     ] with each
  73                 ] each-basic-block
  74             ] bi
  75         ] over cfg-title graph,
  76     ] each ;
  77
  78 : optimized-cfg ( quot -- cfgs )
  79     {
  80         { [ dup cfg? ] [ 1array ] }
  81         { [ dup quotation? ] [ test-ssa ] }
  82         { [ dup word? ] [ test-ssa ] }
  83         [ ]
  84     } cond ;
  85
  86 : render-cfg ( cfg -- name )
  87     optimized-cfg [ cfgs ] render-graph ;
  88
  89 : dom-trees ( cfgs -- )
  90     [
  91         [
  92             needs-dominance
  93             dom-childrens get [
  94                 [
  95                     bb-edge,
  96                 ] with each
  97             ] assoc-each
  98         ] over cfg-title graph,
  99     ] each ;
 100
 101 : render-dom ( cfg -- name )
 102     optimized-cfg [ dom-trees ] render-graph ;
 103
 104 SYMBOL: word-counts
 105 SYMBOL: vertex-names
 106
 107 : vertex-name ( call-graph-node -- string )
 108     label>> vertex-names get [
 109         word>> name>>
 110         dup word-counts get [ 0 or 1 + dup ] assocs:change-at
 111         number>string " #" glue
 112     ] cache ;
 113
 114 : vertex-attrs ( obj -- string )
 115     tail?>> { "style=bold,label=\"tail\"" } { } ? ;
 116
 117 : call-graph-edge, ( from to attrs -- )
 118     [ [ vertex-name ] [ vertex-attrs ] bi ] dip append edge,* ;
 119
 120 : (call-graph-back-edges) ( string calls -- )
 121     [ { "color=red" } call-graph-edge, ] with each ;
 122
 123 : (call-graph-edges) ( string children -- )
 124     [
 125         {
 126             [ { } call-graph-edge, ]
 127             [ [ vertex-name ] [ label>> loop?>> { "shape=box" } { } ? ] bi node-style, ]
 128             [ [ vertex-name ] [ calls>> ] bi (call-graph-back-edges) ]
 129             [ [ vertex-name ] [ children>> ] bi (call-graph-edges) ]
 130         } cleave
 131     ] with each ;
 132
 133 : call-graph-edges ( call-graph-node -- )
 134     H{ } clone word-counts set
 135     H{ } clone vertex-names set
 136     [ "ROOT" ] dip (call-graph-edges) ;
 137
 138 : render-call-graph ( tree -- name )
 139     dup quotation? [ build-tree ] when
 140     analyze-recursive drop
 141     [ [ call-graph get call-graph-edges ] "Call graph" graph, ]
 142     render-graph ;