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/mlrisc/ra.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/mlrisc/ra.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 113 - (view) (download)
Original Path: sml/branches/SMLNJ/src/MLRISC/mlrisc/ra.sml

1 : monnier 16 (* Copyright 1996 AT&T Bell Laboratories
2 :     *
3 :     *)
4 :    
5 :     (** Graph coloring register allocation.
6 :     ** Implements the 'iterated register coalescing' scheme described
7 :     ** in POPL'96, and TOPLAS v18 #3, pp 325-353.
8 :     **)
9 :     functor RegAllocator
10 :     (structure RaArch : RA_ARCH_PARAMS)
11 :     (structure RaUser : RA_USER_PARAMS
12 :     (* where I = RaArch.I -- bug 1205 *)
13 :     where type I.operand = RaArch.I.operand
14 :     and type I.instruction = RaArch.I.instruction
15 :     (* -- equivalent where type if where structure not working *)
16 :     ) : RA =
17 :     struct
18 :     structure F = RaArch.Liveness.F
19 :     structure P = RaArch.InsnProps
20 :     structure C = F.C
21 :     structure SL = SortedList
22 :     structure BM = TriangularBitMatrix
23 :    
24 :     fun error msg = MLRiscErrorMsg.impossible ("RegAllocator." ^ msg)
25 :     fun assert(msg, true) = () | assert(msg, false) = error msg
26 :    
27 :     (*---------datatypes------------ *)
28 :    
29 :     datatype mode = REGISTER_ALLOCATION | COPY_PROPAGATION
30 :    
31 :     datatype moveStatus = MOVE | COALESCED | CONSTRAINED | LOST | WORKLIST
32 :    
33 :     datatype move =
34 :     MV of {src : node, (* source register of move *)
35 :     dst : node, (* destination register of move *)
36 :     status : moveStatus ref (* coalesced? *)
37 :     }
38 :    
39 :     and nodeStatus = REMOVED | PSEUDO | ALIASED of node | COLORED of int
40 :    
41 :     and node =
42 :     NODE of { number : int, (* node number *)
43 :     movecnt: int ref, (* # of moves this node is involved in *)
44 :     movelist: move list ref, (* moves associated with this node *)
45 :     degree : int ref, (* current degree *)
46 :     color : nodeStatus ref, (* status *)
47 :     adj : node list ref (* adjacency list *)
48 :     }
49 :     (* the valid transitions for a node are:
50 :     * PSEUDO -> REMOVED % during simplify
51 :     * PSEUDO -> ALIASED(n) % during coalescing
52 :     * REMOVED -> COLORED(r) % assigning a color
53 :     *
54 :     * ... all others are illegal.
55 :     *)
56 :    
57 :     fun newNode(num, col) =
58 :     NODE{number=num,
59 :     color=ref col,
60 :     degree=ref 0,
61 :     adj=ref [],
62 :     movecnt = ref 0,
63 :     movelist = ref []}
64 :    
65 :     fun nodeNumber(NODE{number, ...}) = number
66 :    
67 :     fun nodeMember(_, []) = false
68 :     | nodeMember(node as NODE{number=x, ...}, NODE{number=y,...}::rest) =
69 :     x = y orelse nodeMember(node, rest)
70 :    
71 :     fun chase(NODE{color=ref(ALIASED r), ...}) = chase r
72 :     | chase x = x
73 :    
74 :     fun isMoveRelated(NODE{movecnt=ref 0, ...}) = false
75 :     | isMoveRelated _ = true
76 :    
77 :    
78 :     (*-------------------------------*)
79 :     (* set of dedicated registers *)
80 :     val dedicated = SL.uniq RaUser.dedicated
81 :     val isDedicated = SL.member dedicated
82 :    
83 :     (* Note: This function maintains the order of members in rset
84 :     * which is important when dealing with parallel copies.
85 :     *)
86 :     fun rmvDedicated rset = let
87 :     fun f (x::xs) = if isDedicated x then f xs else x::f xs
88 :     | f [] = []
89 :     in f rset
90 :     end
91 :    
92 :     (* register mapping functions *)
93 :     fun uniqMap(f, l) = let
94 :     fun map([], acc) = acc
95 :     | map(x::xs, acc) = map(xs, SL.enter(f x, acc))
96 :     in map(l, [])
97 :     end
98 :    
99 :     (*---------printing------------ *)
100 :     fun prList (l:int list,msg:string) = let
101 :     fun pr [] = print "\n"
102 :     | pr (x::xs) = (print (Int.toString x ^ " "); pr xs)
103 :     in
104 :     print msg; pr l
105 :     end
106 :    
107 :     fun printBlocks(blks, regmap) = let
108 :     fun prBlks([]) = print"\n"
109 :     | prBlks(F.BBLOCK{blknum,insns,liveOut,liveIn,succ,pred,...}::blocks)=let
110 :     fun rmap r = (Intmap.map regmap r) handle _ => r
111 :     fun regset cellset = map rmap (RaArch.regSet(cellset))
112 :     fun pr [] = prList(regset(!liveOut), "liveOut: ")
113 :     | pr (instr::rest) =
114 :     (RaArch.AsmEmitter.emitInstr(instr,regmap); pr rest)
115 :     fun blkNum(F.BBLOCK{blknum, ...}) = blknum
116 :     | blkNum(F.ENTRY{blknum, ...}) = blknum
117 :     | blkNum(F.EXIT{blknum, ...}) = blknum
118 :     | blkNum _ = error "printBlocks.prBlks.blkNum"
119 :     in
120 :     print("BLOCK" ^ Int.toString blknum ^ "\n");
121 :     prList(regset (!liveIn), "LiveIn :");
122 :     prList(map blkNum (!pred),"predecessors: ");
123 :     case !insns of [] => print "empty instruction sequence\n"
124 :     | l => pr(rev l)
125 :     (*esac*);
126 :     prList(map blkNum (!succ),"successors: ");
127 :     prBlks(blocks)
128 :     end
129 :     | prBlks(F.LABEL lab::blocks) =
130 :     (print(Label.nameOf lab^":\n");
131 :     prBlks(blocks))
132 :     | prBlks(F.ORDERED blks::blocks) = (prBlks blks; prBlks blocks)
133 :     | prBlks(_::blocks) = prBlks(blocks)
134 :    
135 :     val saveStrm= !AsmStream.asmOutStream
136 :     in
137 :     AsmStream.asmOutStream:=TextIO.stdOut;
138 :     prBlks blks;
139 :     AsmStream.asmOutStream:=saveStrm
140 :     end
141 :    
142 :     fun debug(msg, blocks, regmap) =
143 :     if false then
144 :     (print ("------------------" ^ msg ^ " ----------------\n");
145 :     printBlocks(blocks,regmap))
146 :     else ()
147 :    
148 :     (*------------------------------*)
149 :     fun graphColoring(mode, blocks, cblocks, blockDU, prevSpills,
150 :     nodes, regmap) = let
151 :     datatype worklists = WKL of
152 :     {simplifyWkl: node list, (* nodes that can be simplified *)
153 :     moveWkl : move list, (* moves to be considered for coalescing *)
154 :     freezeWkl : node list, (* all n, s.t. degree(n)<K and moveRelated(n) *)
155 :     spillWkl : node list, (* all n, s.t. degree(n)>=K *)
156 :     stack : node list} (* nodes removed from the graph *)
157 :    
158 :     val K = RaUser.nFreeRegs
159 :     val numOfBlocks = Array.length cblocks
160 :     val maxR = RaArch.maxPseudoR()
161 :    
162 :     val getnode = Intmap.map nodes
163 :     val chaseReg = chase o getnode
164 :     val chaseRegs = map chaseReg
165 :    
166 :     (* Info to undo a spill when an optimistic spill has occurred *)
167 :     val spillFlag = ref false
168 :     val undoInfo : (node * moveStatus ref) list ref = ref []
169 :    
170 :     (* lower triangular bitmatrix primitives *)
171 :     (* NOTE: The average ratio of E/N is about 16 *)
172 :     val bitMatrix = BM.new (RaArch.numRegs() * 20)
173 :     val addBitMatrix = BM.add bitMatrix
174 :     local
175 :     val member = BM.member bitMatrix
176 :     in
177 :     fun memBitMatrix(NODE{number=x,...}, NODE{number=y,...}) =
178 :     member (if x<y then (x, y) else (y, x))
179 :     end
180 :    
181 :     fun newdu (d, u) = let
182 :     fun rmv [] = []
183 :     | rmv (r::rs) = let
184 :     val node =
185 :     getnode r handle _ => let
186 :     val n = newNode(r, PSEUDO)
187 :     in Intmap.add nodes (r, n); n
188 :     end
189 :     in chase node::rmv rs
190 :     end
191 :     val rmv' = rmv o rmvDedicated
192 :     in (rmv' d, rmv' u)
193 :     end (* newdu *)
194 :    
195 :     val defUse = newdu o RaArch.defUse
196 :    
197 :     (*--------interference graph construction--------*)
198 :    
199 :     (* add an edge to the interference graph.
200 :     * note --- adjacency lists for machine registers are not maintained.
201 :     *)
202 :     fun addEdge(x as NODE{number=xn, ...}, y as NODE{number=yn, ...}) = let
203 :     fun add(r as NODE{color=ref PSEUDO, adj, degree,...}, s) =
204 :     (adj := s :: !adj;
205 :     degree := 1 + !degree)
206 :     | add(NODE{color=ref(ALIASED _), ...}, _) = error "addEdge.add: ALIASED"
207 :     | add(NODE{color=ref(REMOVED), ...}, _) = error "addEdge.add: REMOVED"
208 :     | add _ = ()
209 :     in
210 :     if xn = yn then ()
211 :     else if addBitMatrix(if xn < yn then (xn, yn) else (yn, xn)) then
212 :     (add(x, y); add(y, x))
213 :     else ()
214 :     end
215 :    
216 :     (* Builds the interference graph and initialMove list *)
217 :     fun mkInterferenceGraph() = let
218 :     (* The movecnt field is used to (lazily) record members in the
219 :     * live set. Deleted members are removed during an
220 :     * addEdgeForallLive operation.
221 :     *)
222 :     fun delete(NODE{movecnt, ...}) = movecnt:=0
223 :     fun insert((node as NODE{movecnt as ref 0, ...})::rest, live) =
224 :     (movecnt:=1; insert(rest, node::live))
225 :     | insert(_::rest, live) = insert(rest, live)
226 :     | insert([], live) = live
227 :     fun addEdgeForallLive([], live) = live
228 :     | addEdgeForallLive(d::ds, live) = let
229 :     fun f ([], pruned) = pruned
230 :     | f ((n as NODE{movecnt as ref 1, ...})::rest, pruned) =
231 :     (addEdge(d, n); f(rest, n::pruned))
232 :     | f (_::rest, pruned) = f(rest, pruned)
233 :     in
234 :     addEdgeForallLive(ds, f(live, []))
235 :     end
236 :     fun forallBlocks(~1, mvs) = mvs
237 :     | forallBlocks(n, mvs) = let
238 :     val F.BBLOCK{insns, liveOut, ...} = Array.sub(cblocks, n)
239 :     val bdu = Array.sub(blockDU, n)
240 :     fun doBlock([], _, live, mvs) =
241 :     (app (fn NODE{movecnt, ...} => movecnt := 0) live;
242 :     forallBlocks(n-1, mvs))
243 :     | doBlock(instr::rest, (def',use')::bdu, live', mvs) = let
244 :     val def = map chase def'
245 :     val use = map chase use'
246 :    
247 :     (* move instructions are treated specially *)
248 :     (* There is a subtle interaction between parallel
249 :     moves and interference graph construction. When we
250 :     have {d1, ... dn} <- {s1, ... sn} and liveOut we
251 :     should make di interfere with:
252 :    
253 :     liveOut U {d1, ... dn} U ({s1, ... sn} \ {si})
254 :    
255 :     This is not currently done.
256 :     *)
257 :     fun zip(defs, uses) = let
258 :     fun f([], []) = mvs
259 :     | f(d::defs, u::uses) =
260 :     if d=u then f(defs, uses)
261 :     else MV{dst=d, src=u, status=ref WORKLIST}::f(defs, uses)
262 :     in if length defs <> length uses then mvs else f(defs, uses)
263 :     end
264 :    
265 :     (* Assumes that the move temporary if present is always the
266 :     * first thing on the definition list.
267 :     *)
268 :     val moves =
269 :     if P.moveInstr instr then
270 :     (case P.moveTmpR instr
271 :     of NONE => zip(def, use)
272 :     | SOME r => if null def then mvs else zip(tl def, use))
273 :     else mvs
274 :    
275 :     val live =
276 :     if length def > 1 then
277 :     addEdgeForallLive(def, insert(def, live'))
278 :     else addEdgeForallLive(def, live')
279 :     in
280 :     app delete def;
281 :     doBlock(rest, bdu, insert(use,live), moves)
282 :     end
283 :     val lout = chaseRegs (rmvDedicated(RaArch.regSet(!liveOut)))
284 :     in
285 :     doBlock(!insns, bdu, insert(lout, []), mvs)
286 :     end
287 :     (* Filter moves that already have an interference.
288 :     * Also initialize the movelist and movecnt fields at this time.
289 :     *)
290 :     fun filter [] = []
291 :     | filter (MV{src=NODE{color=ref(COLORED _), ...},
292 :     dst=NODE{color=ref(COLORED _), ...}, ...}::rest) =
293 :     filter rest
294 :     | filter ((mv as MV{src, dst, ...})::rest) =
295 :     if memBitMatrix(src, dst) then filter rest
296 :     else let
297 :     fun info(u as NODE{color=ref PSEUDO, movecnt, movelist,...}) =
298 :     (movelist := mv :: !movelist; movecnt := 1 + !movecnt)
299 :     | info _ = ()
300 :     in info src; info dst; mv::filter rest
301 :     end
302 :     in filter(forallBlocks(numOfBlocks-1, []))
303 :     end (* mkInterferenceGraph *)
304 :    
305 :    
306 :     (*--------build worklists----------*)
307 :    
308 :     (* make initial worklists. Note: register aliasing may have
309 :     * occurred due to previous rounds of graph-coloring; therefore
310 :     * nodes may already be colored or aliased.
311 :     *)
312 :     fun mkInitialWorkLists initialMoves = let
313 :     fun iter([], simpWkl, fzWkl, spillWkl) =
314 :     {simplifyWkl = simpWkl,
315 :     freezeWkl = fzWkl,
316 :     spillWkl = spillWkl,
317 :     moveWkl = initialMoves,
318 :     stack = []}
319 :     | iter((_, node)::rest, simpWkl, fzWkl, spillWkl) =
320 :     (case node
321 :     of NODE{color=ref PSEUDO, degree, ...} =>
322 :     if !degree >= K then
323 :     iter(rest, simpWkl, fzWkl, node::spillWkl)
324 :     else if isMoveRelated(node) then
325 :     iter(rest, simpWkl, node::fzWkl, spillWkl)
326 :     else
327 :     iter(rest, node::simpWkl, fzWkl, spillWkl)
328 :     | _ =>
329 :     iter(rest, simpWkl, fzWkl, spillWkl)
330 :     (*esac*))
331 :     in iter(Intmap.intMapToList nodes, [], [], [])
332 :     end
333 :    
334 :     fun liveness blocks = let
335 :     fun regmap i = let
336 :     val node = getnode i
337 :     in
338 :     case node
339 :     of NODE{color= ref (COLORED r), ...} => r
340 :     | NODE{color=ref PSEUDO, ...} => nodeNumber node
341 :     | NODE{color=ref(ALIASED r), ...} => nodeNumber(chase node)
342 :     | _ => error "liveness.regmap"
343 :     end handle _ => i (* XXX *)
344 :     in RaArch.Liveness.liveness(blocks, regmap)
345 :     end
346 :    
347 :     val _ = liveness blocks
348 :     val initialMoves = mkInterferenceGraph()
349 :     val initialWkls = mkInitialWorkLists initialMoves
350 :    
351 :     (* debugging *)
352 :     fun dumpGraph() = let
353 :     fun prAdj(nodes, n)= prList(map (nodeNumber o chase) nodes, n)
354 :     in
355 :     Intmap.app
356 :     (fn (n, NODE{adj, ...}) =>
357 :     prAdj (!adj, Int.toString(n) ^ " <--> "))
358 :     nodes
359 :     end
360 :    
361 :     val _ = debug("before register allocation", blocks, regmap);
362 :    
363 :     (*---------simplify-----------*)
364 :    
365 :     (* activate moves associated with a node and its neighbors *)
366 :     fun enableMoves(node as NODE{adj, ...}, moveWkl) = let
367 :     fun addMvWkl([], wkl) = wkl
368 :     | addMvWkl((mv as MV{status, ...})::rest, wkl) =
369 :     (case !status
370 :     of MOVE =>
371 :     (status := WORKLIST; addMvWkl(rest, mv::wkl))
372 :     | _ => addMvWkl(rest, wkl)
373 :     (*esac*))
374 :    
375 :     fun add([], wkl) = wkl
376 :     | add((node as NODE{movelist, color=ref PSEUDO,...})::ns, wkl) =
377 :     if isMoveRelated node then
378 :     add(ns, addMvWkl(!movelist, wkl))
379 :     else
380 :     add(ns, wkl)
381 :     | add(_::ns, wkl) = wkl
382 :     in
383 :     add(node:: (!adj), moveWkl)
384 :     end
385 :    
386 :     (* decrement the degree associated with a node returning a potentially
387 :     * new set of worklists --- simplifyWkl, freezeWkl, and moveWkl.
388 :     *)
389 :     fun decrementDegree(node as (NODE{degree as ref d, ...}),
390 :     simpWkl, fzWkl, mvWkl) =
391 :     (degree := d - 1;
392 :     if d = K then let
393 :     val moveWkl = enableMoves(node, mvWkl)
394 :     in
395 :     if isMoveRelated(node) then
396 :     (simpWkl, node::fzWkl, moveWkl)
397 :     else
398 :     (node::simpWkl, fzWkl, moveWkl)
399 :     end
400 :     else
401 :     (simpWkl, fzWkl, mvWkl))
402 :    
403 :    
404 :     (* for every node removed from the simplify worklist, decrement the
405 :     * degree of all of its neighbors, potentially adding the neighbor
406 :     * to the simplify worklist.
407 :     *)
408 :     fun simplify(WKL{simplifyWkl,freezeWkl,spillWkl,moveWkl,stack}) = let
409 :     fun loop([], fzWkl, mvWkl, stack) =
410 :     WKL{simplifyWkl=[], freezeWkl=fzWkl, moveWkl=mvWkl,
411 :     stack=stack, spillWkl=spillWkl}
412 :     | loop((node as NODE{color as ref PSEUDO, adj, ...})::wkl,
413 :     fzWkl, mvWkl, stack) = let
414 :     fun forallAdj([], simpWkl, fzWkl, mvWkl) =
415 :     loop(simpWkl, fzWkl, mvWkl, node::stack)
416 :     | forallAdj((n as NODE{color as ref PSEUDO, ...})::rest,
417 :     wkl, fzWkl, mvWkl) = let
418 :     val (wkl, fzWkl, mvWkl) = decrementDegree(n, wkl, fzWkl, mvWkl)
419 :     in
420 :     forallAdj(rest, wkl, fzWkl, mvWkl)
421 :     end
422 :     | forallAdj(_::rest, simpWkl, fzWkl, mvWkl) =
423 :     forallAdj(rest, simpWkl, fzWkl, mvWkl)
424 :     in
425 :     color := REMOVED;
426 :     forallAdj(!adj, wkl, fzWkl, mvWkl)
427 :     end
428 :     | loop(_::ns, fzWkl, mvWkl, stack) = loop(ns, fzWkl, mvWkl, stack)
429 :     in
430 :     loop(simplifyWkl, freezeWkl, moveWkl, stack)
431 :     end
432 :    
433 :     (*-----------coalesce-------------*)
434 :    
435 :     fun coalesce(WKL{moveWkl, simplifyWkl, freezeWkl, spillWkl, stack}) = let
436 :     (* v is being replaced by u *)
437 :     fun combine(v as NODE{color=cv, movecnt, movelist=mv, adj, ...},
438 :     u as NODE{color=cu, movelist=mu, ...},
439 :     mvWkl, simpWkl, fzWkl) = let
440 :     (* merge moveList entries, taking the opportunity to prune the lists *)
441 :     fun mergeMoveLists([], [], mvs) = mvs
442 :     | mergeMoveLists([], xmvs, mvs) = mergeMoveLists(xmvs, [], mvs)
443 :     | mergeMoveLists((mv as MV{status,...})::rest, other, mvs) =
444 :     (case !status
445 :     of (MOVE | WORKLIST) =>
446 :     mergeMoveLists(rest, other, mv::mvs)
447 :     | _ => mergeMoveLists(rest, other, mvs)
448 :     (*esac*))
449 :    
450 :     (* form combined node *)
451 :     fun union([], mvWkl, simpWkl, fzWkl) = (mvWkl, simpWkl, fzWkl)
452 :     | union((t as NODE{color, ...})::rest, mvWkl, simpWkl, fzWkl) =
453 :     (case color
454 :     of ref (COLORED _) =>
455 :     (addEdge(t, u); union(rest, mvWkl, simpWkl, fzWkl))
456 :     | ref PSEUDO =>
457 :     ((* the order of addEdge and decrementDegree is important *)
458 :     addEdge (t, u);
459 :     let val (wkl, fzWkl, mvWkl) =
460 :     decrementDegree(t, simpWkl, fzWkl, mvWkl)
461 :     in
462 :     union(rest, mvWkl, wkl, fzWkl)
463 :     end)
464 :     | _ => union(rest, mvWkl, simpWkl, fzWkl)
465 :     (*esac*))
466 :     in
467 :     cv := ALIASED u;
468 :     movecnt := 0;
469 :     case cu
470 :     of ref PSEUDO => mu := mergeMoveLists(!mu, !mv, [])
471 :     | _ => ()
472 :     (*esac*);
473 :     union(!adj, mvWkl, simpWkl, fzWkl)
474 :     end (*combine*)
475 :    
476 :     (* If a node is no longer move-related as a result of coalescing,
477 :     * and can become candidate for the next round of simplification.
478 :     *)
479 :     fun addWkl(node as NODE{color=ref PSEUDO,
480 :     movecnt as ref mc,
481 :     degree, ...}, c, wkl) = let
482 :     val ncnt = mc - c
483 :     in
484 :     if ncnt <> 0 then (movecnt := ncnt; wkl)
485 :     else if !degree >= K then wkl
486 :     else node::wkl
487 :     end
488 :     | addWkl(_, _, wkl) = wkl
489 :    
490 :     (* heuristic used to determine if a pseudo and machine register
491 :     * can be coalesced.
492 :     *)
493 :     fun safe(r, NODE{adj, ...}) = let
494 :     fun f [] = true
495 :     | f (NODE{color=ref (COLORED _), ...}::rest) = f rest
496 :     | f ((x as NODE{degree, ...})::rest) =
497 :     (!degree < K orelse memBitMatrix(x, r)) andalso f rest
498 :     in
499 :     f(!adj)
500 :     end
501 :    
502 :     (* return true if Briggs et.al. conservative heuristic applies *)
503 :     fun conservative(x as NODE{degree=ref dx, adj=ref xadj, ...},
504 :     y as NODE{degree=ref dy, adj=ref yadj, ...}) =
505 :     dx + dy < K
506 :     orelse let
507 :     (* movecnt is used as a temporary scratch to record high degree
508 :     * or colored nodes we have already visited
509 :     * ((movecnt = ~1) => visited)
510 :     *)
511 :     fun g(_, _, 0) = false
512 :     | g([], [], _) = true
513 :     | g([], yadj, k) = g(yadj, [], k)
514 :     | g(NODE{color=ref REMOVED, ...}::vs, yadj, k) = g(vs, yadj, k)
515 :     | g(NODE{color=ref(ALIASED _), ...}::vs, yadj, k) = g(vs, yadj, k)
516 :     | g(NODE{movecnt=ref ~1, ...} ::vs, yadj, k) = g(vs, yadj, k)
517 :     | g(NODE{movecnt, color=ref(COLORED _), ...}::vs, yadj, k) = let
518 :     val m = !movecnt
519 :     in movecnt := ~1; g(vs, yadj, k-1) before movecnt := m
520 :     end
521 :     | g(NODE{movecnt as ref m,
522 :     degree, color=ref PSEUDO,...}::vs, yadj, k) =
523 :     if !degree < K then g(vs, yadj, k)
524 :     else (movecnt := ~1;
525 :     g(vs, yadj, k-1) before movecnt := m)
526 :     in g(xadj, yadj, K)
527 :     end
528 :    
529 :     (* iterate over move worklist *)
530 :     fun doMoveWkl((mv as MV{src,dst,status,...})::rest, wkl, fzWkl) = let
531 :     val (u as NODE{number=u', color as ref ucol, ...},
532 :     v as NODE{number=v', movecnt as ref vCnt, ...}) =
533 :     case (chase src, chase dst)
534 :     of (x, y as NODE{color=ref (COLORED _),...}) => (y,x)
535 :     | (x,y) => (x,y)
536 :     fun coalesceIt() =
537 :     (status := COALESCED;
538 :     if !spillFlag then undoInfo := (v, status) :: (!undoInfo)
539 :     else ())
540 :     in
541 :     if u' = v' then
542 :     (coalesceIt ();
543 :     doMoveWkl(rest, addWkl(u, 2, wkl), fzWkl))
544 :     else
545 :     (case v
546 :     of NODE{color=ref(COLORED _), ...} =>
547 :     (status := CONSTRAINED;
548 :     doMoveWkl(rest, wkl, fzWkl))
549 :     | _ => (* v is a pseudo register *)
550 :     if memBitMatrix (v, u) then
551 :     (status := CONSTRAINED;
552 :     doMoveWkl(rest, addWkl(v,1,addWkl(u,1,wkl)), fzWkl))
553 :     else
554 :     (case ucol
555 :     of COLORED _ =>
556 :     (* coalescing a pseudo and machine register *)
557 :     if safe(u,v) then
558 :     (coalesceIt();
559 :     doMoveWkl(combine(v, u, rest, wkl, fzWkl)))
560 :     else
561 :     (status := MOVE;
562 :     doMoveWkl(rest, wkl, fzWkl))
563 :     | _ =>
564 :     (* coalescing pseudo and pseudo register *)
565 :     if conservative(u, v) then let
566 :     val (mvWkl, wkl, fzWkl) =
567 :     combine(v, u, rest, wkl, fzWkl)
568 :     in
569 :     coalesceIt();
570 :     doMoveWkl(mvWkl, addWkl(u, 2-vCnt, wkl), fzWkl)
571 :     end
572 :     else
573 :     (status := MOVE;
574 :     doMoveWkl(rest, wkl, fzWkl))
575 :     (*esac*))
576 :     (*esac*))
577 :     end
578 :     | doMoveWkl([], wkl, fzWkl) =
579 :     (* Note. The wkl is not uniq, because decrementDegree may have
580 :     * added the same node multiple times. We will let simplify take
581 :     * care of this.
582 :     *)
583 :     WKL{simplifyWkl = wkl, freezeWkl = fzWkl,
584 :     moveWkl = [], spillWkl = spillWkl, stack = stack}
585 :     in
586 :     doMoveWkl(moveWkl, simplifyWkl, freezeWkl)
587 :     end (* coalesce *)
588 :    
589 :    
590 :     (*-----------freeze------------*)
591 :    
592 :     (* When a move is frozen in place, the operands of the move may
593 :     * be simplified. One of the operands is node (below).
594 :     *)
595 :     fun wklFromFrozen(NODE{number=node, movelist, movecnt, ...}) = let
596 :     fun mkWkl(MV{status, src, dst, ...}) = let
597 :     val s = chase src and d = chase dst
598 :     val y = if nodeNumber s = node then d else s
599 :     in
600 :     case !status
601 :     of MOVE =>
602 :     (status := LOST;
603 :     case y
604 :     of NODE{color=ref(COLORED _), ...} => NONE
605 :     | NODE{movecnt=ref 1, degree, ...} =>
606 :     (movecnt := 0;
607 :     if !degree < K then SOME y
608 :     else NONE)
609 :     | NODE{movecnt,...} =>
610 :     (movecnt := !movecnt - 1; NONE)
611 :     (*esac*))
612 :     | WORKLIST => error "wklFromFrozen"
613 :     | _ => NONE
614 :     end
615 :     in
616 :     movecnt:=0;
617 :     List.mapPartial mkWkl (!movelist)
618 :     end
619 :    
620 :    
621 :     (* freeze a move in place
622 :     * Important: A node in the freezeWkl starts out with a degree < K.
623 :     * However, because of coalescing, it may have its degree increased
624 :     * to > K; BUT is guaranteed never to be a spill candidate. We do not
625 :     * want to select such nodes for freezing. There has to be some other
626 :     * freeze candidate that will liberate such nodes.
627 :     *)
628 :     fun freeze(WKL{freezeWkl, simplifyWkl, spillWkl, moveWkl, stack}) = let
629 :     fun find([], acc) = (NONE, acc)
630 :     | find((n as NODE{color=ref PSEUDO, degree=ref d, ...})::ns, acc) =
631 :     if d >= K then find(ns, n::acc) else (SOME n, acc@ns)
632 :     | find(_::ns, acc) = find(ns, acc)
633 :    
634 :     fun mkWorkLists(NONE, fzWkl) =
635 :     WKL{freezeWkl=fzWkl, simplifyWkl=simplifyWkl,
636 :     spillWkl=spillWkl, moveWkl=moveWkl, stack=stack}
637 :     | mkWorkLists(SOME n, fzWkl) =
638 :     WKL{freezeWkl=fzWkl, simplifyWkl=n::wklFromFrozen n,
639 :     spillWkl=spillWkl, moveWkl=moveWkl, stack=stack}
640 :     in
641 :     mkWorkLists(find(freezeWkl,[]))
642 :     end
643 :    
644 :     (*----------select spill node--------------*)
645 :     (* remainInfo: blocks where spill nodes are defined and used. *)
646 :     type info = int list Intmap.intmap
647 :     val remainInfo : (info * info) option ref = ref NONE
648 :    
649 :     fun cleanupSpillInfo() = remainInfo := NONE
650 :    
651 :     fun selectSpillNode(WKL{simplifyWkl, spillWkl, stack, moveWkl, freezeWkl}) = let
652 :    
653 :     (* duCount: compute the def/use points of spilled nodes. *)
654 :     fun duCount spillable = let
655 :     val size = length spillable
656 :     exception Info
657 :     val defInfo : info = Intmap.new(size,Info)
658 :     val useInfo : info = Intmap.new(size,Info)
659 :     val addDef = Intmap.add defInfo
660 :     val addUse = Intmap.add useInfo
661 :     fun getDefs n = (Intmap.map defInfo n) handle _ => []
662 :     fun getUses n = (Intmap.map useInfo n) handle _ => []
663 :    
664 :     (* doblocks --- updates the defInfo and useInfo tables to indicate
665 :     * the blocks where spillable live ranges are defined and used.
666 :     *)
667 :     fun doblocks ~1 = ()
668 :     | doblocks blknum = let
669 :     val bdu = Array.sub(blockDU,blknum)
670 :     fun iter [] = ()
671 :     | iter((def',use')::rest) = let
672 :     val def = uniqMap(nodeNumber o chase, def')
673 :     val use = uniqMap(nodeNumber o chase, use')
674 :     fun updateDef n = addDef(n, blknum::getDefs n)
675 :     fun updateUse n = addUse(n, blknum::getUses n)
676 :     in
677 :     app updateDef (SL.intersect(def,spillable));
678 :     app updateUse (SL.intersect(use,spillable));
679 :     iter rest
680 :     end
681 :     in
682 :     iter(bdu);
683 :     doblocks(blknum-1)
684 :     end
685 :    
686 :     (* If a node is live going out of an block terminated by
687 :     * an escaping branch, it may be necessary to reload the
688 :     * the node just prior to taking the branch. We will therefore
689 :     * record this as a definition of the node.
690 :     *)
691 :     fun doBBlocks n = let
692 :     val F.BBLOCK{blknum,liveIn,liveOut,succ,...} = Array.sub(cblocks,n)
693 :     val rNum = nodeNumber o chaseReg
694 :     val liveout = uniqMap (rNum, rmvDedicated(RaArch.regSet(!liveOut)))
695 :     in
696 :     case !succ
697 :     of [F.EXIT _] =>
698 :     (case SL.intersect(spillable,liveout)
699 :     of [] => doBBlocks(n+1)
700 :     | some =>
701 :     (app (fn n => addDef(n, blknum::getDefs n)) some;
702 :     doBBlocks (n+1))
703 :     (*esac*))
704 :     | _ => doBBlocks(n+1)
705 :     (*esac*)
706 :     end (* doBBlocks *)
707 :     in
708 :     doblocks (numOfBlocks - 1);
709 :     doBBlocks 0 handle _ => ();
710 :     (defInfo,useInfo)
711 :     end (* duCount *)
712 :    
713 :     (* Since the spillWkl is not actively maintained, the set of
714 :     * spillable nodes for which def/use info is needed is a subset
715 :     * of spillWkl.
716 :     *)
717 :     fun remainingNodes() = let
718 :     fun prune [] = []
719 :     | prune((n as NODE{color=ref PSEUDO, ...}) ::ns) =
720 :     n::prune ns
721 :     | prune((n as NODE{color=ref(ALIASED _), ...})::ns) =
722 :     prune(chase n::ns)
723 :     | prune(_::ns) = prune ns
724 :     in
725 :     case !remainInfo
726 :     of SOME info => prune spillWkl
727 :     | NONE => let
728 :     (* first time spilling *)
729 :     val spillable = prune ( spillWkl)
730 :     in
731 :     remainInfo :=
732 :     (case spillable
733 :     of [] => NONE
734 :     | _ => SOME(duCount(uniqMap(nodeNumber, spillable)))
735 :     (*esac*));
736 :     spillable
737 :     end
738 :     end
739 :    
740 :     (** apply the chaitan hueristic to find the spill node **)
741 :     fun chaitanHueristic(spillable) = let
742 :     val infinity = 1000000.0
743 :     val infinityi= 1000000
744 :     val SOME(dinfo,uinfo) = !remainInfo
745 :     val getdInfo = Intmap.map dinfo
746 :     val getuInfo = Intmap.map uinfo
747 :     fun coreDump [] = ()
748 :     | coreDump ((node as NODE{number, degree, adj, ...})::rest) =
749 :     (print(concat
750 :     ["number =", Int.toString number,
751 :     " node =", Int.toString(nodeNumber (chase node)),
752 :     " degree = ", Int.toString (!degree),
753 :     " adj = "]);
754 :     prList(map (nodeNumber o chase) (!adj), "");
755 :     print "\n";
756 :     coreDump rest)
757 :     fun iter([],node,_) =
758 :     if node <> ~1 then getnode node
759 :     else (coreDump spillable; error "chaitanHueristic.iter")
760 :     | iter((node as NODE{number, degree, ...})::rest,cnode,cmin) = let
761 :     (* An exeception will be raised if the node is defined
762 :     * but not used. This is not a suitable node to spill.
763 :     *)
764 :     val cost = ((length(getdInfo number) +
765 :     (length(getuInfo number) handle _ => infinityi)))
766 :     val hueristic = real cost / real (!degree)
767 :     in
768 :     if hueristic < cmin andalso not(SL.member prevSpills number)
769 :     then iter(rest, number, hueristic)
770 :     else iter(rest, cnode, cmin)
771 :     end
772 :     in iter(spillable, ~1, infinity)
773 :     end
774 :     in
775 :     case mode
776 :     of COPY_PROPAGATION =>
777 :     WKL{spillWkl=[], simplifyWkl=[], stack=[], moveWkl=[], freezeWkl=[]}
778 :     | REGISTER_ALLOCATION =>
779 :     (case remainingNodes()
780 :     of [] =>
781 :     WKL{spillWkl=[], simplifyWkl=simplifyWkl,
782 :     stack=stack, moveWkl=moveWkl, freezeWkl=freezeWkl}
783 :     | spillWkl => let
784 :     val spillNode = chaitanHueristic(spillWkl)
785 :     val simpWkl =
786 :     if isMoveRelated spillNode then spillNode::wklFromFrozen(spillNode)
787 :     else [spillNode]
788 :     in
789 :     spillFlag:=true;
790 :     WKL{simplifyWkl=simpWkl,
791 :     spillWkl = spillWkl,
792 :     freezeWkl = freezeWkl,
793 :     stack = stack,
794 :     moveWkl = moveWkl}
795 :     end
796 :     (*esac*))
797 :    
798 :     end (* selectSpillNode *)
799 :    
800 :    
801 :     (*---------rerun algorithm-------------*)
802 :    
803 :     (** rerun(spillList) - an unsuccessful round of coloring as taken
804 :     ** place with nodes in spillList having been spilled. The
805 :     ** flowgraph must be updated and the entire process repeated.
806 :     **)
807 :     fun rerun spillList = let
808 :     val SOME(dInfo,uInfo) = !remainInfo
809 :    
810 :     fun coalesceSpillLoc () = let
811 :     fun grow([], set, remain) = (set, remain)
812 :     | grow(x::xs, set, remain) = let
813 :     fun test(s::rest) = memBitMatrix(x, s) orelse test rest
814 :     | test [] = false
815 :     in
816 :     if test set then grow(xs, set, x::remain)
817 :     else grow(xs, x::set, remain)
818 :     end
819 :     fun loop([]) = []
820 :     | loop(x::xs) = let
821 :     val (set, remain) = grow(xs, [x], [])
822 :     in set::loop remain
823 :     end
824 :     in loop(spillList)
825 :     end
826 :    
827 :     (*
828 :     val _ =
829 :     app (fn set => prList(map nodeNumber set,
830 :     "coalesced " ^ Int.toString(length set) ^ ": "))
831 :     (coalesceSpillLoc())
832 :     *)
833 :    
834 :     (* blocks where spill code is required for node n *)
835 :     fun affectedBlocks node = let
836 :     val n = nodeNumber node
837 :     in SL.merge(SL.uniq(Intmap.map dInfo n),
838 :     SL.uniq(Intmap.map uInfo n) handle _ => [])
839 :     end
840 :    
841 :     fun allBlocksAffected () = let
842 :     fun merge([], L) = L
843 :     | merge(x::xs, L) = merge(xs, SL.enter(x, L))
844 :     in List.foldl merge [] (map affectedBlocks spillList)
845 :     end
846 :    
847 :     (* Insert spill code into the affected blocks *)
848 :     fun doBlocks([], _, prevSpills) = prevSpills
849 :     | doBlocks(blknum::rest, node, pSpills) = let
850 :     fun mapr r = Intmap.map regmap r handle _ => r
851 :     val F.BBLOCK{insns, liveOut, ...} = Array.sub(cblocks, blknum)
852 :     val bdu = Array.sub(blockDU, blknum)
853 :     val liveOut = chaseRegs (rmvDedicated(RaArch.regSet(!liveOut)))
854 :    
855 :     val spillReg = nodeNumber node
856 :    
857 :     (* note: the instruction list start out in reverse order. *)
858 :     fun doInstrs([], [], newI, newBDU, prevSpills) =
859 :     (rev newI, rev newBDU, prevSpills)
860 :     | doInstrs(instr::rest, (du as (d,u))::bDU, newI, newBDU, prevSpills) = let
861 :     val defs=map chase d
862 :     val uses=map chase u
863 :    
864 :     fun mergeProh(proh,pSpills) = SL.merge(SL.uniq proh, pSpills)
865 :    
866 :     fun outputInstrs(instrs, I, bDU) =
867 :     {newI=instrs @ I,
868 :     newBDU=(map defUse instrs) @ bDU}
869 :    
870 :     fun newReloadCopy(rds, rss) = let
871 :     fun f(rd::rds, rs::rss, rds', rss') =
872 :     if rs = spillReg then(([rd], [rs]), (rds@rds', rss@rss'))
873 :     else f(rds, rss, rd::rds', rs::rss')
874 :     | f([], [], _, _) = error "newReloadCopy.f"
875 :     in f(rds, rss, [], [])
876 :     end
877 :    
878 :     (* insert reloading code and continue *)
879 :     fun reloadInstr(instr, du, newI, newBDU, prevSpills) = let
880 :     val {code, proh} = RaUser.reload{regmap=mapr, instr=instr, reg=spillReg}
881 :     val prevSpills = mergeProh(proh, prevSpills)
882 :     val {newI, newBDU} = outputInstrs(code, newI, newBDU)
883 :     in doInstrs(rest, bDU, newI, newBDU, prevSpills)
884 :     end
885 :    
886 :     (* insert reload code for copies. *)
887 :     fun reloadCopy(du, instr, newI, newBDU, prevSpills) =
888 :     if nodeMember(node, #2 du) then
889 :     (case (P.moveDstSrc(instr))
890 :     of ([d], [u]) => reloadInstr(instr, du, newI, newBDU, prevSpills)
891 :     | (defs, uses) => let
892 :     val (mv, cpy) = newReloadCopy(defs, uses)
893 :     val cpyInstr = RaUser.copyInstr(cpy, instr)
894 :     val duCpy = defUse cpyInstr
895 :     val {code, proh} =
896 :     RaUser.reload{regmap=mapr, instr=RaUser.copyInstr(mv, instr), reg=spillReg}
897 :     val prevSpills = mergeProh(proh, prevSpills)
898 :     val {newI, newBDU} = outputInstrs(code, newI, newBDU)
899 :     in
900 :     (* recurse to deal with multiple uses *)
901 :     reloadCopy(duCpy, cpyInstr, newI, newBDU, prevSpills)
902 :     end
903 :     (*esac*))
904 :     else
905 :     doInstrs(rest, bDU, instr::newI, du::newBDU, prevSpills)
906 :    
907 :    
908 :     (* insert reload code *)
909 :     fun reload(du as (d,u), instr, newI, newBDU, prevSpills) =
910 :     if P.moveInstr(instr) then
911 :     reloadCopy(du, instr, newI, newBDU, prevSpills)
912 :     else if nodeMember(node, u) then let
913 :     val {code, proh} = RaUser.reload{regmap=mapr, instr=instr, reg=spillReg}
914 :     val {newI, newBDU} = outputInstrs(code, newI, newBDU)
915 :     val prevSpills = mergeProh(proh, prevSpills)
916 :     in doInstrs(rest, bDU, newI, newBDU, prevSpills)
917 :     end
918 :     else
919 :     doInstrs(rest, bDU, instr::newI, du::newBDU, prevSpills)
920 :    
921 :    
922 :     fun spillInstr(instr, newI, newBDU, prevSpills) = let
923 :     val {code, instr, proh} = RaUser.spill{regmap=mapr, instr=instr, reg=spillReg}
924 :     val prevSpills = mergeProh(proh, prevSpills)
925 :     val {newI, newBDU} = outputInstrs(code, newI, newBDU)
926 :     in
927 :     case instr
928 :     of NONE => doInstrs(rest, bDU, newI, newBDU, prevSpills)
929 :     | SOME instr => reload(defUse instr, instr, newI, newBDU, prevSpills)
930 :     end
931 :    
932 :     fun spillCopy() = let
933 :     (* Note:: There is a guarantee that the node
934 :     * will never be aliased to another register.
935 :     *)
936 :     fun newSpillCopy(rds, rss) = let
937 :     fun f(rd::rds, rs::rss, rds', rss') =
938 :     if rd = spillReg then
939 :     (([rd], [rs]), (rds@rds', rss@rss'))
940 :     else f(rds, rss, rd::rds', rs::rss')
941 :     | f([], [], _, _) = error "newSpillCopy"
942 :     in f(rds, rss, [], [])
943 :     end
944 :    
945 :     fun spillCpyDst() = let
946 :     val (mv, cpy) = newSpillCopy(P.moveDstSrc(instr))
947 :     val (newI, newBDU) =
948 :     (case cpy
949 :     of ([],[]) => (newI, newBDU)
950 :     | _ => let
951 :     val cpyInstr = RaUser.copyInstr(cpy, instr)
952 :     in (cpyInstr::newI, defUse cpyInstr::newBDU)
953 :     end
954 :     (*esac*))
955 :     val instr = RaUser.copyInstr(mv, instr)
956 :     in spillInstr(instr, newI, newBDU, prevSpills)
957 :     end
958 :     in
959 :     case P.moveTmpR instr
960 :     of NONE => spillCpyDst()
961 :     | SOME r =>
962 :     if r=spillReg then spillInstr(instr, newI, newBDU, prevSpills)
963 :     else spillCpyDst()
964 :     (*esac*)
965 :     end (* spillCopy *)
966 :     in
967 :     (* insert spill code *)
968 :     if nodeMember(node, defs) then
969 :     if P.moveInstr instr then spillCopy()
970 :     else spillInstr(instr, newI, newBDU, prevSpills)
971 :     else
972 :     reload((defs,uses), instr, newI, newBDU, prevSpills)
973 :     end
974 :    
975 :     (* special action if the last instruction is an escaping
976 :     * branch and the node is live across the branch.
977 :     * We discover if the node needs to be spilled or reloaded.
978 :     *)
979 :     fun blockEnd(instrs as instr::rest, bDU as du::bdu) = let
980 :     fun escapes [] = false
981 :     | escapes (P.ESCAPES::_) = true
982 :     | escapes (_::targets) = escapes targets
983 :     in
984 :     if nodeMember(node, liveOut) then
985 :     (case P.instrKind instr
986 :     of P.IK_JUMP =>
987 :     if escapes(P.branchTargets instr) then let
988 :     val {code,...} =
989 :     RaUser.reload{regmap=mapr, instr=instr, reg=spillReg}
990 :     val reloadDU = map defUse code
991 :     in (rev code@rest, rev reloadDU@bdu)
992 :     end
993 :     else (instrs, bDU)
994 :     | _ => (instrs, bDU)
995 :     (*esac*))
996 :     else (instrs, bDU)
997 :     end
998 :     | blockEnd([],[]) = ([], [])
999 :    
1000 :     val (newInstrs, newBdu, pSpills) =
1001 :     doInstrs(!insns, bdu, [], [], pSpills)
1002 :     val (newInstrs, newBdu) = blockEnd(newInstrs, newBdu)
1003 :     in
1004 :     insns := newInstrs;
1005 :     Array.update(blockDU, blknum, newBdu);
1006 :     doBlocks(rest, node, pSpills)
1007 :     end (* doBlocks *)
1008 :    
1009 :     (* The optimistic coloring selection may come up with a node
1010 :     * that has already been spilled. Must be careful not to spill
1011 :     * it twice.
1012 :     *)
1013 :     fun glue([], prevSpills) = prevSpills
1014 :     | glue((node as NODE{number, ...})::rest, prevSpills) =
1015 :     if SL.member prevSpills number then glue(rest, prevSpills)
1016 :     else glue(rest, doBlocks(affectedBlocks node, node, prevSpills))
1017 :    
1018 :     (* redoAlgorithm
1019 :     * -- rerun graph coloring but note that spilling may
1020 :     * have introduced new registers.
1021 :     *)
1022 :     fun redoAlgorithm(prevSpills) = let
1023 :     val spills = SL.merge(SL.uniq(map nodeNumber spillList), prevSpills)
1024 :     fun init(_, NODE{color=ref PSEUDO, degree, adj,
1025 :     movecnt, movelist, ...}) =
1026 :     (degree:=0; adj := []; movecnt:=0; movelist:=[])
1027 :     | init _ = ()
1028 :     in
1029 :     Intmap.app init nodes;
1030 :     graphColoring(mode, blocks, cblocks, blockDU, spills, nodes, regmap)
1031 :     end
1032 :     in
1033 :     redoAlgorithm(glue(spillList, prevSpills))
1034 :     end (* rerun *)
1035 :    
1036 :    
1037 :     (*-----------select-------------*)
1038 :     (* spilling has occurred, and we retain coalesces upto to first
1039 :     * potential (chaitin) spill. Any move that was coalesced after
1040 :     * the spillFlag was set, is undone.
1041 :     *)
1042 :     fun undoCoalesced (NODE{number, color, ...}, status) =
1043 :     (status := MOVE;
1044 :     if number < RaArch.firstPseudoR then () else color := PSEUDO)
1045 :    
1046 :     (* assigns colors *)
1047 :     fun assignColors(WKL{stack, ...}) = let
1048 :     (* Briggs's optimistic spilling heuristic *)
1049 :     fun optimistic([], spills) = spills
1050 :     | optimistic((node as NODE{color, adj, ...}) ::ns, spills) = let
1051 :     fun neighbors [] = []
1052 :     | neighbors(r::rs) =
1053 :     (case chase r
1054 :     of NODE{color=ref (COLORED col), number, ...} =>
1055 :     col::neighbors rs
1056 :     | _ => neighbors rs
1057 :     (*esac*))
1058 :     val neighs = neighbors(!adj)
1059 :     fun getcolor () = RaUser.getreg{pref=[], proh=neighbors(!adj)}
1060 :     in
1061 :     let val col = getcolor()
1062 :     in
1063 :     color := COLORED col;
1064 :     optimistic(ns, spills)
1065 :     end
1066 :     handle _ => (optimistic(ns, node::spills))
1067 :     end
1068 :    
1069 :     fun finishRA () = let
1070 :     val enter = Intmap.add regmap
1071 :     in
1072 :     Intmap.app
1073 :     (fn (i, node) =>
1074 :     case chase node
1075 :     of NODE{color=ref(COLORED col), ...} => enter(i,col)
1076 :     | _ => error "finishRA"
1077 :     (*esac*))
1078 :     nodes
1079 :     end
1080 :    
1081 :     fun finishCP() = let
1082 :     val enter = Intmap.add regmap
1083 :     in
1084 :     Intmap.app
1085 :     (fn (i, node as NODE{color as ref (ALIASED _), ...}) =>
1086 :     (case (chase node)
1087 :     of NODE{color=ref(COLORED col), ...} => enter(i, col)
1088 :     | NODE{color=ref PSEUDO, number, ...} => enter(i, number)
1089 :     | NODE{color=ref REMOVED, number, ...} => enter(i,number)
1090 :     | _ => error "finishP"
1091 :     (*esac*))
1092 :     | _ => ())
1093 :     nodes
1094 :     end
1095 :     in
1096 :     case mode
1097 : monnier 106 of COPY_PROPAGATION => finishCP()
1098 :     | REGISTER_ALLOCATION =>
1099 :     (case optimistic(stack, [])
1100 :     of [] => finishRA()
1101 :     | spills =>
1102 :     (app (fn NODE{color, ...} => color := PSEUDO) stack;
1103 :     app undoCoalesced (!undoInfo);
1104 :     rerun spills)
1105 :     (*esac*))
1106 : monnier 16 end (* assignColors *)
1107 :    
1108 :    
1109 :     (*---------main------------*)
1110 :     (* iterate (WKL{count,simplifyWkl,freezeWkl,spillWkl,moveWkl,stack})
1111 :     * Note: freezeWkl or spillWkl are maintained lazily.
1112 :     *)
1113 :     fun iterate(wkls as WKL{simplifyWkl= _::_, ...}) = iterate(simplify wkls)
1114 :     | iterate(wkls as WKL{moveWkl= _::_, ...}) = iterate(coalesce wkls)
1115 :     | iterate(wkls as WKL{freezeWkl= _::_, ...}) = iterate(freeze wkls)
1116 :     | iterate(wkls as WKL{spillWkl= _::_, ...}) = iterate(selectSpillNode wkls)
1117 :     | iterate wkls = assignColors wkls
1118 :     in
1119 :     iterate (WKL initialWkls)
1120 :     end (* graphColoring *)
1121 :    
1122 :     fun ra mode (cluster as (F.CLUSTER{blocks, regmap, ...})) =
1123 :     if RaArch.numRegs() = 0 then cluster
1124 :     else let
1125 :     exception Nodes
1126 :     val nodes : node Intmap.intmap = Intmap.new(32, Nodes)
1127 :     fun mkNode i =
1128 :     newNode(i, if i < RaArch.firstPseudoR then COLORED(i) else PSEUDO)
1129 :    
1130 :     val nCBlks =
1131 :     List.foldl
1132 :     (fn (F.BBLOCK _, acc) => acc+1 | (_, acc) => acc) 0 blocks
1133 :     val blockDU = Array.array(nCBlks, ([]: (node list * node list) list))
1134 :     val cblocks = Array.array(nCBlks, F.LABEL(Label.newLabel""))
1135 :    
1136 :     fun getnode n =
1137 :     Intmap.map nodes n
1138 :     handle Nodes =>
1139 :     let val node = mkNode n
1140 :     in Intmap.add nodes (n, node);
1141 :     node
1142 :     end
1143 :    
1144 :     fun blockDefUse((blk as F.BBLOCK{insns,liveOut,succ, ...})::blks, n) = let
1145 :     fun insnDefUse insn = let
1146 :     val (d,u) = RaArch.defUse insn
1147 :     fun rmv [] = []
1148 :     | rmv (l as [x]) =
1149 :     if isDedicated x then [] else [getnode x]
1150 :     | rmv set = map getnode (rmvDedicated set)
1151 :     in (rmv d, rmv u)
1152 :     end
1153 :     in
1154 :     Unsafe.Array.update(cblocks, n, blk);
1155 :     Unsafe.Array.update(blockDU, n, map insnDefUse (!insns));
1156 :     case !succ
1157 :     of [F.EXIT _] =>
1158 :     app (fn i => (getnode i; ()))
1159 :     (rmvDedicated(RaArch.regSet(!liveOut)))
1160 :     | _ => ();
1161 :     blockDefUse(blks, n+1)
1162 :     end
1163 :     | blockDefUse(_::blks, n) = blockDefUse(blks, n)
1164 :     | blockDefUse([], _) = ()
1165 :    
1166 :     (* if copy propagation was done prior to register allocation
1167 :     * then some nodes may already be aliased.
1168 :     *)
1169 :     fun updtAliases() = let
1170 :     val alias = Intmap.map regmap
1171 :     fun fixup(num, NODE{color, ...}) =
1172 :     if num < RaArch.firstPseudoR then ()
1173 :     else let
1174 :     val reg = alias num
1175 :     in if reg=num then () else color := ALIASED(getnode reg)
1176 :     end handle _ => ()
1177 :     in Intmap.app fixup nodes
1178 :     end
1179 :     in
1180 :     blockDefUse(blocks, 0);
1181 :     updtAliases();
1182 :     graphColoring(mode, blocks, cblocks, blockDU, [], nodes, regmap);
1183 :     debug("after register allocation", blocks, regmap);
1184 :     cluster
1185 :     end
1186 :     end (* functor *)
1187 :    
1188 :     (*
1189 : monnier 113 * $Log$
1190 : monnier 16 *)
1191 :    

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