extra/compiler/cfg/graphviz/graphviz.factor

   1 ! Copyright (C) 2011 Alex Vondrak.
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors fry io io.directories io.pathnames
   5 io.streams.string kernel math math.parser namespaces
   6 prettyprint sequences splitting strings tools.annotations
   7
   8 compiler.cfg
   9 compiler.cfg.builder
  10 compiler.cfg.debugger
  11 compiler.cfg.linearization
  12 compiler.cfg.finalization
  13 compiler.cfg.optimizer
  14 compiler.cfg.rpo
  15
  16 compiler.cfg.value-numbering
  17 compiler.cfg.value-numbering.graph
  18
  19 graphviz
  20 graphviz.notation
  21 graphviz.render
  22 ;
  23 FROM: compiler.cfg.linearization => number-blocks ;
  24 IN: compiler.cfg.graphviz
  25
  26 : left-justify ( str -- str' )
  27     lines "\\l" join ;
  28
  29 : left-justified ( quot -- str )
  30     with-string-writer left-justify ; inline
  31
  32 : bb-label ( bb -- str )
  33     [ number>> number>string ]
  34     [
  35         [ instructions>> [ insn. ] each ] left-justified
  36     ] bi "\\n" glue ;
  37
  38 : add-cfg-vertex ( graph bb -- graph' )
  39     [ number>> <node> ]
  40     [ bb-label =label ]
  41     [ kill-block?>> [ "grey" =color "filled" =style ] when ]
  42     tri add ;
  43
  44 : add-cfg-edges ( graph bb -- graph' )
  45     dup successors>> [
  46         [ number>> ] bi@ ->
  47     ] with each ;
  48
  49 : cfgviz ( cfg -- graph )
  50     <digraph>
  51         [graph "t" =labelloc ];
  52         [node "box" =shape "Courier" =fontname 10 =fontsize ];
  53         swap [
  54             [ add-cfg-vertex ] [ add-cfg-edges ] bi
  55         ] each-basic-block ;
  56
  57 : perform-pass ( cfg pass pass# -- )
  58     drop def>> call( cfg -- ) ;
  59
  60 : draw-cfg ( cfg pass pass# -- cfg )
  61     [ dup cfgviz ]
  62     [ name>> "-" prepend ]
  63     [ number>string prepend svg ]
  64     tri* ;
  65
  66 SYMBOL: passes
  67
  68 : watch-pass ( cfg pass pass# -- cfg' )
  69     [ perform-pass ] 3keep draw-cfg ;
  70
  71 : begin-watching-passes ( cfg -- cfg )
  72     \ build-cfg 0 draw-cfg ;
  73
  74 : watch-passes ( cfg -- cfg' )
  75     passes get [ 1 + watch-pass ] each-index ;
  76
  77 : finish-watching-passes ( cfg -- )
  78     \ finalize-cfg
  79     passes get length 1 +
  80     watch-pass drop ;
  81
  82 : watch-cfg ( path cfg -- )
  83     over make-directories
  84     [
  85         [
  86             begin-watching-passes
  87             watch-passes
  88             finish-watching-passes
  89         ] with-cfg
  90     ] curry with-directory ;
  91
  92 : watch-cfgs ( path cfgs -- )
  93     [
  94         number>string "cfg" prepend append-path
  95         swap watch-cfg
  96     ] with each-index ;
  97
  98 : watch-optimizer* ( path quot -- )
  99     test-builder
 100     dup length 1 = [ first watch-cfg ] [ watch-cfgs ] if ;
 101
 102 : watch-optimizer ( quot -- )
 103     [ "" ] dip watch-optimizer* ;
 104
 105 : ssa. ( quot -- ) test-ssa [ cfgviz preview ] each ;
 106 : flat. ( quot -- ) test-flat [ cfgviz preview ] each ;
 107 : regs. ( quot -- ) test-regs [ cfgviz preview ] each ;