X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=a2b98f1f6a31e32bc71dfac6ed57013f81a930de;hb=86f1f4e0748ba1146cf74786af38a68a88164e2f;hp=8449b5e6d3f2f4c6606054c57df414818fcdabb5;hpb=1dd44153dac634be2e6af2b68eff2ceb74a8c64c;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs index 8449b5e..a2b98f1 100644 --- a/compiler/nativeGen/RegAllocColor.hs +++ b/compiler/nativeGen/RegAllocColor.hs @@ -1,15 +1,7 @@ -- | 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. -- {-# OPTIONS -fno-warn-missing-signatures #-} @@ -35,7 +27,7 @@ import UniqSet import UniqFM import Bag import Outputable -import Util +import DynFlags import Data.List import Data.Maybe @@ -52,7 +44,7 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. -- regAlloc - :: Bool -- ^ whether to generate RegAllocStats, or not. + :: 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. @@ -60,16 +52,25 @@ regAlloc ( [NatCmmTop] -- ^ code with registers allocated. , [RegAllocStats] ) -- ^ stats for each stage of allocation -regAlloc dump regsFree slotsFree code +regAlloc dflags regsFree slotsFree code = do (code_final, debug_codeGraphs, _) - <- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code + <- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code return ( code_final , reverse debug_codeGraphs ) -regAlloc_spin dump (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." @@ -82,6 +83,14 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c -- build a conflict graph from the 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 is lazy, it won't be computed unless we need to spill @@ -103,11 +112,14 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c -- try and color the graph let (graph_colored, rsSpill, rmCoalesce) - = {-# SCC "ColorGraph" #-} Color.colorGraph regsFree triv spill graph + = {-# SCC "ColorGraph" #-} + Color.colorGraph + (dopt Opt_RegsIterative dflags) + regsFree triv spill graph -- rewrite regs in the code that have been coalesced let patchF reg = case lookupUFM rmCoalesce reg of - Just reg' -> reg' + Just reg' -> patchF reg' Nothing -> reg let code_coalesced = map (patchEraseLive patchF) code @@ -123,7 +135,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c let code_spillclean = map cleanSpills code_patched -- strip off liveness information - let code_nat = map stripLive code_patched + let code_nat = map stripLive code_spillclean -- rewrite SPILL/RELOAD pseudos into real instructions let spillNatTop = mapGenBlockTop spillNatBlock @@ -137,7 +149,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c , raPatched = code_patched , raSpillClean = code_spillclean , raFinal = code_final - , raSRMs = foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean } + , raSRMs = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean } let statList = @@ -145,7 +157,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c else [] -- space leak avoidance - seqList statList $! return () + seqList statList `seq` return () return ( code_final , statList @@ -175,9 +187,9 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c else [] -- space leak avoidance - seqList statList $! return () + seqList statList `seq` return () - regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree' + regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' statList code_relive @@ -234,16 +246,18 @@ buildGraph code let (conflictList, moveList) = unzip $ map slurpConflicts code - let conflictBag = unionManyBags conflictList - let moveBag = unionManyBags moveList + -- 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 moveBag = unionBags (unionManyBags moveList2) (unionManyBags moveList) let graph_coalesce = foldrBag graphAddCoalesce graph_conflict moveBag - return graph_coalesce + return $ Color.validateGraph (text "urk") graph_coalesce -- | Add some conflict edges to the graph. @@ -314,12 +328,69 @@ patchRegsFromGraph graph code ( text "There is no node in the graph for register " <> ppr reg $$ ppr code $$ Color.dotGraph (\_ -> text "white") trivColorable graph) - + in patchEraseLive patchF code plusUFMs_C :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt plusUFMs_C f maps - = foldl (plusUFM_C f) emptyUFM 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 +