X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FGraph%2FMain.hs;h=cdbe98755acf48e3a1952bb997911b94a1b5d850;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hp=1f04d7ff72da1047b4c93ec90e0faf7c53633585;hpb=a12e845684c10955bc594cdb20d1f13fae14873d;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 1f04d7f..cdbe987 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -5,21 +5,23 @@ -- module RegAlloc.Graph.Main ( - regAlloc, - regDotColor + regAlloc ) where import qualified GraphColor as Color -import RegLiveness +import RegAlloc.Liveness import RegAlloc.Graph.Spill import RegAlloc.Graph.SpillClean import RegAlloc.Graph.SpillCost import RegAlloc.Graph.Stats -import Regs -import Instrs -import PprMach +import RegAlloc.Graph.TrivColorable +import Instruction +import TargetReg +import RegClass +import Reg + import UniqSupply import UniqSet @@ -41,25 +43,41 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. --- regAlloc - :: DynFlags - -> UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation + :: (Outputable instr, Instruction instr) + => DynFlags + -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. - -> [LiveCmmTop] -- ^ code annotated with liveness information. - -> UniqSM ( [NatCmmTop], [RegAllocStats] ) + -> [LiveCmmTop instr] -- ^ code annotated with liveness information. + -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] ) -- ^ code with registers allocated and stats for each stage of -- allocation regAlloc dflags regsFree slotsFree code = do + -- TODO: the regClass function is currently hard coded to the default target + -- architecture. Would prefer to determine this from dflags. + -- There are other uses of targetRegClass later in this module. + let triv = trivColorable + targetVirtualRegSqueeze + targetRealRegSqueeze + (code_final, debug_codeGraphs, _) - <- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code + <- regAlloc_spin dflags 0 + triv + regsFree slotsFree [] code return ( code_final , reverse debug_codeGraphs ) -regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code +regAlloc_spin + dflags + spinCount + (triv :: Color.Triv VirtualReg RegClass RealReg) + (regsFree :: UniqFM (UniqSet RealReg)) + 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 @@ -74,12 +92,13 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded." ( text "It looks like the register allocator is stuck in an infinite loop." $$ text "max cycles = " <> int maxSpinCount - $$ text "regsFree = " <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) + $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree) $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) -- build a conflict graph from the code. - graph <- {-# SCC "BuildGraph" #-} buildGraph code + (graph :: Color.Graph VirtualReg RegClass RealReg) + <- {-# SCC "BuildGraph" #-} buildGraph code -- VERY IMPORTANT: -- We really do want the graph to be fully evaluated _before_ we start coloring. @@ -115,9 +134,15 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code 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 patchF reg + | RegVirtual vr <- reg + = case lookupUFM rmCoalesce vr of + Just vr' -> patchF (RegVirtual vr') + Nothing -> reg + + | otherwise + = reg + let code_coalesced = map (patchEraseLive patchF) code @@ -139,19 +164,18 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code -- clean out unneeded SPILL/RELOADs let code_spillclean = map cleanSpills code_patched - -- strip off liveness information - let code_nat = map stripLive code_spillclean + -- strip off liveness information, + -- and rewrite SPILL/RELOAD pseudos into real instructions along the way + let code_final = 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 + { raCode = code + , raGraph = graph , raGraphColored = graph_colored_lint , raCoalesced = rmCoalesce + , raCodeCoalesced = code_coalesced , raPatched = code_patched , raSpillClean = code_spillclean , raFinal = code_final @@ -184,13 +208,16 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code <- regSpill code_coalesced slotsFree rsSpill -- recalculate liveness - let code_nat = map stripLive code_spilled - code_relive <- mapM regLiveness code_nat + -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency + -- order required by computeLiveness. If they're not in the correct order + -- that function will panic. + code_relive <- mapM (regLiveness . reverseBlocksInTops) code_spilled -- record what happened in this stage for debugging let stat = RegAllocStatsSpill - { raGraph = graph_colored_lint + { raCode = code + , raGraph = graph_colored_lint , raCoalesced = rmCoalesce , raSpillStats = spillStats , raSpillCosts = spillCosts @@ -209,12 +236,11 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code code_relive - -- | Build a graph from the liveness and coalesce information in this code. - buildGraph - :: [LiveCmmTop] - -> UniqSM (Color.Graph Reg RegClass Reg) + :: Instruction instr + => [LiveCmmTop instr] + -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code = do @@ -238,72 +264,92 @@ buildGraph code -- | Add some conflict edges to the graph. -- Conflicts between virtual and real regs are recorded as exclusions. --- graphAddConflictSet :: UniqSet Reg - -> Color.Graph Reg RegClass Reg - -> Color.Graph Reg RegClass Reg + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg graphAddConflictSet set graph - = let reals = filterUFM isRealReg set - virtuals = filterUFM (not . isRealReg) set + = let virtuals = mkUniqSet + [ vr | RegVirtual vr <- uniqSetToList set ] - graph1 = Color.addConflicts virtuals regClass graph - graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2) + graph1 = Color.addConflicts virtuals classOfVirtualReg graph + + graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2) graph1 - [ (a, b) - | a <- uniqSetToList virtuals - , b <- uniqSetToList reals] + [ (vr, rr) + | RegVirtual vr <- uniqSetToList set + , RegReal rr <- uniqSetToList set] in graph2 -- | Add some coalesence edges to the graph -- Coalesences between virtual and real regs are recorded as preferences. --- graphAddCoalesce :: (Reg, Reg) - -> Color.Graph Reg RegClass Reg - -> Color.Graph Reg RegClass Reg + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg graphAddCoalesce (r1, r2) graph - | RealReg _ <- r1 - = Color.addPreference (regWithClass r2) r1 graph + | RegReal rr <- r1 + , RegVirtual vr <- r2 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph - | RealReg _ <- r2 - = Color.addPreference (regWithClass r1) r2 graph + | RegReal rr <- r2 + , RegVirtual vr <- r1 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph + + | RegVirtual vr1 <- r1 + , RegVirtual vr2 <- r2 + = Color.addCoalesce + (vr1, classOfVirtualReg vr1) + (vr2, classOfVirtualReg vr2) + graph + + -- We can't coalesce two real regs, but there could well be existing + -- hreg,hreg moves in the input code. We'll just ignore these + -- for coalescing purposes. + | RegReal _ <- r1 + , RegReal _ <- r2 + = graph + +graphAddCoalesce _ _ + = panic "graphAddCoalesce: bogus" - | otherwise - = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph - - where regWithClass r = (r, regClass r) - -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: Color.Graph Reg RegClass Reg - -> LiveCmmTop -> LiveCmmTop + :: (Outputable instr, Instruction instr) + => Color.Graph VirtualReg RegClass RealReg + -> LiveCmmTop instr -> LiveCmmTop instr patchRegsFromGraph graph code = let -- a function to lookup the hardreg for a virtual reg from the graph. patchF reg -- leave real regs alone. - | isRealReg reg + | RegReal{} <- reg = reg -- this virtual has a regular node in the graph. - | Just node <- Color.lookupNode graph reg + | RegVirtual vr <- reg + , Just node <- Color.lookupNode graph vr = case Color.nodeColor node of - Just color -> color - Nothing -> reg + Just color -> RegReal color + Nothing -> RegVirtual vr -- no node in the graph for this virtual, bad news. | otherwise = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg $$ ppr code - $$ Color.dotGraph (\_ -> text "white") trivColorable graph) + $$ Color.dotGraph + (\_ -> text "white") + (trivColorable + targetVirtualRegSqueeze + targetRealRegSqueeze) + graph) in patchEraseLive patchF code @@ -311,52 +357,51 @@ patchRegsFromGraph graph code ----- -- for when laziness just isn't what you wanted... -- -seqGraph :: Color.Graph Reg RegClass Reg -> () +seqGraph :: Color.Graph VirtualReg RegClass RealReg -> () seqGraph graph = seqNodes (eltsUFM (Color.graphMap graph)) -seqNodes :: [Color.Node Reg RegClass Reg] -> () +seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> () seqNodes ns = case ns of [] -> () (n : ns) -> seqNode n `seq` seqNodes ns -seqNode :: Color.Node Reg RegClass Reg -> () +seqNode :: Color.Node VirtualReg RegClass RealReg -> () 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 _ -> () + = seqVirtualReg (Color.nodeId node) + `seq` seqRegClass (Color.nodeClass node) + `seq` seqMaybeRealReg (Color.nodeColor node) + `seq` (seqVirtualRegList (uniqSetToList (Color.nodeConflicts node))) + `seq` (seqRealRegList (uniqSetToList (Color.nodeExclusions node))) + `seq` (seqRealRegList (Color.nodePreference node)) + `seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node))) + +seqVirtualReg :: VirtualReg -> () +seqVirtualReg reg = reg `seq` () + +seqRealReg :: RealReg -> () +seqRealReg reg = reg `seq` () seqRegClass :: RegClass -> () -seqRegClass c - = case c of - RcInteger -> () - RcFloat -> () - RcDouble -> () - -seqMaybeReg :: Maybe Reg -> () -seqMaybeReg mr +seqRegClass c = c `seq` () + +seqMaybeRealReg :: Maybe RealReg -> () +seqMaybeRealReg mr = case mr of Nothing -> () - Just r -> seqReg r + Just r -> seqRealReg r + +seqVirtualRegList :: [VirtualReg] -> () +seqVirtualRegList rs + = case rs of + [] -> () + (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs -seqRegList :: [Reg] -> () -seqRegList rs +seqRealRegList :: [RealReg] -> () +seqRealRegList rs = case rs of [] -> () - (r : rs) -> seqReg r `seq` seqRegList rs + (r : rs) -> seqRealReg r `seq` seqRealRegList rs seqList :: [a] -> () seqList ls