X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=27b603c2faadae70d6182b5b84041a14c7d8f630;hp=6a71412bcfa152c34ac5bdbcc308825ec1c4a9f6;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=0f7d268d00795a58a06ae3c92ebbd14571295b84 diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs index 6a71412..27b603c 100644 --- a/compiler/nativeGen/RegAllocColor.hs +++ b/compiler/nativeGen/RegAllocColor.hs @@ -13,6 +13,13 @@ -- Colors in graphviz graphs could be nicer. -- +{-# OPTIONS_GHC -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/WorkingConventions#Warnings +-- for details + module RegAllocColor ( regAlloc, regDotColor @@ -20,11 +27,11 @@ module RegAllocColor ( where -#include "nativeGen/NCG.h" - import qualified GraphColor as Color import RegLiveness import RegSpill +import RegSpillClean +import RegAllocStats import MachRegs import MachInstrs import RegCoalesce @@ -51,23 +58,23 @@ 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. + :: Bool -- ^ whether to generate RegAllocStats, or not. + -> 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 dump regsFree slotsFree code = do (code_final, debug_codeGraphs, graph_final) - <- regAlloc_spin 0 trivColorable regsFree slotsFree [] code + <- regAlloc_spin dump 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 dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code = do -- check that we're not running off down the garden path. when (spinCount > maxSpinCount) @@ -81,11 +88,21 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code -- build a conflict graph from the code. graph <- buildGraph code - -- build a map of how many instructions each reg lives for - -- this lazy, it won't be computed unless we need to spill + -- 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)) $ map lifetimeCount code + -- record startup state + let stat1 = + if spinCount == 0 + then Just $ RegAllocStatsStart + { raLiveCmm = code + , raGraph = graph + , raLifetimes = fmLife } + else Nothing + + -- the function to choose regs to leave uncolored let spill = chooseSpill_maxLife fmLife @@ -98,24 +115,54 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code then do -- patch the registers using the info in the graph let code_patched = map (patchRegsFromGraph graph_colored) code + + -- clean out unneeded SPILL/RELOADs + let code_spillclean = map cleanSpills code_patched + + -- strip off liveness information let code_nat = map stripLive code_patched + + -- rewrite SPILL/REALOAD pseudos into real instructions + let spillNatTop = mapGenBlockTop spillNatBlock + let code_final = map spillNatTop code_nat - return ( code_nat - , debug_codeGraphs ++ [(code, graph_colored), (code_patched, graph_colored)] + -- record what happened in this stage for debugging + let stat = + RegAllocStatsColored + { raGraph = graph_colored + , raPatched = code_patched + , raSpillClean = code_spillclean + , raFinal = code_final + , raSRMs = foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean } + + return ( code_final + , if dump + then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] , graph_colored) else do -- spill the uncolored regs - (code_spilled, slotsFree') + (code_spilled, slotsFree', spillStats) <- regSpill code 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 + , raSpillStats = spillStats + , raLifetimes = fmLife + , raSpilled = code_spilled } -- try again - regAlloc_spin (spinCount + 1) triv regsFree slotsFree' - (debug_codeGraphs ++ [(code, graph_colored)]) + regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree' + (if dump + then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else []) code_relive @@ -180,7 +227,7 @@ buildGraph code -- | 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 +248,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 @@ -251,81 +298,6 @@ patchRegsFromGraph graph code 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