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 2126 - (view) (download)

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

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