X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=45e51b927fd44eb2665c0097b33140da44d5916a;hb=8672676c20d5c9a268a8f07dc7aa706df4ca315f;hp=b9eda1b3bace05c7f91d9e0301b6e7318df8b5f8;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs index b9eda1b..45e51b9 100644 --- a/compiler/nativeGen/RegAllocColor.hs +++ b/compiler/nativeGen/RegAllocColor.hs @@ -1,24 +1,10 @@ -- | 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 -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details +{-# OPTIONS -fno-warn-missing-signatures #-} module RegAllocColor ( regAlloc, @@ -67,7 +53,7 @@ regAlloc regAlloc dump regsFree slotsFree code = do - (code_final, debug_codeGraphs, graph_final) + (code_final, debug_codeGraphs, _) <- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code return ( code_final @@ -85,11 +71,20 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c $$ 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 is lazy, it won't be computed unless we need to spill - let fmLife = plusUFMs_C (\(r1, l1) (r2, l2) -> (r1, l1 + l2)) + + let fmLife = {-# SCC "LifetimeCount" #-} plusUFMs_C (\(r1, l1) (_, l2) -> (r1, l1 + l2)) $ map lifetimeCount code -- record startup state @@ -107,7 +102,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c -- try and color the graph let (graph_colored, rsSpill, rmCoalesce) - = Color.colorGraph regsFree triv spill graph + = {-# SCC "ColorGraph" #-} Color.colorGraph regsFree triv spill graph -- rewrite regs in the code that have been coalesced let patchF reg = case lookupUFM rmCoalesce reg of @@ -129,7 +124,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c -- strip off liveness information let code_nat = map stripLive code_patched - -- rewrite SPILL/REALOAD pseudos into real instructions + -- rewrite SPILL/RELOAD pseudos into real instructions let spillNatTop = mapGenBlockTop spillNatBlock let code_final = map spillNatTop code_nat @@ -141,19 +136,25 @@ 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 } - return ( code_final - , if dump - then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + + let statList = + if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs else [] + + -- space leak avoidance + seqList statList `seq` return () + + return ( code_final + , statList , graph_colored) else do -- spill the uncolored regs (code_spilled, slotsFree', spillStats) <- regSpill code_coalesced slotsFree rsSpill - + -- recalculate liveness let code_nat = map stripLive code_spilled code_relive <- mapM regLiveness code_nat @@ -167,11 +168,16 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c , raLifetimes = fmLife , raSpilled = code_spilled } - -- try again - regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree' - (if dump + let statList = + if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else []) + else [] + + -- space leak avoidance + seqList statList `seq` return () + + regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree' + statList code_relive @@ -270,10 +276,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 @@ -306,12 +312,70 @@ 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 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 + +