Home My Page Projects Code Snippets Project Openings diderot
Summary Activity Tracker Tasks SCM

SCM Repository

[diderot] Annotation of /branches/pure-cfg/src/compiler/IL/dump-dot-fn.sml
ViewVC logotype

Annotation of /branches/pure-cfg/src/compiler/IL/dump-dot-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1556 - (view) (download)

1 : jhr 1157 (* dump-dot-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     * All rights reserved.
5 :     *
6 :     * A debugging aid that dumps an IL control-flow graph as a dot file.
7 :     *)
8 :    
9 :     functor DumpDotFn (IL : SSA) : sig
10 :    
11 :     structure IL : SSA
12 :    
13 :     val dump : string * IL.cfg -> unit
14 :    
15 :     end = struct
16 :    
17 :     structure IL = IL
18 :    
19 :     fun indent (outS, i) = TextIO.output(outS, StringCvt.padLeft #" " i "")
20 :     fun incIndent (outS, i) = (outS, i+2)
21 :     fun pr ((outS, _), s) = TextIO.output(outS, s)
22 :     fun prl (out, l) = pr(out, concat l)
23 :     fun prln (out, l) = (indent out; prl(out, l))
24 :    
25 :     val n2s = IL.Node.toString
26 :    
27 :     val {getFn, setFn} = IL.Node.newFlag ()
28 :    
29 :     (* assuming that the current node is a simple node, do we need a new dot node for its
30 :     * successor?
31 :     *)
32 :     fun needNewDotNode nd = (case IL.Node.kind nd
33 :     of IL.COM _ => false
34 :     | IL.ASSIGN _ => false
35 : jhr 1556 | IL.MASSIGN _ => false
36 : jhr 1157 | IL.NEW _ => false
37 :     | _ => true
38 :     (* end case *))
39 :    
40 :     fun dumpCFG (out, IL.CFG{entry, ...}) = let
41 :     val out' = incIndent out
42 :     val out'' = incIndent out'
43 :     fun prNode (name, shape) = prln (out', [name, " [shape = ", shape, "];\n"]);
44 :     fun prEdges (src, []) = ()
45 :     | prEdges (src, dsts) = prln (out'', [String.concatWith " -> " dsts, ";\n"])
46 :     fun dfs (label, edge, nd, l) =
47 :     if getFn nd
48 :     then l
49 :     else let
50 :     val l = nd::l
51 :     fun doEdge (dstNd, l) = let
52 :     val dstLabel = n2s dstNd
53 :     in
54 :     prln(out'', [label, " -> ", dstLabel, ";\n"]);
55 :     dfs (dstLabel, true, dstNd, l)
56 :     end
57 :     fun condEdge (dstNd, l) = if needNewDotNode dstNd
58 :     then doEdge (dstNd, l)
59 :     else dfs (label, false, dstNd, l)
60 :     in
61 :     setFn (nd, true);
62 :     case IL.Node.kind nd
63 :     of IL.NULL => (prNode (n2s nd, "plaintext"); l)
64 :     | IL.ENTRY{succ, ...} => (
65 :     prNode (label, "house");
66 :     doEdge (!succ, l))
67 :     | IL.JOIN{succ, ...} => (
68 :     prNode (label, "ellipse");
69 :     doEdge (!succ, l))
70 :     | IL.COND{trueBranch, falseBranch, ...} => (
71 :     prNode (label, "diamond");
72 :     doEdge (!trueBranch, doEdge (!falseBranch, l)))
73 :     | IL.COM{succ, ...} => (
74 :     if edge then prNode(label, "box") else ();
75 :     condEdge (!succ, l))
76 :     | IL.ASSIGN{succ, ...} =>(
77 :     if edge then prNode(label, "box") else ();
78 :     condEdge (!succ, l))
79 : jhr 1556 | IL.MASSIGN{succ, ...} =>(
80 :     if edge then prNode(label, "box") else ();
81 :     condEdge (!succ, l))
82 : jhr 1157 | IL.NEW{succ, ...} =>(
83 :     if edge then prNode(label, "box") else ();
84 :     condEdge (!succ, l))
85 : jhr 1504 | IL.SAVE{succ, ...} =>(
86 :     if edge then prNode(label, "box") else ();
87 :     condEdge (!succ, l))
88 : jhr 1157 | IL.EXIT _ => (prNode (label, "hexagon"); l)
89 :     (* end case *)
90 :     end
91 :     in
92 :     pr (out, "digraph CFG {\n");
93 :     prln (out', ["size = \"7.5,10\";\n"]);
94 :     prln (out', ["node [fontsize = 14];\n"]);
95 :     List.app (fn nd => setFn(nd, false))
96 :     (dfs (n2s entry, true, entry, []));
97 :     pr (out, "}\n")
98 :     end
99 :    
100 :     fun dump (fileName, cfg) = let
101 :     val outS = TextIO.openOut fileName
102 :     in
103 :     dumpCFG ((outS, 0), cfg);
104 :     TextIO.closeOut outS
105 :     end
106 :    
107 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0