Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /MLRISC/trunk/flowgraph/cfgView.sml
ViewVC logotype

Annotation of /MLRISC/trunk/flowgraph/cfgView.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 959 - (view) (download)
Original Path: sml/trunk/src/MLRISC/flowgraph/cfgView.sml

1 : george 933 (* cfgView.sml -- graphical viewing utilities for cfg
2 :     *
3 :     * Copyright (c) 2001 Bell Laboratories.
4 :     *)
5 :     functor CFGView
6 :     (structure CFG : CONTROL_FLOW_GRAPH
7 :     structure Asm : INSTRUCTION_EMITTER
8 :     where I = CFG.I
9 :     and P = CFG.P
10 :     ) : CFG_VIEW =
11 :    
12 :     struct
13 :    
14 :     structure L = GraphLayout
15 :     structure CFG = CFG
16 :     structure G = Graph
17 :     structure W = Freq
18 :     structure S = Asm.S
19 :    
20 :     fun nl() = TextIO.output(!AsmStream.asmOutStream,"\n")
21 :     fun kindName CFG.START = "START"
22 :     | kindName CFG.STOP = "STOP"
23 :     | kindName CFG.HYPERBLOCK = "Hyperblock"
24 :     | kindName CFG.NORMAL = "Block"
25 :    
26 :    
27 :     fun emitHeader (S.STREAM{comment,annotation,...})
28 :     (CFG.BLOCK{id,kind,freq,annotations,...}) =
29 :     (comment(kindName kind ^"["^Int.toString id^
30 :     "] ("^W.toString (!freq)^")");
31 :     nl();
32 :     app annotation (!annotations)
33 :     )
34 :    
35 :     fun emitFooter (S.STREAM{comment,...}) (CFG.BLOCK{annotations,...}) =
36 :     (case #get CFG.LIVEOUT (!annotations) of
37 :     SOME s =>
38 :     let val regs = String.tokens Char.isSpace(CellsBasis.CellSet.toString s)
39 :     val K = 7
40 :     fun f(_,[],s,l) = s::l
41 :     | f(0,vs,s,l) = f(K,vs," ",s::l)
42 :     | f(n,[v],s,l) = v^s::l
43 :     | f(n,v::vs,s,l) = f(n-1,vs,s^" "^v,l)
44 :     val text = rev(f(K,regs,"",[]))
45 :     in app (fn c => (comment c; nl())) text
46 :     end
47 :     | NONE => ()
48 :     ) handle Overflow => print("Bad footer\n")
49 :    
50 :     fun emitStuff outline annotations
51 :     (block as CFG.BLOCK{insns,data,labels,...}) =
52 :     let val S as S.STREAM{pseudoOp,defineLabel,emit,...} =
53 :     Asm.makeStream annotations
54 :     in emitHeader S block;
55 :     app (fn CFG.PSEUDO p => pseudoOp p
56 :     | CFG.LABEL l => defineLabel l) (!data);
57 : george 959 app defineLabel (!labels);
58 : george 933 if outline then () else app emit (rev (!insns));
59 :     emitFooter S block
60 :     end
61 :    
62 :     val emit = emitStuff false
63 :     val emitOutline = emitStuff true []
64 :    
65 :     fun getString f x =
66 :     let val buffer = StringOutStream.mkStreamBuf()
67 :     val S = StringOutStream.openStringOut buffer
68 :     val _ = AsmStream.withStream S f x
69 :     in StringOutStream.getString buffer end
70 :    
71 :     fun show_block an block =
72 :     let val text = getString (emit an) block
73 :     in foldr (fn (x,"") => x | (x,y) => x^" "^y) ""
74 :     (String.tokens (fn #" " => true | _ => false) text)
75 :     end
76 :    
77 :     fun headerText block = getString
78 :     (fn b => emitHeader (Asm.makeStream []) b) block
79 :     fun footerText block = getString
80 :     (fn b => emitFooter (Asm.makeStream []) b) block
81 :    
82 :     fun getStyle a = (case #get L.STYLE (!a) of SOME l => l | NONE => [])
83 :    
84 :     val green = L.COLOR "green"
85 :     val red = L.COLOR "red"
86 :     val yellow = L.COLOR "yellow"
87 :    
88 :    
89 :     fun show_edge(CFG.EDGE{k,w,a,...}) =
90 :     let val kind = case k of
91 :     CFG.JUMP => ""
92 :     | CFG.FALLSTHRU => "fallsthru"
93 :     | CFG.BRANCH b => Bool.toString b
94 :     | CFG.SWITCH i => Int.toString i
95 :     | CFG.ENTRY => "entry"
96 :     | CFG.EXIT => "exit"
97 :     | CFG.SIDEEXIT i => "sideexit("^Int.toString i^")"
98 :     val weight = "(" ^ W.toString (!w) ^ ")"
99 :     in kind ^ weight
100 :     end
101 :    
102 :     fun edgeStyle(i,j,e as CFG.EDGE{k,a,...}) =
103 :     let val a = L.LABEL(show_edge e) :: getStyle a
104 :     in case k of
105 :     (CFG.ENTRY | CFG.EXIT) => green :: a
106 :     | (CFG.FALLSTHRU | CFG.BRANCH false) => yellow :: a
107 :     | _ => red :: a
108 :     end
109 :    
110 :     val outline = MLRiscControl.getFlag "view-outline"
111 :    
112 :     fun annotations(G.GRAPH{graph_info=CFG.INFO{annotations=a,...},...}) = a
113 :    
114 :     fun viewStyle cfg =
115 :     let val an = !(annotations cfg)
116 :     fun node (n,b as CFG.BLOCK{annotations,...}) =
117 :     if !outline then
118 :     L.LABEL(getString emitOutline b) :: getStyle annotations
119 :     else
120 :     L.LABEL(show_block an b) :: getStyle annotations
121 :     in { graph = fn _ => [],
122 :     edge = edgeStyle,
123 :     node = node
124 :     }
125 :     end
126 :    
127 :     fun viewLayout cfg = L.makeLayout (viewStyle cfg) cfg
128 :    
129 :     fun subgraphLayout {cfg,subgraph = G.GRAPH subgraph} =
130 :     let val an = !(annotations cfg)
131 :     fun node(n,b as CFG.BLOCK{annotations,...}) =
132 :     if #has_node subgraph n then
133 :     L.LABEL(show_block an b) :: getStyle annotations
134 :     else
135 :     L.COLOR "lightblue"::L.LABEL(headerText b) :: getStyle annotations
136 :     fun edge(i,j,e) =
137 :     if #has_edge subgraph (i,j) then edgeStyle(i,j,e)
138 :     else [L.EDGEPATTERN "dotted"]
139 :     in L.makeLayout {graph = fn _ => [],
140 :     edge = edge,
141 :     node = node} cfg
142 :     end
143 :     end
144 :    
145 :    
146 :    

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