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

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