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/block-placement/weighted-block-placement-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/block-placement/weighted-block-placement-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1182 - (view) (download)

1 : jhr 1083 (* weighted-block-placement-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
4 :     *
5 :     * This functor implements the bottom-up block-placement algorithm of
6 :     * Pettis and Hansen (PLDI 1990).
7 :     *
8 :     * TODO
9 :     * remove low-weight nodes to break cycles in chain graph
10 :     *)
11 :    
12 :     functor WeightedBlockPlacementFn (
13 : jhr 1106
14 : jhr 1083 structure CFG : CONTROL_FLOW_GRAPH
15 :     structure InsnProps : INSN_PROPERTIES
16 : jhr 1106 where I = CFG.I
17 :    
18 : jhr 1083 ) : BLOCK_PLACEMENT = struct
19 :    
20 : jhr 1090 structure CFG = CFG
21 : jhr 1083 structure IP = InsnProps
22 :     structure G = Graph
23 :     structure ITbl = IntHashTable
24 :     structure PQ = LeftPriorityQFn (
25 :     struct
26 : jhr 1111 type priority = CFG.weight
27 : jhr 1125 val compare = Real.compare
28 : jhr 1083 type item = CFG.edge
29 :     fun priority (_, _, CFG.EDGE{w, ...}) = !w
30 :     end)
31 :    
32 : jhr 1106 (* flags *)
33 : jhr 1129 val dumpBlocks = MLRiscControl.mkFlag (
34 :     "dump-block-list",
35 :     "whether block list is shown")
36 :     val dumpCFG = MLRiscControl.mkFlag (
37 :     "dump-cfg-after-placement",
38 :     "whether CFG is shown after block placement")
39 : jhr 1106 val dumpStrm = MLRiscControl.debug_stream
40 :    
41 : jhr 1083 (* sequences with constant-time concatenation *)
42 :     datatype 'a seq
43 :     = ONE of 'a
44 :     | SEQ of ('a seq * 'a seq)
45 :    
46 :     (* a chain of blocks that should be placed in order *)
47 :     datatype chain = CHAIN of {
48 :     blocks : CFG.node seq,
49 : jhr 1090 hd : CFG.node,
50 :     tl : CFG.node
51 : jhr 1083 }
52 :    
53 :     fun head (CHAIN{hd, ...}) = #1 hd
54 : jhr 1090 fun tail (CHAIN{tl, ...}) = #1 tl
55 : jhr 1083 fun id (CHAIN{hd, ...}) = #1 hd (* use node ID of head to identify chains *)
56 : jhr 1111 fun sameChain (CHAIN{hd=h1, ...}, CHAIN{hd=h2, ...}) = (#1 h1 = #1 h2)
57 : jhr 1083
58 : jhr 1106 fun blockToString (id', CFG.BLOCK{id, ...}) =
59 :     concat["<", Int.toString id', ":", Int.toString id, ">"]
60 :    
61 :     fun chainToString (CHAIN{hd, blocks, ...}) = let
62 :     fun seq (ONE blk, l) = blockToString blk :: l
63 :     | seq (SEQ(s1, s2), l) = seq(s1, "," :: seq(s2, l))
64 :     in
65 :     concat("CHAIN{" :: blockToString hd :: ",[" :: seq(blocks, ["]}"]))
66 :     end
67 :    
68 : jhr 1083 (* join two chains *)
69 : jhr 1090 fun joinChains (CHAIN{blocks=b1, hd, ...}, CHAIN{blocks=b2, tl, ...}) =
70 : jhr 1083 CHAIN{blocks=SEQ(b1, b2), hd=hd, tl=tl}
71 :    
72 :     val unifyChainPtrs = URef.unify joinChains
73 :    
74 :     (* chain pointers provide a union-find structure for chains *)
75 : jhr 1090 type chain_ptr = chain URef.uref
76 : jhr 1083
77 :     type block_chain_tbl = chain_ptr ITbl.hash_table
78 :    
79 :     (* a directed graph representing the placement ordering on chains. An edge
80 :     * from chain c1 to c2 means that we should place c1 before c2. The graph
81 :     * may be cyclic, so we weight the edges and remove the low-cost edge
82 :     * on any cycle.
83 :     *)
84 :     datatype node = ND of {
85 :     chain : chain,
86 :     mark : bool ref,
87 :     kids : edge list ref
88 :     }
89 :     and edge = E of {
90 :     w : CFG.weight,
91 :     dst : node,
92 :     ign : bool ref (* if set, then ignore this edge. We use this *)
93 :     (* flag to break cycles. *)
94 :     }
95 :    
96 :     fun mkNode c = ND{chain = c, mark = ref false, kids = ref []}
97 :     fun mkEdge (w, dst) = E{w = w, dst = dst, ign = ref false}
98 :    
99 :     (* given a table that maps block IDs to chain pointers, construct a table that
100 :     * maps block IDs to their chain-placement graph nodes.
101 :     *)
102 :     fun mkChainPlacementGraph (tbl : block_chain_tbl) = let
103 :     val gTbl = ITbl.mkTable (ITbl.numItems tbl, Fail "graph table")
104 : jhr 1090 val find = ITbl.find gTbl
105 :     val insert = ITbl.insert gTbl
106 : jhr 1083 (* given a block ID and the chain pointer corresponding to the block
107 :     * add the chain node to the graph table (this may involve creating
108 :     * the node if it doesn't already exist).
109 :     *)
110 :     fun blockToNd (blkId, cptr, nodes) = let
111 :     val chain = URef.!! cptr
112 :     val chainId = id chain
113 :     in
114 :     case find chainId
115 :     of NONE => let
116 :     val nd = mkNode chain
117 :     in
118 :     insert (chainId, nd);
119 : jhr 1090 if (blkId <> chainId)
120 : jhr 1083 then insert (blkId, nd)
121 :     else ();
122 :     nd :: nodes
123 :     end
124 :     | SOME nd => (insert (blkId, nd); nodes)
125 :     (* end case *)
126 :     end
127 :     in
128 :     (ITbl.foldi blockToNd [] tbl, gTbl)
129 :     end
130 :    
131 : jhr 1106 fun blockPlacement (cfg as G.GRAPH graph) = let
132 : jhr 1083 (* a map from block IDs to their chain *)
133 :     val blkTbl : chain_ptr ITbl.hash_table = let
134 :     val tbl = ITbl.mkTable (#size graph (), Fail "blkTbl")
135 :     val insert = ITbl.insert tbl
136 : jhr 1090 fun ins (b : CFG.node) = insert (#1 b,
137 :     URef.uRef(CHAIN{blocks = ONE b, hd = b, tl = b}))
138 : jhr 1083 in
139 :     #forall_nodes graph ins;
140 :     tbl
141 :     end
142 : jhr 1090 val lookupChain = ITbl.lookup blkTbl
143 : jhr 1106 (* the unique exit node *)
144 : jhr 1182 val exitId = CFG.exitId cfg
145 : jhr 1083 (* given an edge that connects two blocks, attempt to merge their chains.
146 : jhr 1106 * We return true if a merge occurred. We do not join exit edges so that
147 :     * the exit and entry nodes end up in distinct chains.
148 : jhr 1083 *)
149 : jhr 1106 fun join (src, dst, _) = if (dst = exitId)
150 :     then false
151 :     else let
152 :     val cptr1 = lookupChain src
153 :     val chain1 = URef.!! cptr1
154 :     val cptr2 = lookupChain dst
155 :     val chain2 = URef.!! cptr2
156 :     in
157 :     if (tail chain1 = src) andalso (dst = head chain2)
158 :     andalso not(sameChain(chain1, chain2))
159 :     then (
160 :     (* the source block is the tail of its chain and the
161 :     * destination block is the head of its chain, so we can
162 :     * join the chains.
163 :     *)
164 :     ignore (unifyChainPtrs (cptr1, cptr2));
165 :     true)
166 :     else false (* we cannot join these chains *)
167 :     end
168 : jhr 1083 (* merge chains until all of the edges have been examined; the remaining
169 :     * edges cannot be fall-through.
170 :     *)
171 :     fun loop (pq, edges) = (case PQ.next pq
172 : jhr 1090 of SOME(edge, pq) => if join edge
173 : jhr 1083 then loop (pq, edges)
174 :     else loop (pq, edge::edges)
175 :     | NONE => edges
176 :     (* end case *))
177 : jhr 1090 val edges = loop (PQ.fromList (#edges graph ()), [])
178 : jhr 1083 (* construct a chain placement graph *)
179 :     val (chainNodes, grTbl) = mkChainPlacementGraph blkTbl
180 :     val lookupNd = ITbl.lookup grTbl
181 :     fun addCFGEdge (src, dst, CFG.EDGE{k, w, ...}) = (case k
182 :     (* NOTE: there may be icache benefits to including SWITCH edges. *)
183 :     of CFG.SWITCH _ => ()
184 :     | CFG.FLOWSTO => ()
185 :     | _ => let
186 : jhr 1090 val ND{chain=c1, kids, ...} = lookupNd src
187 : jhr 1083 val dstNd as ND{chain=c2, ...} = lookupNd dst
188 :     in
189 :     if sameChain(c1, c2)
190 :     then ()
191 : jhr 1090 else kids := mkEdge (!w, dstNd) :: !kids
192 : jhr 1083 end
193 :     (* end case *))
194 :     val _ = List.app addCFGEdge edges
195 :     (* FIXME: we should remove low-weight nodes to break cycles *)
196 :     (* now we construct an ordering on the chains by doing a DFS on the
197 :     * chain graph.
198 :     *)
199 :     fun dfs (ND{mark = ref true, ...}, l) = l
200 :     | dfs (ND{mark, chain, kids, ...}, l) = let
201 :     fun addKid (E{ign=ref true, ...}, l) = l
202 :     | addKid (E{dst, ...}, l) = dfs (dst, l)
203 :     in
204 : jhr 1106 mark := true;
205 : jhr 1083 List.foldl addKid (chain::l) (!kids)
206 :     end
207 : jhr 1106 (* mark the exit node, since it should be last. Note that we
208 :     * ensured above that the exit and entry nodes are in distinct
209 :     * chains!
210 :     *)
211 : jhr 1083 val exitChain = let
212 : jhr 1164 val ND{chain, mark, ...} = lookupNd(CFG.exitId cfg)
213 : jhr 1083 in
214 :     mark := true;
215 :     chain
216 :     end
217 :     (* start with the entry node *)
218 : jhr 1164 val chains = dfs (lookupNd(CFG.entryId cfg), [])
219 : jhr 1083 (* place the rest of the nodes and add the exit node *)
220 :     val chains = List.foldl dfs chains chainNodes
221 :     val chains = exitChain :: chains
222 :     (* extract the list of blocks from the chains list; the chains list is
223 : jhr 1106 * in reverse order. The resulting list of blocks is in order.
224 : jhr 1083 *)
225 :     fun addChain (CHAIN{blocks, ...}, blks) = let
226 :     fun addSeq (ONE b, blks) = b::blks
227 :     | addSeq (SEQ(s1, s2), blks) = addSeq(s1, addSeq(s2, blks))
228 :     in
229 :     addSeq (blocks, blks)
230 :     end
231 :     val blocks = List.foldl addChain [] chains
232 :     fun updEdge (CFG.EDGE{w, a, ...}, k) = CFG.EDGE{w=w, a=a, k=k}
233 : george 1176 fun updJmp f (insns as ref(i::r)) = insns := f i :: r
234 :     fun flipJmp (insns, lab) =
235 :     updJmp (fn i => IP.negateConditional(i, lab)) insns
236 :     (* set to true if we change anything *)
237 :     val changed = ref false
238 :     val setEdges = let
239 :     val set = #set_out_edges graph
240 :     in
241 :     fn arg => (changed := true; set arg)
242 :     end
243 : jhr 1083 (* map a block ID to a label *)
244 : george 1176 val labelOf = CFG.labelOf cfg
245 : george 1112 (* patch the blocks so that unconditional jumps to the immediate successor
246 :     * are replaced by fall-through edges and conditional jumps to the immediate
247 :     * successor are negated. Remember that we cannot fall through to the exit
248 :     * block!
249 :     *)
250 : jhr 1083 fun patch (
251 : george 1176 nd as (blkId, CFG.BLOCK{kind=CFG.NORMAL, insns, freq, ...}),
252 :     (next as (nextId, _)) :: rest,
253 :     l
254 : jhr 1177 ) = let
255 :     fun continue () = patch (next, rest, nd::l)
256 :     in
257 :     case #out_edges graph blkId
258 :     of [(_, dst, e as CFG.EDGE{k, w, a})] => (
259 :     case (dst = nextId, k)
260 :     of (false, CFG.FALLSTHRU) => (
261 :     (* rewrite edge as JUMP and add jump insn *)
262 :     setEdges (blkId, [(blkId, dst, updEdge(e, CFG.JUMP))]);
263 :     insns := IP.jump(labelOf dst) :: !insns)
264 :     | (true, CFG.JUMP) =>
265 :     if (nextId <> exitId)
266 :     then (
267 :     (* rewrite edge as FALLSTHRU and remove jump insn *)
268 :     setEdges (blkId,
269 :     [(blkId, dst, updEdge(e, CFG.FALLSTHRU))]);
270 :     insns := tl(!insns))
271 :     else () (* do not rewrite jumps to STOP block *)
272 :     | _ => ()
273 :     (* end case *);
274 :     continue())
275 :     | [(_, dst1, e1 as CFG.EDGE{k=CFG.BRANCH b, ...}),
276 :     (_, dst2, e2)
277 :     ] => (case (dst1 = nextId, dst2 = nextId, b)
278 :     of (false, false, _) => let
279 :     (* here, we have to introduce a new block that
280 :     * jumps to the false target.
281 :     *)
282 :     fun rewrite (trueId, trueE, falseId, falseE) = let
283 :     val CFG.EDGE{w, a, ...} = falseE
284 :     val nd' as (id, CFG.BLOCK{insns=i, ...}) =
285 :     CFG.newNode cfg (!w)
286 :     in
287 :     (* initialize the new block *)
288 :     i := [IP.jump(labelOf falseId)];
289 :     setEdges (id, [
290 :     (id, falseId, CFG.EDGE{
291 :     w = ref(!w), a = ref[], k=CFG.JUMP})
292 :     ]);
293 :     (* rewrite the out edges of the old block *)
294 :     setEdges (blkId, [
295 :     (blkId, trueId, trueE),
296 :     (blkId, id, CFG.EDGE{
297 :     k=CFG.BRANCH false, w=w, a=a
298 :     })
299 :     ]);
300 :     (* rewrite the old jump instruction *)
301 :     updJmp (fn i =>
302 :     IP.setBranchTargets{
303 :     i=i, t=labelOf trueId, f=labelOf id
304 :     }) insns;
305 :     patch (next, rest, nd'::nd::l)
306 :     end
307 :     in
308 :     if b
309 :     then rewrite (dst1, e1, dst2, e2)
310 :     else rewrite (dst2, e2, dst1, e1)
311 :     end
312 :     | (true, _, true) => (
313 :     setEdges (blkId, [
314 :     (blkId, dst1, updEdge(e1, CFG.BRANCH false)),
315 :     (blkId, dst2, updEdge(e2, CFG.BRANCH true))
316 :     ]);
317 :     flipJmp (insns, labelOf dst2);
318 :     continue())
319 :     | (false, _, false) => (
320 :     setEdges (blkId, [
321 :     (blkId, dst1, updEdge(e1, CFG.BRANCH true)),
322 :     (blkId, dst2, updEdge(e2, CFG.BRANCH false))
323 :     ]);
324 :     flipJmp (insns, labelOf dst1);
325 :     continue())
326 :     | _ => continue()
327 :     (* end case *))
328 :     | _ => continue()
329 :     (* end case *)
330 :     end
331 : george 1176 | patch (nd, next::rest, l) = patch(next, rest, nd::l)
332 : jhr 1177 | patch (nd, [], l) = List.rev(nd::l)
333 : george 1176 val blocks = patch (hd blocks, tl blocks, [])
334 : jhr 1083 in
335 : george 1176 if !changed then CFG.changed cfg else ();
336 : jhr 1106 if !dumpBlocks
337 :     then let
338 :     fun say s = TextIO.output(!dumpStrm, s)
339 :     in
340 :     say "Block placement order:\n";
341 :     List.app
342 :     (fn b => say(concat[" ", blockToString b, "\n"]))
343 :     blocks
344 :     end
345 :     else ();
346 :     if !dumpCFG
347 : george 1112 then let
348 :     val prBlock = CFG.dumpBlock (!dumpStrm, cfg)
349 :     in
350 :     TextIO.output(!dumpStrm, "[ after block placement ]\n");
351 :     List.app prBlock blocks
352 :     end
353 : jhr 1106 else ();
354 : george 1133 (cfg, blocks)
355 : jhr 1083 end
356 :    
357 :     end

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