extra/compiler/graphviz/graphviz.factor

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