1 -- | Graph coloring register allocator.
4 -- The function that choosing the potential spills could be a bit cleverer.
5 -- Colors in graphviz graphs could be nicer.
7 {-# OPTIONS -fno-warn-missing-signatures #-}
16 import qualified GraphColor as Color
36 -- | The maximum number of build/spill cycles we'll allow.
37 -- We should only need 3 or 4 cycles tops.
38 -- If we run for any longer than this we're probably in an infinite loop,
39 -- It's probably better just to bail out and report a bug at this stage.
44 -- | The top level of the graph coloring register allocator.
48 -> UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation
49 -> UniqSet Int -- ^ the set of available spill slots.
50 -> [LiveCmmTop] -- ^ code annotated with liveness information.
52 ( [NatCmmTop] -- ^ code with registers allocated.
53 , [RegAllocStats] ) -- ^ stats for each stage of allocation
55 regAlloc dflags regsFree slotsFree code
57 (code_final, debug_codeGraphs, _)
58 <- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code
61 , reverse debug_codeGraphs )
63 regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
65 -- if any of these dump flags are turned on we want to hang on to
66 -- intermediate structures in the allocator - otherwise tell the
67 -- allocator to ditch them early so we don't end up creating space leaks.
69 [ dopt Opt_D_dump_asm_regalloc_stages dflags
70 , dopt Opt_D_dump_asm_stats dflags
71 , dopt Opt_D_dump_asm_conflicts dflags ]
74 -- check that we're not running off down the garden path.
75 when (spinCount > maxSpinCount)
76 $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
77 ( text "It looks like the register allocator is stuck in an infinite loop."
78 $$ text "max cycles = " <> int maxSpinCount
79 $$ text "regsFree = " <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg)
80 $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
81 $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree))
83 -- build a conflict graph from the code.
84 graph <- {-# SCC "BuildGraph" #-} buildGraph code
87 -- We really do want the graph to be fully evaluated _before_ we start coloring.
88 -- If we don't do this now then when the call to Color.colorGraph forces bits of it,
89 -- the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
91 seqGraph graph `seq` return ()
94 -- build a map of how many instructions each reg lives for.
95 -- this is lazy, it won't be computed unless we need to spill
97 let fmLife = {-# SCC "LifetimeCount" #-} plusUFMs_C (\(r1, l1) (_, l2) -> (r1, l1 + l2))
98 $ map lifetimeCount code
100 -- record startup state
103 then Just $ RegAllocStatsStart
106 , raLifetimes = fmLife }
110 -- the function to choose regs to leave uncolored
111 let spill = chooseSpill_maxLife fmLife
113 -- try and color the graph
114 let (graph_colored, rsSpill, rmCoalesce)
115 = {-# SCC "ColorGraph" #-}
117 (dopt Opt_RegsIterative dflags)
118 regsFree triv spill graph
120 -- rewrite regs in the code that have been coalesced
121 let patchF reg = case lookupUFM rmCoalesce reg of
122 Just reg' -> patchF reg'
125 = map (patchEraseLive patchF) code
128 -- see if we've found a coloring
129 if isEmptyUniqSet rsSpill
131 -- patch the registers using the info in the graph
132 let code_patched = map (patchRegsFromGraph graph_colored) code_coalesced
134 -- clean out unneeded SPILL/RELOADs
135 let code_spillclean = map cleanSpills code_patched
137 -- strip off liveness information
138 let code_nat = map stripLive code_spillclean
140 -- rewrite SPILL/RELOAD pseudos into real instructions
141 let spillNatTop = mapGenBlockTop spillNatBlock
142 let code_final = map spillNatTop code_nat
144 -- record what happened in this stage for debugging
147 { raGraph = graph_colored
148 , raCoalesced = rmCoalesce
149 , raPatched = code_patched
150 , raSpillClean = code_spillclean
151 , raFinal = code_final
152 , raSRMs = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
156 if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
159 -- space leak avoidance
160 seqList statList `seq` return ()
167 -- spill the uncolored regs
168 (code_spilled, slotsFree', spillStats)
169 <- regSpill code_coalesced slotsFree rsSpill
171 -- recalculate liveness
172 let code_nat = map stripLive code_spilled
173 code_relive <- mapM regLiveness code_nat
175 -- record what happened in this stage for debugging
178 { raGraph = graph_colored
179 , raCoalesced = rmCoalesce
180 , raSpillStats = spillStats
181 , raLifetimes = fmLife
182 , raSpilled = code_spilled }
186 then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
189 -- space leak avoidance
190 seqList statList `seq` return ()
192 regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
198 -- Simple maxconflicts isn't always good, because we
199 -- can naievely end up spilling vregs that only live for one or two instrs.
202 chooseSpill_maxConflicts
203 :: Color.Graph Reg RegClass Reg
206 chooseSpill_maxConflicts graph
207 = let node = maximumBy
209 (sizeUniqSet $ Color.nodeConflicts n1)
210 (sizeUniqSet $ Color.nodeConflicts n2))
211 $ eltsUFM $ Color.graphMap graph
219 -> Color.Graph Reg RegClass Reg
222 chooseSpill_maxLife life graph
223 = let node = maximumBy (\n1 n2 -> compare (getLife n1) (getLife n2))
224 $ eltsUFM $ Color.graphMap graph
226 -- Orphan vregs die in the same instruction they are born in.
227 -- They will be in the graph, but not in the liveness map.
228 -- Their liveness is 0.
230 = case lookupUFM life (Color.nodeId n) of
237 -- | Build a graph from the liveness and coalesce information in this code.
241 -> UniqSM (Color.Graph Reg RegClass Reg)
245 -- Slurp out the conflicts and reg->reg moves from this code
246 let (conflictList, moveList) =
247 unzip $ map slurpConflicts code
249 -- Slurp out the spill/reload coalesces
250 let moveList2 = map slurpReloadCoalesce code
252 -- Add the reg-reg conflicts to the graph
253 let conflictBag = unionManyBags conflictList
254 let graph_conflict = foldrBag graphAddConflictSet Color.initGraph conflictBag
256 -- Add the coalescences edges to the graph.
257 let moveBag = unionBags (unionManyBags moveList2) (unionManyBags moveList)
258 let graph_coalesce = foldrBag graphAddCoalesce graph_conflict moveBag
260 return $ Color.validateGraph (text "urk") graph_coalesce
263 -- | Add some conflict edges to the graph.
264 -- Conflicts between virtual and real regs are recorded as exclusions.
268 -> Color.Graph Reg RegClass Reg
269 -> Color.Graph Reg RegClass Reg
271 graphAddConflictSet set graph
272 = let reals = filterUFM isRealReg set
273 virtuals = filterUFM (not . isRealReg) set
275 graph1 = Color.addConflicts virtuals regClass graph
276 graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
279 | a <- uniqSetToList virtuals
280 , b <- uniqSetToList reals]
285 -- | Add some coalesence edges to the graph
286 -- Coalesences between virtual and real regs are recorded as preferences.
290 -> Color.Graph Reg RegClass Reg
291 -> Color.Graph Reg RegClass Reg
293 graphAddCoalesce (r1, r2) graph
295 = Color.addPreference (regWithClass r2) r1 graph
298 = Color.addPreference (regWithClass r1) r2 graph
301 = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
303 where regWithClass r = (r, regClass r)
306 -- | Patch registers in code using the reg -> reg mapping in this graph.
308 :: Color.Graph Reg RegClass Reg
309 -> LiveCmmTop -> LiveCmmTop
311 patchRegsFromGraph graph code
313 -- a function to lookup the hardreg for a virtual reg from the graph.
315 -- leave real regs alone.
319 -- this virtual has a regular node in the graph.
320 | Just node <- Color.lookupNode graph reg
321 = case Color.nodeColor node of
325 -- no node in the graph for this virtual, bad news.
327 = pprPanic "patchRegsFromGraph: register mapping failed."
328 ( text "There is no node in the graph for register " <> ppr reg
330 $$ Color.dotGraph (\_ -> text "white") trivColorable graph)
332 in patchEraseLive patchF code
335 plusUFMs_C :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
337 = foldl' (plusUFM_C f) emptyUFM maps
341 -- for when laziness just isn't what you wanted...
343 seqGraph :: Color.Graph Reg RegClass Reg -> ()
344 seqGraph graph = seqNodes (eltsUFM (Color.graphMap graph))
346 seqNodes :: [Color.Node Reg RegClass Reg] -> ()
350 (n : ns) -> seqNode n `seq` seqNodes ns
352 seqNode :: Color.Node Reg RegClass Reg -> ()
354 = seqReg (Color.nodeId node)
355 `seq` seqRegClass (Color.nodeClass node)
356 `seq` seqMaybeReg (Color.nodeColor node)
357 `seq` (seqRegList (uniqSetToList (Color.nodeConflicts node)))
358 `seq` (seqRegList (uniqSetToList (Color.nodeExclusions node)))
359 `seq` (seqRegList (Color.nodePreference node))
360 `seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node)))
371 seqRegClass :: RegClass -> ()
378 seqMaybeReg :: Maybe Reg -> ()
384 seqRegList :: [Reg] -> ()
388 (r : rs) -> seqReg r `seq` seqRegList rs
394 (r : rs) -> r `seq` seqList rs