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/branches/SMLNJ/src/MLRISC/mlrisc/ra.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/MLRISC/mlrisc/ra.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 139 - (view) (download)

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

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