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 /sml/trunk/src/MLRISC/IR/mlrisc-cfg-gen.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/IR/mlrisc-cfg-gen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 744 - (view) (download)

1 : monnier 411 (*
2 :     * This module takes a stream of instructions and build a CFG.
3 :     * The building can be incremental.
4 :     *
5 :     * -- Allen
6 :     *)
7 : george 545 functor ControlFlowGraphGen
8 : monnier 245 (structure CFG : CONTROL_FLOW_GRAPH
9 : monnier 411 structure Stream : INSTRUCTION_STREAM
10 :     structure InsnProps : INSN_PROPERTIES
11 :     sharing CFG.I = InsnProps.I
12 :     sharing CFG.P = Stream.P
13 : monnier 245 ) : CONTROL_FLOW_GRAPH_GEN =
14 :     struct
15 :    
16 :     structure CFG = CFG
17 :     structure I = CFG.I
18 :     structure P = CFG.P
19 :     structure G = Graph
20 :     structure W = CFG.W
21 : monnier 411 structure S = Stream
22 : monnier 245
23 : monnier 411 fun error msg = MLRiscErrorMsg.error("ControlFlowGraphGen",msg)
24 : monnier 245
25 : monnier 411 fun builder(CFG) =
26 : monnier 469 let val NOBLOCK = CFG.newBlock(~1,ref 0)
27 : monnier 429 val currentBlock = ref NOBLOCK
28 : monnier 245 val newBlocks = ref [] : CFG.block list ref
29 : monnier 498 val blockNames = ref [] : Annotations.annotations ref
30 : monnier 429 val entryLabels = ref [] : Label.label list ref
31 :     fun can'tUse _ = error "unimplemented"
32 : monnier 245 exception NotFound
33 : leunga 744 val labelMap = IntHashTable.mkTable(32,NotFound)
34 :     val newLabel = IntHashTable.insert labelMap
35 :     val lookupLabel = IntHashTable.lookup labelMap
36 : monnier 429 val CFG = ref CFG
37 : monnier 245
38 : monnier 498 (* Initialization *)
39 : monnier 411 fun init _ =
40 : monnier 498 let val G.GRAPH cfg = !CFG
41 : leunga 744 in IntHashTable.clear labelMap;
42 : monnier 498 #forall_nodes cfg
43 :     (fn (blockId,CFG.BLOCK{labels, ...}) =>
44 :     app (fn Label.Label{id, ...} => newLabel(id,blockId))
45 :     (!labels));
46 :     currentBlock := NOBLOCK;
47 :     newBlocks := [];
48 :     blockNames := [];
49 : leunga 744 entryLabels := []
50 : monnier 498 end
51 : monnier 411
52 :     val _ = init()
53 :    
54 : monnier 429 fun next cfg = CFG := cfg
55 : monnier 411
56 : monnier 245 fun newBlock() =
57 : monnier 429 let val G.GRAPH cfg = !CFG
58 :     val id = #new_id cfg ()
59 : monnier 498 val b as CFG.BLOCK{annotations,...} = CFG.newBlock(id,ref 0)
60 : monnier 429 in currentBlock := b;
61 : monnier 498 annotations := !blockNames;
62 : monnier 429 newBlocks := b :: !newBlocks;
63 :     #add_node cfg (id,b);
64 :     b
65 :     end
66 : monnier 245
67 :     fun getBlock() =
68 :     case !currentBlock of
69 : monnier 429 CFG.BLOCK{id= ~1,...} => newBlock()
70 :     | b => b
71 : monnier 245
72 :     fun newPseudoOpBlock() =
73 :     (case !currentBlock of
74 : monnier 429 CFG.BLOCK{id= ~1,...} => newBlock()
75 :     | b as CFG.BLOCK{insns=ref [],...} => b
76 : monnier 245 | _ => newBlock()
77 :     )
78 :    
79 :     fun insertOp p =
80 : monnier 429 let val CFG.BLOCK{data,...} = newPseudoOpBlock()
81 :     in data := !data @ [p] end
82 : monnier 245
83 : monnier 498 (* Add a new label *)
84 : monnier 429 fun defineLabel(l as Label.Label{id=labelId,...}) =
85 : monnier 498 let val id = lookupLabel labelId
86 :     val G.GRAPH cfg = !CFG
87 :     val blk as CFG.BLOCK{insns, ...} = #node_info cfg id
88 :     in currentBlock := blk;
89 :     newBlocks := blk :: !newBlocks;
90 :     insns := []; (* clear instructions *)
91 :     #set_out_edges cfg (id,[]) (* clear edges *)
92 :     end handle _ =>
93 : monnier 429 let val CFG.BLOCK{id,labels,...} = newPseudoOpBlock()
94 :     in labels := l :: !labels;
95 : monnier 498 newLabel(labelId, id)
96 : monnier 429 end
97 : monnier 245
98 : monnier 498 (* Add a new entry label *)
99 : monnier 429 fun entryLabel l = (defineLabel l; entryLabels := l :: !entryLabels)
100 :    
101 : monnier 498 (* Add a new pseudo op *)
102 : monnier 245 fun pseudoOp p = insertOp(CFG.PSEUDO p)
103 :    
104 : monnier 498 fun nextBlock() =
105 :     case !currentBlock of
106 :     CFG.BLOCK{id= ~1,...} => ()
107 :     | b => currentBlock := NOBLOCK
108 :    
109 :     (* Add a new annotation *)
110 : monnier 429 fun annotation a =
111 : leunga 585 case a of
112 :     MLRiscAnnotations.BLOCKNAMES names =>
113 : monnier 498 (blockNames := names;
114 :     nextBlock()
115 :     )
116 : leunga 585 | MLRiscAnnotations.EMPTYBLOCK => nextBlock()
117 :     | a =>
118 : monnier 498 let val CFG.BLOCK{annotations,...} = getBlock()
119 :     in annotations := a :: !annotations
120 :     end
121 : monnier 429
122 : monnier 498 (* Mark current block as exit *)
123 : monnier 245 fun exitBlock liveOut =
124 : monnier 429 let fun setLiveOut(CFG.BLOCK{annotations,...}) =
125 : monnier 469 annotations := #create CFG.LIVEOUT liveOut :: !annotations
126 : monnier 429 in case !currentBlock of
127 :     CFG.BLOCK{id= ~1,...} =>
128 :     (case !newBlocks of
129 :     [] => error "exitBlock"
130 :     | b::_ => setLiveOut b
131 :     )
132 :     | b => setLiveOut b
133 :     end
134 : monnier 245
135 : monnier 498 (* Add a new comment *)
136 :     fun comment msg = annotation(#create MLRiscAnnotations.COMMENT msg)
137 : monnier 245
138 : monnier 498 (* Emit an instruction *)
139 :     fun emit i =
140 : monnier 429 let val CFG.BLOCK{insns,...} = getBlock()
141 :     in insns := i :: !insns;
142 :     if InsnProps.instrKind i = InsnProps.IK_JUMP then
143 :     currentBlock := NOBLOCK
144 :     else ()
145 : monnier 245 end
146 : monnier 411
147 : monnier 498 (* End current cluster *)
148 :     fun endCluster(annotations) =
149 : monnier 429 let val G.GRAPH cfg = !CFG
150 :     val _ = CFG.init(!CFG) (* create entry/exit *)
151 : monnier 498
152 : monnier 429 val ENTRY = hd(#entries cfg ())
153 :     val EXIT = hd(#exits cfg ())
154 : monnier 245
155 : monnier 429 fun next(CFG.BLOCK{id,data=ref [],...}::_) = id
156 :     | next _ = error "next"
157 : monnier 498
158 : leunga 744 val lookupLabelMap = IntHashTable.find labelMap
159 :     val lookupLabelMap =
160 :     fn l => case lookupLabelMap l of SOME b => b | NONE => EXIT
161 : monnier 429 val TRUE = CFG.BRANCH true
162 :     val FALSE = CFG.BRANCH false
163 :     val addEdge = #add_edge cfg
164 :    
165 :     fun target(Label.Label{id,...}) = lookupLabelMap id
166 :    
167 : monnier 411 fun addEdges [] = ()
168 :     | addEdges(CFG.BLOCK{id,insns,...}::blocks) =
169 :     (case !insns of
170 :     [] => fallsThru(id,blocks)
171 :     | instr::_ =>
172 : monnier 429 if InsnProps.instrKind instr = InsnProps.IK_JUMP then
173 :     jump(id,InsnProps.branchTargets instr,blocks)
174 : monnier 411 else
175 :     fallsThru(id,blocks);
176 :     addEdges blocks
177 :     )
178 :     and fallsThru(i,CFG.BLOCK{id=j,data,...}::_) =
179 :     (case !data of
180 :     [] => ()
181 : monnier 429 | _ => error("falls thru into pseudo ops: "^
182 :     Int.toString i^" -> "^Int.toString j)
183 : monnier 411 ;
184 : monnier 429 addEdge(i,j,CFG.EDGE{k=CFG.FALLSTHRU,w=ref 0, a=ref []})
185 : monnier 411 )
186 :     | fallsThru(i,[]) =
187 : monnier 429 (* error("missing return in block "^Int.toString i) *)
188 :     addEdge(i,EXIT,CFG.EDGE{k=CFG.EXIT,w=ref 0,a=ref []})
189 :     and jump(i,[InsnProps.ESCAPES],_) =
190 :     addEdge(i,EXIT,CFG.EDGE{k=CFG.EXIT,w=ref 0,a=ref []})
191 :     | jump(i,[InsnProps.LABELLED L],_) =
192 :     addEdge(i,target L,CFG.EDGE{k=CFG.JUMP,w=ref 0,a=ref []})
193 :     | jump(i,[InsnProps.LABELLED L,InsnProps.FALLTHROUGH],bs) =
194 :     (addEdge(i,target L,CFG.EDGE{k=TRUE,w=ref 0,a=ref[]});
195 :     addEdge(i,next bs,CFG.EDGE{k=FALSE,w=ref 0,a=ref []})
196 : monnier 411 )
197 : monnier 429 | jump(i,[InsnProps.FALLTHROUGH,InsnProps.LABELLED L],bs) =
198 :     (addEdge(i,target L,CFG.EDGE{k=TRUE,w=ref 0,a=ref []});
199 :     addEdge(i,next bs,CFG.EDGE{k=FALSE,w=ref 0,a=ref []})
200 :     )
201 : monnier 411 | jump(i,targets,_) =
202 : monnier 429 let fun loop(n,[]) = ()
203 :     | loop(n,InsnProps.LABELLED L::targets) =
204 :     (addEdge(i,target L,
205 :     CFG.EDGE{k=CFG.SWITCH n,w=ref 0,a=ref []});
206 :     loop(n+1,targets))
207 :     | loop _ = error "jump"
208 :     in loop(0,targets) end
209 : monnier 411 in addEdges(rev(!newBlocks));
210 : monnier 429 app (fn l => addEdge(ENTRY,target l,
211 :     CFG.EDGE{k=CFG.ENTRY,a=ref [],w=ref 0}))
212 :     (!entryLabels);
213 : leunga 624 let val an = CFG.annotations(!CFG);
214 :     in an := annotations @ (!an) end;
215 : monnier 411 init()
216 :     end
217 :    
218 : monnier 498 (* Start a new cluster *)
219 : leunga 744 fun beginCluster _ = init()
220 : monnier 429
221 : monnier 411 in {stream=S.STREAM
222 : monnier 498 { beginCluster= beginCluster,
223 :     endCluster = endCluster,
224 : monnier 411 defineLabel = defineLabel,
225 :     entryLabel = entryLabel,
226 :     pseudoOp = pseudoOp,
227 : monnier 498 emit = emit,
228 : monnier 411 exitBlock = exitBlock,
229 :     comment = comment,
230 : leunga 744 annotation = annotation
231 : monnier 411 },
232 :     next = next
233 :     }
234 : monnier 245 end
235 :    
236 :     end

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