X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=21d7ed1d758d81db8cd728ca2f3e4943e0be5958;hb=fff4dee0483eda0b675057f8259a161ff16467f4;hp=6a71412bcfa152c34ac5bdbcc308825ec1c4a9f6;hpb=0f7d268d00795a58a06ae3c92ebbd14571295b84;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs index 6a71412..21d7ed1 100644 --- a/compiler/nativeGen/RegAllocColor.hs +++ b/compiler/nativeGen/RegAllocColor.hs @@ -1,17 +1,8 @@ -- | Graph coloring register allocator. -- --- TODO: --- Live range splitting: --- At the moment regs that are spilled are spilled for all time, even though --- we might be able to allocate them a hardreg in different parts of the code. --- --- As we're aggressively coalescing before register allocation proper we're not currently --- using the coalescence information present in the graph. --- --- The function that choosing the potential spills could be a bit cleverer. --- --- Colors in graphviz graphs could be nicer. +-- TODO: The colors in graphviz graphs for x86_64 and ppc could be nicer. -- +{-# OPTIONS -fno-warn-missing-signatures #-} module RegAllocColor ( regAlloc, @@ -20,14 +11,15 @@ module RegAllocColor ( where -#include "nativeGen/NCG.h" - import qualified GraphColor as Color import RegLiveness import RegSpill +import RegSpillClean +import RegSpillCost +import RegAllocStats +-- import RegCoalesce import MachRegs import MachInstrs -import RegCoalesce import PprMach import UniqSupply @@ -35,6 +27,7 @@ import UniqSet import UniqFM import Bag import Outputable +import DynFlags import Data.List import Data.Maybe @@ -51,24 +44,32 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. -- regAlloc - :: UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation - -> UniqSet Int -- ^ the set of available spill slots. - -> [LiveCmmTop] -- ^ code annotated with liveness information. + :: DynFlags + -> UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation + -> UniqSet Int -- ^ the set of available spill slots. + -> [LiveCmmTop] -- ^ code annotated with liveness information. -> UniqSM - ( [NatCmmTop] -- ^ code with registers allocated. - , [ ( [LiveCmmTop] - , Color.Graph Reg RegClass Reg) ]) -- ^ code and graph for each pass + ( [NatCmmTop] -- ^ code with registers allocated. + , [RegAllocStats] ) -- ^ stats for each stage of allocation -regAlloc regsFree slotsFree code +regAlloc dflags regsFree slotsFree code = do - (code_final, debug_codeGraphs, graph_final) - <- regAlloc_spin 0 trivColorable regsFree slotsFree [] code + (code_final, debug_codeGraphs, _) + <- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code return ( code_final - , debug_codeGraphs ) + , reverse debug_codeGraphs ) -regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code +regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code = do + -- if any of these dump flags are turned on we want to hang on to + -- intermediate structures in the allocator - otherwise tell the + -- allocator to ditch them early so we don't end up creating space leaks. + let dump = or + [ dopt Opt_D_dump_asm_regalloc_stages dflags + , dopt Opt_D_dump_asm_stats dflags + , dopt Opt_D_dump_asm_conflicts dflags ] + -- check that we're not running off down the garden path. when (spinCount > maxSpinCount) $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded." @@ -79,85 +80,136 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) -- build a conflict graph from the code. - graph <- buildGraph code + graph <- {-# SCC "BuildGraph" #-} buildGraph code + + -- VERY IMPORTANT: + -- We really do want the graph to be fully evaluated _before_ we start coloring. + -- If we don't do this now then when the call to Color.colorGraph forces bits of it, + -- the heap will be filled with half evaluated pieces of graph and zillions of apply thunks. + -- + seqGraph graph `seq` return () - -- build a map of how many instructions each reg lives for - -- this lazy, it won't be computed unless we need to spill - let fmLife = plusUFMs_C (\(r1, l1) (r2, l2) -> (r1, l1 + l2)) - $ map lifetimeCount code + + -- build a map of the cost of spilling each instruction + -- this will only actually be computed if we have to spill something. + let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo + $ map slurpSpillCostInfo code -- the function to choose regs to leave uncolored - let spill = chooseSpill_maxLife fmLife + let spill = chooseSpill spillCosts + + -- record startup state + let stat1 = + if spinCount == 0 + then Just $ RegAllocStatsStart + { raLiveCmm = code + , raGraph = graph + , raSpillCosts = spillCosts } + else Nothing -- try and color the graph - let (graph_colored, rsSpill) - = Color.colorGraph regsFree triv spill graph + let (graph_colored, rsSpill, rmCoalesce) + = {-# SCC "ColorGraph" #-} + Color.colorGraph + (dopt Opt_RegsIterative dflags) + spinCount + regsFree triv spill graph + + -- rewrite regs in the code that have been coalesced + let patchF reg = case lookupUFM rmCoalesce reg of + Just reg' -> patchF reg' + Nothing -> reg + let code_coalesced + = map (patchEraseLive patchF) code + -- see if we've found a coloring if isEmptyUniqSet rsSpill then do + -- if -fasm-lint is turned on then validate the graph + let graph_colored_lint = + if dopt Opt_DoAsmLinting dflags + then Color.validateGraph (text "") + True -- require all nodes to be colored + graph_colored + else graph_colored + -- patch the registers using the info in the graph - let code_patched = map (patchRegsFromGraph graph_colored) code - let code_nat = map stripLive code_patched - - return ( code_nat - , debug_codeGraphs ++ [(code, graph_colored), (code_patched, graph_colored)] - , graph_colored) + let code_patched = map (patchRegsFromGraph graph_colored_lint) code_coalesced + -- clean out unneeded SPILL/RELOADs + let code_spillclean = map cleanSpills code_patched + + -- strip off liveness information + let code_nat = map stripLive code_spillclean + + -- rewrite SPILL/RELOAD pseudos into real instructions + let spillNatTop = mapGenBlockTop spillNatBlock + let code_final = map spillNatTop code_nat + + -- record what happened in this stage for debugging + let stat = + RegAllocStatsColored + { raGraph = graph + , raGraphColored = graph_colored_lint + , raCoalesced = rmCoalesce + , raPatched = code_patched + , raSpillClean = code_spillclean + , raFinal = code_final + , raSRMs = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean } + + + let statList = + if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] + + -- space leak avoidance + seqList statList `seq` return () + + return ( code_final + , statList + , graph_colored_lint) + + -- we couldn't find a coloring, time to spill something else do + -- if -fasm-lint is turned on then validate the graph + let graph_colored_lint = + if dopt Opt_DoAsmLinting dflags + then Color.validateGraph (text "") + False -- don't require nodes to be colored + graph_colored + else graph_colored + -- spill the uncolored regs - (code_spilled, slotsFree') - <- regSpill code slotsFree rsSpill - + (code_spilled, slotsFree', spillStats) + <- regSpill code_coalesced slotsFree rsSpill + -- recalculate liveness let code_nat = map stripLive code_spilled code_relive <- mapM regLiveness code_nat + + -- record what happened in this stage for debugging + let stat = + RegAllocStatsSpill + { raGraph = graph_colored_lint + , raCoalesced = rmCoalesce + , raSpillStats = spillStats + , raSpillCosts = spillCosts + , raSpilled = code_spilled } - -- try again - regAlloc_spin (spinCount + 1) triv regsFree slotsFree' - (debug_codeGraphs ++ [(code, graph_colored)]) - code_relive + let statList = + if dump + then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] - ------ --- Simple maxconflicts isn't always good, because we --- can naievely end up spilling vregs that only live for one or two instrs. --- -{- -chooseSpill_maxConflicts - :: Color.Graph Reg RegClass Reg - -> Reg - -chooseSpill_maxConflicts graph - = let node = maximumBy - (\n1 n2 -> compare - (sizeUniqSet $ Color.nodeConflicts n1) - (sizeUniqSet $ Color.nodeConflicts n2)) - $ eltsUFM $ Color.graphMap graph - - in Color.nodeId node --} - ------ -chooseSpill_maxLife - :: UniqFM (Reg, Int) - -> Color.Graph Reg RegClass Reg - -> Reg + -- space leak avoidance + seqList statList `seq` return () -chooseSpill_maxLife life graph - = let node = maximumBy (\n1 n2 -> compare (getLife n1) (getLife n2)) - $ eltsUFM $ Color.graphMap graph + regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' + statList + code_relive - -- Orphan vregs die in the same instruction they are born in. - -- They will be in the graph, but not in the liveness map. - -- Their liveness is 0. - getLife n - = case lookupUFM life (Color.nodeId n) of - Just (_, l) -> l - Nothing -> 0 - in Color.nodeId node - -- | Build a graph from the liveness and coalesce information in this code. @@ -167,20 +219,26 @@ buildGraph buildGraph code = do - -- Add the reg-reg conflicts to the graph - let conflictSets = unionManyBags (map slurpConflicts code) - let graph_conflict = foldrBag graphAddConflictSet Color.initGraph conflictSets + -- Slurp out the conflicts and reg->reg moves from this code + let (conflictList, moveList) = + unzip $ map slurpConflicts code + -- Slurp out the spill/reload coalesces + let moveList2 = map slurpReloadCoalesce code + + -- Add the reg-reg conflicts to the graph + let conflictBag = unionManyBags conflictList + let graph_conflict = foldrBag graphAddConflictSet Color.initGraph conflictBag -- Add the coalescences edges to the graph. - let coalesce = unionManyBags (map slurpJoinMovs code) - let graph_coalesce = foldrBag graphAddCoalesce graph_conflict coalesce + let moveBag = unionBags (unionManyBags moveList2) (unionManyBags moveList) + let graph_coalesce = foldrBag graphAddCoalesce graph_conflict moveBag - return $ graph_coalesce + return graph_coalesce -- | Add some conflict edges to the graph. --- Conflicts between virtual and real regs are recorded as exlusions. +-- Conflicts between virtual and real regs are recorded as exclusions. -- graphAddConflictSet :: UniqSet Reg @@ -201,7 +259,7 @@ graphAddConflictSet set graph in graph2 --- | Add some coalesences edges to the graph +-- | Add some coalesence edges to the graph -- Coalesences between virtual and real regs are recorded as preferences. -- graphAddCoalesce @@ -210,10 +268,10 @@ graphAddCoalesce -> Color.Graph Reg RegClass Reg graphAddCoalesce (r1, r2) graph - | RealReg regno <- r1 + | RealReg _ <- r1 = Color.addPreference (regWithClass r2) r1 graph - | RealReg regno <- r2 + | RealReg _ <- r2 = Color.addPreference (regWithClass r1) r2 graph | otherwise @@ -246,87 +304,65 @@ patchRegsFromGraph graph code = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg $$ ppr code - $$ Color.dotGraph (\x -> text "white") trivColorable graph) - + $$ Color.dotGraph (\_ -> text "white") trivColorable graph) + in patchEraseLive patchF code ----- --- Register colors for drawing conflict graphs --- Keep this out of MachRegs.hs because it's specific to the graph coloring allocator. - - --- reg colors for x86 -#if i386_TARGET_ARCH -regDotColor :: Reg -> SDoc -regDotColor reg - = let Just str = lookupUFM regColors reg - in text str - -regColors - = listToUFM - $ [ (eax, "#00ff00") - , (ebx, "#0000ff") - , (ecx, "#00ffff") - , (edx, "#0080ff") - - , (fake0, "#ff00ff") - , (fake1, "#ff00aa") - , (fake2, "#aa00ff") - , (fake3, "#aa00aa") - , (fake4, "#ff0055") - , (fake5, "#5500ff") ] -#endif - - --- reg colors for x86_64 -#if x86_64_TARGET_ARCH -regDotColor :: Reg -> SDoc -regDotColor reg - = let Just str = lookupUFM regColors reg - in text str - -regColors - = listToUFM - $ [ (rax, "#00ff00"), (eax, "#00ff00") - , (rbx, "#0000ff"), (ebx, "#0000ff") - , (rcx, "#00ffff"), (ecx, "#00ffff") - , (rdx, "#0080ff"), (edx, "#00ffff") - , (r8, "#00ff80") - , (r9, "#008080") - , (r10, "#0040ff") - , (r11, "#00ff40") - , (r12, "#008040") - , (r13, "#004080") - , (r14, "#004040") - , (r15, "#002080") ] - - ++ zip (map RealReg [16..31]) (repeat "red") -#endif - - --- reg colors for ppc -#if powerpc_TARGET_ARCH -regDotColor :: Reg -> SDoc -regDotColor reg - = case regClass reg of - RcInteger -> text "blue" - RcFloat -> text "red" -#endif - - -{- -toX11Color (r, g, b) - = let rs = padL 2 '0' (showHex r "") - gs = padL 2 '0' (showHex r "") - bs = padL 2 '0' (showHex r "") - - padL n c s - = replicate (n - length s) c ++ s - in "#" ++ rs ++ gs ++ bs --} - -plusUFMs_C :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt -plusUFMs_C f maps - = foldl (plusUFM_C f) emptyUFM maps - +-- for when laziness just isn't what you wanted... +-- +seqGraph :: Color.Graph Reg RegClass Reg -> () +seqGraph graph = seqNodes (eltsUFM (Color.graphMap graph)) + +seqNodes :: [Color.Node Reg RegClass Reg] -> () +seqNodes ns + = case ns of + [] -> () + (n : ns) -> seqNode n `seq` seqNodes ns + +seqNode :: Color.Node Reg RegClass Reg -> () +seqNode node + = seqReg (Color.nodeId node) + `seq` seqRegClass (Color.nodeClass node) + `seq` seqMaybeReg (Color.nodeColor node) + `seq` (seqRegList (uniqSetToList (Color.nodeConflicts node))) + `seq` (seqRegList (uniqSetToList (Color.nodeExclusions node))) + `seq` (seqRegList (Color.nodePreference node)) + `seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node))) + +seqReg :: Reg -> () +seqReg reg + = case reg of + RealReg _ -> () + VirtualRegI _ -> () + VirtualRegHi _ -> () + VirtualRegF _ -> () + VirtualRegD _ -> () + +seqRegClass :: RegClass -> () +seqRegClass c + = case c of + RcInteger -> () + RcFloat -> () + RcDouble -> () + +seqMaybeReg :: Maybe Reg -> () +seqMaybeReg mr + = case mr of + Nothing -> () + Just r -> seqReg r + +seqRegList :: [Reg] -> () +seqRegList rs + = case rs of + [] -> () + (r : rs) -> seqReg r `seq` seqRegList rs + +seqList :: [a] -> () +seqList ls + = case ls of + [] -> () + (r : rs) -> r `seq` seqList rs + +