compiler.cfg.gvn.testing: add basic graphviz output

extra/compiler/cfg/gvn/testing/testing.factor

@@ -1,16 +1,51 @@
-! Copyright (C) 2011 Alex Vondrak.
+! Copyright (C) 2011 Alex Vondrak.  See
-! See http://factorcode.org/license.txt for BSD license.
+! http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler.cfg compiler.cfg.alias-analysis
+USING: accessors assocs compiler.cfg
-compiler.cfg.block-joining compiler.cfg.branch-splitting
+compiler.cfg.alias-analysis compiler.cfg.block-joining
-compiler.cfg.copy-prop compiler.cfg.dce compiler.cfg.debugger
+compiler.cfg.branch-splitting compiler.cfg.copy-prop
+compiler.cfg.dce compiler.cfg.debugger
 compiler.cfg.finalization compiler.cfg.graphviz
-compiler.cfg.gvn compiler.cfg.gvn.graph compiler.cfg.height
+compiler.cfg.gvn compiler.cfg.gvn.expressions
+compiler.cfg.gvn.graph compiler.cfg.height
 compiler.cfg.ssa.construction compiler.cfg.tco
-compiler.cfg.useless-conditionals fry io kernel math
+compiler.cfg.useless-conditionals formatting fry graphviz
-math.private namespaces prettyprint sequences tools.annotations
+graphviz.notation graphviz.render io kernel math math.parser
-;
+math.private namespaces prettyprint sequences sorting strings
+tools.annotations ;
 IN: compiler.cfg.gvn.testing
 
+GENERIC: expr>str ( expr -- str )
+
+M: integer-expr expr>str value>> number>string ;
+
+M: reference-expr expr>str value>> number>string "&" prepend ;
+
+M: object expr>str [ unparse ] map " " join ;
+
+: local-value-mapping ( from to -- str )
+    over exprs>vns get value-at* [
+        expr>str "%d -> <%d> (%s)\\l" sprintf
+    ] [
+        drop "%d -> <%d>\\l" sprintf
+    ] if ;
+
+: lvns ( -- str )
+    vregs>vns get >alist natural-sort [
+        first2 local-value-mapping
+    ] map "" concat-as ;
+
+: invert-assoc ( assoc -- inverted )
+    V{ } clone [
+        [ push-at ] curry assoc-each
+    ] keep ;
+
+: gvns ( -- str )
+    vregs>gvns get invert-assoc >alist natural-sort [
+        first2
+        natural-sort [ number>string ] map ", " join
+        "<%d> : {%s}\\l" sprintf
+    ] map "" concat-as ;
+
 SYMBOL: gvn-test
 
 [ 0 100 [ 1 fixnum+fast ] times ]
@@ -24,19 +59,29 @@ test-builder first [
     alias-analysis
 ] with-cfg gvn-test set-global
 
+: basic-block# ( -- n )
+    basic-block get number>> ;
+
+: add-gvns ( graph -- graph' )
+    <anon>
+        "gvns" add-node[ gvns =label "plaintext" =shape ];
+        "gvns" 0 add-edge[ "invis" =style ];
+    add ;
+
+: add-lvns ( graph -- graph' )
+    "lvn" <cluster>
+        "invis" =style
+        "lvns" add-node[ lvns =label "plaintext" =shape ];
+        basic-block# add-node[ "bold" =style ];
+    add ;
+
+: draw-annotated-cfg ( -- )
+    cfg get cfgviz add-gvns add-lvns
+    basic-block# number>string "bb" prepend png ;
+
 : watch-gvn ( -- )
     \ value-numbering-step
-    [
+    [ '[ _ call draw-annotated-cfg ] ] annotate ;
-        '[
-            _ call
-            "Basic block #" write basic-block get number>> .
-            "vregs>gvns: "  write vregs>gvns  get .
-            "vregs>vns: "   write vregs>vns   get .
-            "exprs>vns: "   write exprs>vns   get .
-            "vns>insns: "   write vns>insns   get .
-            "\n---\n" print
-        ]
-    ] annotate ;
 
 : reset-gvn ( -- )
     \ value-numbering-step reset ;