X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FGraph%2FMain.hs;h=cdbe98755acf48e3a1952bb997911b94a1b5d850;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hp=2e584617e9f3da2977e90e0e421e4ac0e0e2c9e1;hpb=b04a210e26ca57242fd052f2aa91011a80b76299;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 2e58461..cdbe987 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -43,11 +43,10 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. --- regAlloc :: (Outputable instr, Instruction instr) => DynFlags - -> UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation + -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. -> [LiveCmmTop instr] -- ^ code annotated with liveness information. -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] ) @@ -59,7 +58,9 @@ regAlloc dflags regsFree slotsFree code -- 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 targetRegClass + let triv = trivColorable + targetVirtualRegSqueeze + targetRealRegSqueeze (code_final, debug_codeGraphs, _) <- regAlloc_spin dflags 0 @@ -69,7 +70,14 @@ regAlloc dflags 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 @@ -89,7 +97,8 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code $$ 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. @@ -125,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 @@ -153,15 +168,14 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code -- and rewrite SPILL/RELOAD pseudos into real instructions along the way let code_final = map stripLive code_spillclean --- 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 @@ -194,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 @@ -219,13 +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 :: Instruction instr => [LiveCmmTop instr] - -> UniqSM (Color.Graph Reg RegClass Reg) + -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code = do @@ -249,51 +264,64 @@ 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 targetRegClass graph - graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 targetRegClass 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, targetRegClass r) - -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph :: (Outputable instr, Instruction instr) - => Color.Graph Reg RegClass Reg + => Color.Graph VirtualReg RegClass RealReg -> LiveCmmTop instr -> LiveCmmTop instr patchRegsFromGraph graph code @@ -301,21 +329,27 @@ patchRegsFromGraph graph code -- 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 targetRegClass) graph) + $$ Color.dotGraph + (\_ -> text "white") + (trivColorable + targetVirtualRegSqueeze + targetRealRegSqueeze) + graph) in patchEraseLive patchF code @@ -323,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