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/flowgraph/buildFlowgraph.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/flowgraph/buildFlowgraph.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 984 - (view) (download)

1 : george 906 (* buildFlowgraph.sml
2 :     *
3 :     * COPYRIGHT (c) 2001 Bell Labs, Lucent Technologies
4 :     *)
5 :     signature CONTROL_FLOWGRAPH_GEN =
6 :     sig
7 :    
8 :     structure S : INSTRUCTION_STREAM
9 :     structure I : INSTRUCTIONS
10 : george 984 structure P : PSEUDO_OPS
11 : george 906 structure CFG : CONTROL_FLOW_GRAPH
12 : george 933 where I = I
13 : george 984 and P = P
14 : george 933 (*
15 : george 906 * This creates an emitter which can be used to build a CFG incrementally
16 :     *)
17 :     type instrStream =
18 :     (I.instruction, Annotations.annotations, I.C.cellset, CFG.cfg) S.stream
19 :    
20 : george 933 val build : unit -> instrStream
21 : george 906
22 :     end
23 :    
24 : george 984
25 :    
26 :    
27 : george 906 functor BuildFlowgraph
28 :     (structure Props : INSN_PROPERTIES
29 :     structure Stream : INSTRUCTION_STREAM
30 :     structure CFG : CONTROL_FLOW_GRAPH
31 : george 984 where I = Props.I
32 :     and P = Stream.P
33 : george 906 ) : CONTROL_FLOWGRAPH_GEN =
34 :     struct
35 :     structure CFG = CFG
36 : george 984 structure P = CFG.P
37 : george 906 structure I = Props.I
38 :     structure G = Graph
39 :     structure S = Stream
40 :     structure Fmt = Format
41 : george 984 structure PB = PseudoOpsBasisTyp
42 :    
43 : george 906 exception LabelNotFound
44 :    
45 :     type instrStream =
46 :     (I.instruction, Annotations.annotations, CFG.I.C.cellset, CFG.cfg) S.stream
47 :    
48 :     fun error msg = MLRiscErrorMsg.error ("BuildFlowGraph", msg)
49 :    
50 :     val hashLabel = Word.toInt o Label.hash
51 :    
52 : george 933 fun build () = let
53 :     val cfg as ref(G.GRAPH graph) = ref(CFG.new())
54 : george 906
55 :     (* list of blocks generated so far *)
56 :     val blockList = ref ([] : CFG.block list)
57 :    
58 :     (* list of entry labels to patch successors of ENTRY *)
59 :     val entryLabels = ref ([] : Label.label list)
60 : george 984
61 : george 906 (* block id associated with a label*)
62 :     val labelMap = IntHashTable.mkTable(32, LabelNotFound)
63 : jhr 950 val findLabel = IntHashTable.find labelMap
64 : george 906 val addLabel = IntHashTable.insert labelMap
65 :    
66 : george 984 (* Data in text segment is read-only *)
67 :     datatype segment_t = TEXT | DATA | RO_DATA
68 :     val segmentF = ref TEXT
69 :    
70 :     (* the block names *)
71 : george 906 val blockNames = ref [] : Annotations.annotations ref
72 :    
73 : george 984 (* can instructions be reordered *)
74 :     val reorder = ref [] : Annotations.annotations ref
75 :    
76 : george 906 (* noblock or invalid block has id of ~1 *)
77 :     val noBlock = CFG.newBlock(~1, ref 0)
78 : george 984
79 : george 906 (* current block being built up *)
80 :     val currentBlock = ref noBlock
81 :    
82 :    
83 :     (* add a new block and make it the current block being built up *)
84 :     fun newBlock(freq) = let
85 :     val G.GRAPH graph = !cfg
86 :     val id = #new_id graph ()
87 :     val blk as CFG.BLOCK{annotations, ...} = CFG.newBlock(id, ref freq)
88 :     in
89 :     currentBlock := blk;
90 : george 984 annotations := !blockNames @ !reorder;
91 : george 906 blockList := blk :: !blockList;
92 :     #add_node graph (id, blk);
93 :     blk
94 :     end
95 :    
96 :    
97 :     (* get current basic block *)
98 :     fun getBlock () =
99 :     (case !currentBlock of CFG.BLOCK{id= ~1, ...} => newBlock(1) | blk => blk)
100 :    
101 :    
102 :     (* ------------------------cluster---------------------------*)
103 :     (* start a new cluster *)
104 : george 984 fun beginCluster _ =
105 :     (blockList := [];
106 :     entryLabels := [];
107 :     IntHashTable.clear labelMap;
108 :     blockNames := [];
109 :     currentBlock := noBlock)
110 : george 906
111 :     (* emit an instruction *)
112 :     fun emit i = let
113 :     val CFG.BLOCK{insns, ...} = getBlock()
114 :     fun terminate() = currentBlock := noBlock;
115 :     in
116 :     insns := i:: !insns;
117 :     case Props.instrKind(i)
118 :     of Props.IK_JUMP => terminate()
119 :     | Props.IK_CALL_WITH_CUTS => terminate()
120 :     | _ => ()
121 :     (*esac*)
122 :     end
123 :    
124 :     (* make current block an exit block *)
125 :     fun exitBlock liveout = let
126 :     fun setLiveOut(CFG.BLOCK{annotations, ...}) =
127 :     annotations := #create CFG.LIVEOUT liveout :: !annotations
128 :     in
129 :     case !currentBlock
130 :     of CFG.BLOCK{id= ~1, ...} =>
131 :     (case !blockList
132 :     of [] => error "exitBlocks"
133 :     | blk::_ => setLiveOut blk
134 :     (*esac*))
135 :     | blk => setLiveOut blk
136 :     end (* exitBlock *)
137 :    
138 :    
139 :     (* end cluster --- all done *)
140 :     fun endCluster (annotations) = let
141 :     val cfg as G.GRAPH graph = (!cfg before cfg := CFG.new())
142 :     val _ = CFG.init(cfg) (* create unique ENTRY/EXIT nodes *)
143 :    
144 :     val ENTRY = hd(#entries graph ())
145 :     val EXIT = hd(#exits graph ())
146 :    
147 :     fun addEdge(from, to, kind) =
148 :     #add_edge graph (from, to, CFG.EDGE{k=kind, w=ref 0, a=ref[]})
149 :    
150 :     fun target lab =
151 :     (case (IntHashTable.find labelMap (hashLabel lab))
152 :     of SOME bId => bId
153 :     | NONE => EXIT)
154 :    
155 :     fun jump(from, [Props.ESCAPES], _) = addEdge(from, EXIT, CFG.FALLSTHRU)
156 :     | jump(from, [Props.LABELLED lab], _) = addEdge(from, target lab, CFG.JUMP)
157 :     | jump(from, [Props.LABELLED lab, Props.FALLTHROUGH], blks) = let
158 :     fun next(CFG.BLOCK{id, ...}::_) = id
159 : george 984 | next [] = error "jump.next"
160 : george 906 in
161 :     addEdge(from, target lab, CFG.BRANCH true);
162 :     addEdge(from, next blks, CFG.BRANCH false)
163 :     end
164 :     | jump(from, [f as Props.FALLTHROUGH, l as Props.LABELLED _], blks) =
165 :     jump(from, [l, f], blks)
166 :     | jump(from, targets, _) = let
167 :     fun switch(Props.LABELLED lab, n) =
168 :     (addEdge(from, target lab, CFG.SWITCH(n)); n+1)
169 :     | switch _ = error "jump.switch"
170 :     in List.foldl switch 0 targets; ()
171 :     end
172 :    
173 :     and fallsThru(id, blks) = let
174 :     fun fallThruEdge(to) = addEdge (id, to, CFG.FALLSTHRU)
175 :     in
176 :     case blks
177 :     of [] => fallThruEdge(EXIT)
178 :     | CFG.BLOCK{id=next, insns=ref(_::_), (*data=ref[], JHR *) ...}::_ => fallThruEdge(next)
179 :     | CFG.BLOCK{id=next, ...} ::_ => error
180 :     (* if pseudo ops are alignment directives, this may not be an error *)
181 :     (Fmt.format "Block %d falls through to pseudoOps in %d\n"
182 :     [Fmt.INT id, Fmt.INT next])
183 :     end
184 :    
185 :     and addEdges [] = ()
186 :     | addEdges(CFG.BLOCK{id, insns=ref[], ...}::blocks) = fallsThru(id, blocks)
187 :     | addEdges(CFG.BLOCK{id, insns=ref(instr::_), ...}::blocks) = let
188 :     fun doJmp () = jump(id, Props.branchTargets instr, blocks)
189 :     in
190 :     case Props.instrKind instr
191 :     of Props.IK_JUMP => doJmp()
192 :     | Props.IK_CALL_WITH_CUTS => doJmp()
193 :     | _ => fallsThru(id, blocks)
194 :     (*esac*);
195 :     addEdges(blocks)
196 :     end
197 :     in
198 :     addEdges (rev(!blockList));
199 :     app (fn lab => addEdge(ENTRY, target lab, CFG.ENTRY)) (!entryLabels);
200 :     let val an = CFG.annotations cfg in an := annotations @ (!an) end;
201 :     cfg
202 :     end (* endCluster *)
203 :    
204 :    
205 :     (* ------------------------annotations-----------------------*)
206 :     (* XXX: Bug: EMPTYBLOCK does not really generate an empty block
207 :     * but merely terminates the current block. Contradicts the comment
208 :     * in instructions/mlriscAnnotations.sig.
209 : george 984 * It should be (newBlock(1); newBlock(1); ())
210 : george 906 *)
211 :    
212 :     (* Add a new annotation *)
213 :     fun addAnnotation a =
214 :     (case a
215 :     of MLRiscAnnotations.BLOCKNAMES names =>
216 :     (blockNames := names; newBlock(1); ())
217 :     | MLRiscAnnotations.EMPTYBLOCK => (newBlock(1); ())
218 :     | MLRiscAnnotations.EXECUTIONFREQ f =>
219 :     (case !currentBlock
220 :     of CFG.BLOCK{id= ~1, ...} => (newBlock(f); ())
221 :     | CFG.BLOCK{freq, ...} => freq := f
222 :     (*esac*))
223 :     | a => let
224 :     val CFG.BLOCK{annotations,...} = getBlock()
225 :     in annotations := a :: !annotations
226 :     end
227 :     (*esac*))
228 :    
229 :     (* get annotation associated with flow graph *)
230 :     fun getAnnotations () = CFG.annotations(!cfg)
231 :    
232 :     (* add a comment annotation to the current block *)
233 :     fun comment msg = addAnnotation (#create MLRiscAnnotations.COMMENT msg)
234 : george 984
235 :    
236 :     (* -------------------------labels---------------------------*)
237 :     (* BUG: Does not respect any ordering between labels and pseudoOps.
238 :     * This could be a problem with jump tables.
239 :     *)
240 :     fun addPseudoOp p = let
241 :     val Graph.GRAPH graph = !cfg
242 :     val CFG.INFO{data, ...} = #graph_info graph
243 :    
244 :     fun addAlignment () = let
245 :     val CFG.BLOCK{align, ...} = newBlock(1)
246 :     in align := SOME p
247 :     end
248 :    
249 :     fun startSegment(seg) = (data := p :: !data; segmentF := seg)
250 :    
251 :     fun addData(seg) =
252 :     (case !segmentF
253 :     of TEXT =>
254 :     error (Fmt.format "addPseudoOp: %s in TEXT segment" [Fmt.STR seg])
255 :     | _ => data := p :: !data
256 :     (*esac*))
257 :     in
258 :     case p
259 :     of PB.ALIGN_SZ _ => addAlignment()
260 :     | PB.ALIGN_ENTRY => addAlignment()
261 :     | PB.ALIGN_LABEL => addAlignment()
262 :     | PB.DATA_LABEL _ =>
263 :     (case !segmentF
264 :     of TEXT => error "addPseudoOp: DATA_LABEL in TEXT segment"
265 :     | _ => (data := p:: !data)
266 :     (*esac*))
267 :    
268 :     | PB.DATA_READ_ONLY => startSegment(RO_DATA)
269 :     | PB.DATA => startSegment(DATA)
270 :     | PB.TEXT => startSegment(TEXT)
271 :     | PB.SECTION _ =>
272 :     (case !segmentF
273 :     of TEXT => error "addPseudoOp: SECTION in TEXT segment"
274 :     | _ => data := p :: !data
275 :     (*esac*))
276 :     | PB.REORDER => (reorder := []; newBlock(1); ())
277 :     | PB.NOREORDER =>
278 :     (reorder := [#create MLRiscAnnotations.NOREORDER ()]; newBlock(1); ())
279 :    
280 :     | PB.INT _ => addData("INT")
281 :     | PB.FLOAT _ => addData("FLOAT")
282 :     | PB.ASCII _ => addData("ASCII")
283 :     | PB.ASCIIZ _ => addData("ASCIIZ")
284 :     | PB.IMPORT _ => addData("IMPORT")
285 :     | PB.EXPORT _ => addData("EXPORT")
286 :     | PB.EXT _ => addData("EXT")
287 :     end
288 :    
289 :     fun defineLabel lab =
290 :     (case findLabel (hashLabel lab)
291 :     of NONE => let
292 :     fun newBlk () =
293 :     (case !currentBlock
294 :     of CFG.BLOCK{id= ~1, ...} => newBlock(1)
295 :     | CFG.BLOCK{insns=ref[], ...} => !currentBlock (* probably aligned block *)
296 :     | _ => newBlock(1)
297 :     (*esac*))
298 :     val CFG.BLOCK{id, labels, ...} = newBlk()
299 :     in
300 :     labels := lab :: !labels;
301 :     addLabel(hashLabel lab, id)
302 :     end
303 :    
304 :     | SOME _ =>
305 :     error (concat
306 :     ["multiple definitions of label \"", Label.toString lab, "\""])
307 :     (*esac*))
308 :    
309 :     fun entryLabel lab = (defineLabel lab; entryLabels := lab :: !entryLabels)
310 : george 906 in
311 :     S.STREAM
312 :     {
313 :     comment = comment,
314 :     getAnnotations= getAnnotations,
315 :     annotation = addAnnotation,
316 :     defineLabel = defineLabel,
317 :     entryLabel = entryLabel,
318 :     pseudoOp = addPseudoOp,
319 :     beginCluster = beginCluster,
320 :     emit = emit,
321 :     exitBlock = exitBlock,
322 :     endCluster = endCluster
323 :     }
324 :     end
325 :     end

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