diff options
Diffstat (limited to 'compiler/nativeGen/RegAlloc/Graph')
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/ArchBase.hs | 163 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/ArchX86.hs | 161 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/Coalesce.hs | 99 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/Main.hs | 472 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/Spill.hs | 382 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/SpillClean.hs | 616 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/SpillCost.hs | 317 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/Stats.hs | 346 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs | 274 |
9 files changed, 0 insertions, 2830 deletions
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs deleted file mode 100644 index c38d998779..0000000000 --- a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs +++ /dev/null @@ -1,163 +0,0 @@ - --- | Utils for calculating general worst, bound, squeese and free, functions. --- --- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation" --- Michael Smith, Normal Ramsey, Glenn Holloway. --- PLDI 2004 --- --- These general versions are not used in GHC proper because they are too slow. --- Instead, hand written optimised versions are provided for each architecture --- in MachRegs*.hs --- --- This code is here because we can test the architecture specific code against --- it. --- -module RegAlloc.Graph.ArchBase ( - RegClass(..), - Reg(..), - RegSub(..), - - worst, - bound, - squeese -) where - -import GhcPrelude - -import UniqSet -import UniqFM -import Unique -import MonadUtils (concatMapM) - - --- Some basic register classes. --- These aren't necessarily in 1-to-1 correspondence with the allocatable --- RegClasses in MachRegs.hs -data RegClass - -- general purpose regs - = ClassG32 -- 32 bit GPRs - | ClassG16 -- 16 bit GPRs - | ClassG8 -- 8 bit GPRs - - -- floating point regs - | ClassF64 -- 64 bit FPRs - deriving (Show, Eq, Enum) - - --- | A register of some class -data Reg - -- a register of some class - = Reg RegClass Int - - -- a sub-component of one of the other regs - | RegSub RegSub Reg - deriving (Show, Eq) - - --- | so we can put regs in UniqSets -instance Uniquable Reg where - getUnique (Reg c i) - = mkRegSingleUnique - $ fromEnum c * 1000 + i - - getUnique (RegSub s (Reg c i)) - = mkRegSubUnique - $ fromEnum s * 10000 + fromEnum c * 1000 + i - - getUnique (RegSub _ (RegSub _ _)) - = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg." - - --- | A subcomponent of another register -data RegSub - = SubL16 -- lowest 16 bits - | SubL8 -- lowest 8 bits - | SubL8H -- second lowest 8 bits - deriving (Show, Enum, Ord, Eq) - - --- | Worst case displacement --- --- a node N of classN has some number of neighbors, --- all of which are from classC. --- --- (worst neighbors classN classC) is the maximum number of potential --- colors for N that can be lost by coloring its neighbors. --- --- This should be hand coded/cached for each particular architecture, --- because the compute time is very long.. -worst :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> Int -> RegClass -> RegClass -> Int - -worst regsOfClass regAlias neighbors classN classC - = let regAliasS regs = unionManyUniqSets - $ map regAlias - $ nonDetEltsUniqSet regs - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- all the regs in classes N, C - regsN = regsOfClass classN - regsC = regsOfClass classC - - -- all the possible subsets of c which have size < m - regsS = filter (\s -> sizeUniqSet s >= 1 - && sizeUniqSet s <= neighbors) - $ powersetLS regsC - - -- for each of the subsets of C, the regs which conflict - -- with posiblities for N - regsS_conflict - = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS - - in maximum $ map sizeUniqSet $ regsS_conflict - - --- | For a node N of classN and neighbors of classesC --- (bound classN classesC) is the maximum number of potential --- colors for N that can be lost by coloring its neighbors. -bound :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> RegClass -> [RegClass] -> Int - -bound regsOfClass regAlias classN classesC - = let regAliasS regs = unionManyUniqSets - $ map regAlias - $ nonDetEltsUFM regs - -- See Note [Unique Determinism and code generation] - - regsC_aliases - = unionManyUniqSets - $ map (regAliasS . getUniqSet . regsOfClass) classesC - - overlap = intersectUniqSets (regsOfClass classN) regsC_aliases - - in sizeUniqSet overlap - - --- | The total squeese on a particular node with a list of neighbors. --- --- A version of this should be constructed for each particular architecture, --- possibly including uses of bound, so that alised registers don't get --- counted twice, as per the paper. -squeese :: (RegClass -> UniqSet Reg) - -> (Reg -> UniqSet Reg) - -> RegClass -> [(Int, RegClass)] -> Int - -squeese regsOfClass regAlias classN countCs - = sum - $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC) - $ countCs - - --- | powerset (for lists) -powersetL :: [a] -> [[a]] -powersetL = concatMapM (\x -> [[],[x]]) - - --- | powersetLS (list of sets) -powersetLS :: Uniquable a => UniqSet a -> [UniqSet a] -powersetLS s = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s - -- See Note [Unique Determinism and code generation] diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs deleted file mode 100644 index 0472e4cf09..0000000000 --- a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs +++ /dev/null @@ -1,161 +0,0 @@ - --- | A description of the register set of the X86. --- --- This isn't used directly in GHC proper. --- --- See RegArchBase.hs for the reference. --- See MachRegs.hs for the actual trivColorable function used in GHC. --- -module RegAlloc.Graph.ArchX86 ( - classOfReg, - regsOfClass, - regName, - regAlias, - worst, - squeese, -) where - -import GhcPrelude - -import RegAlloc.Graph.ArchBase (Reg(..), RegSub(..), RegClass(..)) -import UniqSet - -import qualified Data.Array as A - - --- | Determine the class of a register -classOfReg :: Reg -> RegClass -classOfReg reg - = case reg of - Reg c _ -> c - - RegSub SubL16 _ -> ClassG16 - RegSub SubL8 _ -> ClassG8 - RegSub SubL8H _ -> ClassG8 - - --- | Determine all the regs that make up a certain class. -regsOfClass :: RegClass -> UniqSet Reg -regsOfClass c - = case c of - ClassG32 - -> mkUniqSet [ Reg ClassG32 i - | i <- [0..7] ] - - ClassG16 - -> mkUniqSet [ RegSub SubL16 (Reg ClassG32 i) - | i <- [0..7] ] - - ClassG8 - -> unionUniqSets - (mkUniqSet [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ]) - (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ]) - - ClassF64 - -> mkUniqSet [ Reg ClassF64 i - | i <- [0..5] ] - - --- | Determine the common name of a reg --- returns Nothing if this reg is not part of the machine. -regName :: Reg -> Maybe String -regName reg - = case reg of - Reg ClassG32 i - | i <= 7 -> - let names = A.listArray (0,8) - [ "eax", "ebx", "ecx", "edx" - , "ebp", "esi", "edi", "esp" ] - in Just $ names A.! i - - RegSub SubL16 (Reg ClassG32 i) - | i <= 7 -> - let names = A.listArray (0,8) - [ "ax", "bx", "cx", "dx" - , "bp", "si", "di", "sp"] - in Just $ names A.! i - - RegSub SubL8 (Reg ClassG32 i) - | i <= 3 -> - let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"] - in Just $ names A.! i - - RegSub SubL8H (Reg ClassG32 i) - | i <= 3 -> - let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"] - in Just $ names A.! i - - _ -> Nothing - - --- | Which regs alias what other regs. -regAlias :: Reg -> UniqSet Reg -regAlias reg - = case reg of - - -- 32 bit regs alias all of the subregs - Reg ClassG32 i - - -- for eax, ebx, ecx, eds - | i <= 3 - -> mkUniqSet - $ [ Reg ClassG32 i, RegSub SubL16 reg - , RegSub SubL8 reg, RegSub SubL8H reg ] - - -- for esi, edi, esp, ebp - | 4 <= i && i <= 7 - -> mkUniqSet - $ [ Reg ClassG32 i, RegSub SubL16 reg ] - - -- 16 bit subregs alias the whole reg - RegSub SubL16 r@(Reg ClassG32 _) - -> regAlias r - - -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg - RegSub SubL8 r@(Reg ClassG32 _) - -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ] - - RegSub SubL8H r@(Reg ClassG32 _) - -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ] - - -- fp - Reg ClassF64 _ - -> unitUniqSet reg - - _ -> error "regAlias: invalid register" - - --- | Optimised versions of RegColorBase.{worst, squeese} specific to x86 -worst :: Int -> RegClass -> RegClass -> Int -worst n classN classC - = case classN of - ClassG32 - -> case classC of - ClassG32 -> min n 8 - ClassG16 -> min n 8 - ClassG8 -> min n 4 - ClassF64 -> 0 - - ClassG16 - -> case classC of - ClassG32 -> min n 8 - ClassG16 -> min n 8 - ClassG8 -> min n 4 - ClassF64 -> 0 - - ClassG8 - -> case classC of - ClassG32 -> min (n*2) 8 - ClassG16 -> min (n*2) 8 - ClassG8 -> min n 8 - ClassF64 -> 0 - - ClassF64 - -> case classC of - ClassF64 -> min n 6 - _ -> 0 - -squeese :: RegClass -> [(Int, RegClass)] -> Int -squeese classN countCs - = sum (map (\(i, classC) -> worst i classN classC) countCs) - diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs deleted file mode 100644 index f42ff9450a..0000000000 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | Register coalescing. -module RegAlloc.Graph.Coalesce ( - regCoalesce, - slurpJoinMovs -) where -import GhcPrelude - -import RegAlloc.Liveness -import Instruction -import Reg - -import GHC.Cmm -import Bag -import Digraph -import UniqFM -import UniqSet -import UniqSupply - - --- | Do register coalescing on this top level thing --- --- For Reg -> Reg moves, if the first reg dies at the same time the --- second reg is born then the mov only serves to join live ranges. --- The two regs can be renamed to be the same and the move instruction --- safely erased. -regCoalesce - :: Instruction instr - => [LiveCmmDecl statics instr] - -> UniqSM [LiveCmmDecl statics instr] - -regCoalesce code - = do - let joins = foldl' unionBags emptyBag - $ map slurpJoinMovs code - - let alloc = foldl' buildAlloc emptyUFM - $ bagToList joins - - let patched = map (patchEraseLive (sinkReg alloc)) code - - return patched - - --- | Add a v1 = v2 register renaming to the map. --- The register with the lowest lexical name is set as the --- canonical version. -buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg -buildAlloc fm (r1, r2) - = let rmin = min r1 r2 - rmax = max r1 r2 - in addToUFM fm rmax rmin - - --- | Determine the canonical name for a register by following --- v1 = v2 renamings in this map. -sinkReg :: UniqFM Reg -> Reg -> Reg -sinkReg fm r - = case lookupUFM fm r of - Nothing -> r - Just r' -> sinkReg fm r' - - --- | Slurp out mov instructions that only serve to join live ranges. --- --- During a mov, if the source reg dies and the destination reg is --- born then we can rename the two regs to the same thing and --- eliminate the move. -slurpJoinMovs - :: Instruction instr - => LiveCmmDecl statics instr - -> Bag (Reg, Reg) - -slurpJoinMovs live - = slurpCmm emptyBag live - where - slurpCmm rs CmmData{} - = rs - - slurpCmm rs (CmmProc _ _ _ sccs) - = foldl' slurpBlock rs (flattenSCCs sccs) - - slurpBlock rs (BasicBlock _ instrs) - = foldl' slurpLI rs instrs - - slurpLI rs (LiveInstr _ Nothing) = rs - slurpLI rs (LiveInstr instr (Just live)) - | Just (r1, r2) <- takeRegRegMoveInstr instr - , elementOfUniqSet r1 $ liveDieRead live - , elementOfUniqSet r2 $ liveBorn live - - -- only coalesce movs between two virtuals for now, - -- else we end up with allocatable regs in the live - -- regs list.. - , isVirtualReg r1 && isVirtualReg r2 - = consBag (r1, r2) rs - - | otherwise - = rs - diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs deleted file mode 100644 index 6b2758f723..0000000000 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ /dev/null @@ -1,472 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Graph coloring register allocator. -module RegAlloc.Graph.Main ( - regAlloc -) where -import GhcPrelude - -import qualified GraphColor as Color -import RegAlloc.Liveness -import RegAlloc.Graph.Spill -import RegAlloc.Graph.SpillClean -import RegAlloc.Graph.SpillCost -import RegAlloc.Graph.Stats -import RegAlloc.Graph.TrivColorable -import Instruction -import TargetReg -import RegClass -import Reg - -import Bag -import GHC.Driver.Session -import Outputable -import GHC.Platform -import UniqFM -import UniqSet -import UniqSupply -import Util (seqList) -import CFG - -import Data.Maybe -import Control.Monad - - --- | The maximum number of build\/spill cycles we'll allow. --- --- It should only take 3 or 4 cycles for the allocator to converge. --- If it takes any longer than this it's probably in an infinite loop, --- so it's better just to bail out and report a bug. -maxSpinCount :: Int -maxSpinCount = 10 - - --- | The top level of the graph coloring register allocator. -regAlloc - :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags - -> UniqFM (UniqSet RealReg) -- ^ registers we can use for allocation - -> UniqSet Int -- ^ set of available spill slots. - -> Int -- ^ current number of spill slots - -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information. - -> Maybe CFG -- ^ CFG of basic blocks if available - -> UniqSM ( [NatCmmDecl statics instr] - , Maybe Int, [RegAllocStats statics instr] ) - -- ^ code with registers allocated, additional stacks required - -- and stats for each stage of allocation - -regAlloc dflags regsFree slotsFree slotsCount code cfg - = 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 platform = targetPlatform dflags - triv = trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform) - - (code_final, debug_codeGraphs, slotsCount', _) - <- regAlloc_spin dflags 0 - triv - regsFree slotsFree slotsCount [] code cfg - - let needStack - | slotsCount == slotsCount' - = Nothing - | otherwise - = Just slotsCount' - - return ( code_final - , needStack - , reverse debug_codeGraphs ) - - --- | Perform solver iterations for the graph coloring allocator. --- --- We extract a register conflict graph from the provided cmm code, --- and try to colour it. If that works then we use the solution rewrite --- the code with real hregs. If coloring doesn't work we add spill code --- and try to colour it again. After `maxSpinCount` iterations we give up. --- -regAlloc_spin - :: forall instr statics. - (Instruction instr, - Outputable instr, - Outputable statics) - => DynFlags - -> Int -- ^ Number of solver iterations we've already performed. - -> Color.Triv VirtualReg RegClass RealReg - -- ^ Function for calculating whether a register is trivially - -- colourable. - -> UniqFM (UniqSet RealReg) -- ^ Free registers that we can allocate. - -> UniqSet Int -- ^ Free stack slots that we can use. - -> Int -- ^ Number of spill slots in use - -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to. - -> [LiveCmmDecl statics instr] -- ^ Liveness annotated code to allocate. - -> Maybe CFG - -> UniqSM ( [NatCmmDecl statics instr] - , [RegAllocStats statics instr] - , Int -- Slots in use - , Color.Graph VirtualReg RegClass RealReg) - -regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg - = do - let platform = targetPlatform dflags - - -- 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." - ( text "It looks like the register allocator is stuck in an infinite loop." - $$ text "max cycles = " <> int maxSpinCount - $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr - $ nonDetEltsUniqSet $ unionManyUniqSets - $ nonDetEltsUFM regsFree) - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) - - -- Build the register conflict graph from the cmm 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. 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 the cost of spilling each instruction. - -- This is a lazy binding, so the map will only be computed if we - -- actually have to spill to the stack. - let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map (slurpSpillCostInfo platform cfg) code - - -- The function to choose regs to leave uncolored. - let spill = chooseSpill spillCosts - - -- Record startup state in our log. - let stat1 - = if spinCount == 0 - then Just $ RegAllocStatsStart - { raLiveCmm = code - , raGraph = graph - , raSpillCosts = spillCosts } - else Nothing - - -- Try and color the graph. - let (graph_colored, rsSpill, rmCoalesce) - = {-# SCC "ColorGraph" #-} - Color.colorGraph - (gopt Opt_RegsIterative dflags) - spinCount - regsFree triv spill graph - - -- Rewrite registers in the code that have been coalesced. - let patchF reg - | RegVirtual vr <- reg - = case lookupUFM rmCoalesce vr of - Just vr' -> patchF (RegVirtual vr') - Nothing -> reg - - | otherwise - = reg - - let (code_coalesced :: [LiveCmmDecl statics instr]) - = map (patchEraseLive patchF) code - - -- Check whether we've found a coloring. - if isEmptyUniqSet rsSpill - - -- Coloring was successful because no registers needed to be spilled. - then do - -- if -fasm-lint is turned on then validate the graph. - -- This checks for bugs in the graph allocator itself. - let graph_colored_lint = - if gopt Opt_DoAsmLinting dflags - then Color.validateGraph (text "") - True -- Require all nodes to be colored. - graph_colored - else graph_colored - - -- Rewrite the code to use real hregs, using the colored graph. - let code_patched - = map (patchRegsFromGraph platform graph_colored_lint) - code_coalesced - - -- Clean out unneeded SPILL/RELOAD meta instructions. - -- The spill code generator just spills the entire live range - -- of a vreg, but it might not need to be on the stack for - -- its entire lifetime. - let code_spillclean - = map (cleanSpills platform) code_patched - - -- Strip off liveness information from the allocated code. - -- Also rewrite SPILL/RELOAD meta instructions into real machine - -- instructions along the way - let code_final - = map (stripLive dflags) code_spillclean - - -- Record what happened in this stage for debugging - let stat - = RegAllocStatsColored - { raCode = code - , raGraph = graph - , raGraphColored = graph_colored_lint - , raCoalesced = rmCoalesce - , raCodeCoalesced = code_coalesced - , raPatched = code_patched - , raSpillClean = code_spillclean - , raFinal = code_final - , raSRMs = foldl' addSRM (0, 0, 0) - $ map countSRMs code_spillclean } - - -- Bundle up all the register allocator statistics. - -- .. but make sure to drop them on the floor if they're not - -- needed, otherwise we'll get a space leak. - let statList = - if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else [] - - -- Ensure all the statistics are evaluated, to avoid space leaks. - seqList statList (return ()) - - return ( code_final - , statList - , slotsCount - , graph_colored_lint) - - -- Coloring was unsuccessful. We need to spill some register to the - -- stack, make a new graph, and try to color it again. - else do - -- if -fasm-lint is turned on then validate the graph - let graph_colored_lint = - if gopt Opt_DoAsmLinting dflags - then Color.validateGraph (text "") - False -- don't require nodes to be colored - graph_colored - else graph_colored - - -- Spill uncolored regs to the stack. - (code_spilled, slotsFree', slotsCount', spillStats) - <- regSpill platform code_coalesced slotsFree slotsCount rsSpill - - -- Recalculate liveness information. - -- 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 platform . reverseBlocksInTops) - code_spilled - - -- Record what happened in this stage for debugging. - let stat = - RegAllocStatsSpill - { raCode = code - , raGraph = graph_colored_lint - , raCoalesced = rmCoalesce - , raSpillStats = spillStats - , raSpillCosts = spillCosts - , raSpilled = code_spilled } - - -- Bundle up all the register allocator statistics. - -- .. but make sure to drop them on the floor if they're not - -- needed, otherwise we'll get a space leak. - let statList = - if dump - then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else [] - - -- Ensure all the statistics are evaluated, to avoid space leaks. - seqList statList (return ()) - - regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' - slotsCount' statList code_relive cfg - - --- | Build a graph from the liveness and coalesce information in this code. -buildGraph - :: Instruction instr - => [LiveCmmDecl statics instr] - -> UniqSM (Color.Graph VirtualReg RegClass RealReg) - -buildGraph code - = do - -- Slurp out the conflicts and reg->reg moves from this code. - let (conflictList, moveList) = - unzip $ map slurpConflicts code - - -- 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 - = foldr graphAddConflictSet Color.initGraph conflictBag - - -- Add the coalescences edges to the graph. - let moveBag - = unionBags (unionManyBags moveList2) - (unionManyBags moveList) - - let graph_coalesce - = foldr graphAddCoalesce graph_conflict moveBag - - return graph_coalesce - - --- | Add some conflict edges to the graph. --- Conflicts between virtual and real regs are recorded as exclusions. -graphAddConflictSet - :: UniqSet Reg - -> Color.Graph VirtualReg RegClass RealReg - -> Color.Graph VirtualReg RegClass RealReg - -graphAddConflictSet set graph - = let virtuals = mkUniqSet - [ vr | RegVirtual vr <- nonDetEltsUniqSet set ] - - graph1 = Color.addConflicts virtuals classOfVirtualReg graph - - graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2) - graph1 - [ (vr, rr) - | RegVirtual vr <- nonDetEltsUniqSet set - , RegReal rr <- nonDetEltsUniqSet set] - -- See Note [Unique Determinism and code generation] - - in graph2 - - --- | Add some coalesence edges to the graph --- Coalesences between virtual and real regs are recorded as preferences. -graphAddCoalesce - :: (Reg, Reg) - -> Color.Graph VirtualReg RegClass RealReg - -> Color.Graph VirtualReg RegClass RealReg - -graphAddCoalesce (r1, r2) graph - | RegReal rr <- r1 - , RegVirtual vr <- r2 - = Color.addPreference (vr, classOfVirtualReg vr) rr 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 - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise - = panic "graphAddCoalesce" -#endif - - --- | Patch registers in code using the reg -> reg mapping in this graph. -patchRegsFromGraph - :: (Outputable statics, Outputable instr, Instruction instr) - => Platform -> Color.Graph VirtualReg RegClass RealReg - -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr - -patchRegsFromGraph platform graph code - = patchEraseLive patchF code - where - -- Function to lookup the hardreg for a virtual reg from the graph. - patchF reg - -- leave real regs alone. - | RegReal{} <- reg - = reg - - -- this virtual has a regular node in the graph. - | RegVirtual vr <- reg - , Just node <- Color.lookupNode graph vr - = case Color.nodeColor node of - 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 platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - graph) - - ------ --- for when laziness just isn't what you wanted... --- We need to deepSeq the whole graph before trying to colour it to avoid --- space leaks. -seqGraph :: Color.Graph VirtualReg RegClass RealReg -> () -seqGraph graph = seqNodes (nonDetEltsUFM (Color.graphMap graph)) - -- See Note [Unique Determinism and code generation] - -seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> () -seqNodes ns - = case ns of - [] -> () - (n : ns) -> seqNode n `seq` seqNodes ns - -seqNode :: Color.Node VirtualReg RegClass RealReg -> () -seqNode node - = seqVirtualReg (Color.nodeId node) - `seq` seqRegClass (Color.nodeClass node) - `seq` seqMaybeRealReg (Color.nodeColor node) - `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node))) - `seq` (seqRealRegList (nonDetEltsUniqSet (Color.nodeExclusions node))) - `seq` (seqRealRegList (Color.nodePreference node)) - `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node))) - -- It's OK to use nonDetEltsUniqSet for seq - -seqVirtualReg :: VirtualReg -> () -seqVirtualReg reg = reg `seq` () - -seqRealReg :: RealReg -> () -seqRealReg reg = reg `seq` () - -seqRegClass :: RegClass -> () -seqRegClass c = c `seq` () - -seqMaybeRealReg :: Maybe RealReg -> () -seqMaybeRealReg mr - = case mr of - Nothing -> () - Just r -> seqRealReg r - -seqVirtualRegList :: [VirtualReg] -> () -seqVirtualRegList rs - = case rs of - [] -> () - (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs - -seqRealRegList :: [RealReg] -> () -seqRealRegList rs - = case rs of - [] -> () - (r : rs) -> seqRealReg r `seq` seqRealRegList rs diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs deleted file mode 100644 index 9ffb51ee29..0000000000 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ /dev/null @@ -1,382 +0,0 @@ - --- | When there aren't enough registers to hold all the vregs we have to spill --- some of those vregs to slots on the stack. This module is used modify the --- code to use those slots. -module RegAlloc.Graph.Spill ( - regSpill, - SpillStats(..), - accSpillSL -) where -import GhcPrelude - -import RegAlloc.Liveness -import Instruction -import Reg -import GHC.Cmm hiding (RegSet) -import GHC.Cmm.BlockId -import GHC.Cmm.Dataflow.Collections - -import MonadUtils -import State -import Unique -import UniqFM -import UniqSet -import UniqSupply -import Outputable -import GHC.Platform - -import Data.List -import Data.Maybe -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - - --- | Spill all these virtual regs to stack slots. --- --- Bumps the number of required stack slots if required. --- --- --- TODO: See if we can split some of the live ranges instead of just globally --- spilling the virtual reg. This might make the spill cleaner's job easier. --- --- TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction --- when making spills. If an instr is using a spilled virtual we may be able to --- address the spill slot directly. --- -regSpill - :: Instruction instr - => Platform - -> [LiveCmmDecl statics instr] -- ^ the code - -> UniqSet Int -- ^ available stack slots - -> Int -- ^ current number of spill slots. - -> UniqSet VirtualReg -- ^ the regs to spill - -> UniqSM - ([LiveCmmDecl statics instr] - -- code with SPILL and RELOAD meta instructions added. - , UniqSet Int -- left over slots - , Int -- slot count in use now. - , SpillStats ) -- stats about what happened during spilling - -regSpill platform code slotsFree slotCount regs - - -- Not enough slots to spill these regs. - | sizeUniqSet slotsFree < sizeUniqSet regs - = -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $ - let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512]) - in regSpill platform code slotsFree' (slotCount+512) regs - - | otherwise - = do - -- Allocate a slot for each of the spilled regs. - let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree - let regSlotMap = listToUFM - $ zip (nonDetEltsUniqSet regs) slots - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- Grab the unique supply from the monad. - us <- getUniqueSupplyM - - -- Run the spiller on all the blocks. - let (code', state') = - runState (mapM (regSpill_top platform regSlotMap) code) - (initSpillS us) - - return ( code' - , minusUniqSet slotsFree (mkUniqSet slots) - , slotCount - , makeSpillStats state') - - --- | Spill some registers to stack slots in a top-level thing. -regSpill_top - :: Instruction instr - => Platform - -> RegMap Int - -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmDecl statics instr - -- ^ the top level thing. - -> SpillM (LiveCmmDecl statics instr) - -regSpill_top platform regSlotMap cmm - = case cmm of - CmmData{} - -> return cmm - - CmmProc info label live sccs - | LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry <- info - -> do - -- The liveVRegsOnEntry contains the set of vregs that are live - -- on entry to each basic block. If we spill one of those vregs - -- we remove it from that set and add the corresponding slot - -- number to the liveSlotsOnEntry set. The spill cleaner needs - -- this information to erase unneeded spill and reload instructions - -- after we've done a successful allocation. - let liveSlotsOnEntry' :: BlockMap IntSet - liveSlotsOnEntry' - = mapFoldlWithKey patchLiveSlot - liveSlotsOnEntry liveVRegsOnEntry - - let info' - = LiveInfo static firstId - liveVRegsOnEntry - liveSlotsOnEntry' - - -- Apply the spiller to all the basic blocks in the CmmProc. - sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs - - return $ CmmProc info' label live sccs' - - where -- Given a BlockId and the set of registers live in it, - -- if registers in this block are being spilled to stack slots, - -- then record the fact that these slots are now live in those blocks - -- in the given slotmap. - patchLiveSlot - :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet - - patchLiveSlot slotMap blockId regsLive - = let - -- Slots that are already recorded as being live. - curSlotsLive = fromMaybe IntSet.empty - $ mapLookup blockId slotMap - - moreSlotsLive = IntSet.fromList - $ catMaybes - $ map (lookupUFM regSlotMap) - $ nonDetEltsUniqSet regsLive - -- See Note [Unique Determinism and code generation] - - slotMap' - = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive) - slotMap - - in slotMap' - - --- | Spill some registers to stack slots in a basic block. -regSpill_block - :: Instruction instr - => Platform - -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. - -> LiveBasicBlock instr - -> SpillM (LiveBasicBlock instr) - -regSpill_block platform regSlotMap (BasicBlock i instrs) - = do instrss' <- mapM (regSpill_instr platform regSlotMap) instrs - return $ BasicBlock i (concat instrss') - - --- | Spill some registers to stack slots in a single instruction. --- If the instruction uses registers that need to be spilled, then it is --- prefixed (or postfixed) with the appropriate RELOAD or SPILL meta --- instructions. -regSpill_instr - :: Instruction instr - => Platform - -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. - -> LiveInstr instr - -> SpillM [LiveInstr instr] - -regSpill_instr _ _ li@(LiveInstr _ Nothing) - = do return [li] - -regSpill_instr platform regSlotMap - (LiveInstr instr (Just _)) - = do - -- work out which regs are read and written in this instr - let RU rlRead rlWritten = regUsageOfInstr platform instr - - -- sometimes a register is listed as being read more than once, - -- nub this so we don't end up inserting two lots of spill code. - let rsRead_ = nub rlRead - let rsWritten_ = nub rlWritten - - -- if a reg is modified, it appears in both lists, want to undo this.. - let rsRead = rsRead_ \\ rsWritten_ - let rsWritten = rsWritten_ \\ rsRead_ - let rsModify = intersect rsRead_ rsWritten_ - - -- work out if any of the regs being used are currently being spilled. - let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead - let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten - let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify - - -- rewrite the instr and work out spill code. - (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead - (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten - (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify - - let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3) - let prefixes = concat mPrefixes - let postfixes = concat mPostfixes - - -- final code - let instrs' = prefixes - ++ [LiveInstr instr3 Nothing] - ++ postfixes - - return $ instrs' - - --- | Add a RELOAD met a instruction to load a value for an instruction that --- writes to a vreg that is being spilled. -spillRead - :: Instruction instr - => UniqFM Int - -> instr - -> Reg - -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) - -spillRead regSlotMap instr reg - | Just slot <- lookupUFM regSlotMap reg - = do (instr', nReg) <- patchInstr reg instr - - modify $ \s -> s - { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) } - - return ( instr' - , ( [LiveInstr (RELOAD slot nReg) Nothing] - , []) ) - - | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg" - - --- | Add a SPILL meta instruction to store a value for an instruction that --- writes to a vreg that is being spilled. -spillWrite - :: Instruction instr - => UniqFM Int - -> instr - -> Reg - -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) - -spillWrite regSlotMap instr reg - | Just slot <- lookupUFM regSlotMap reg - = do (instr', nReg) <- patchInstr reg instr - - modify $ \s -> s - { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) } - - return ( instr' - , ( [] - , [LiveInstr (SPILL nReg slot) Nothing])) - - | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg" - - --- | Add both RELOAD and SPILL meta instructions for an instruction that --- both reads and writes to a vreg that is being spilled. -spillModify - :: Instruction instr - => UniqFM Int - -> instr - -> Reg - -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) - -spillModify regSlotMap instr reg - | Just slot <- lookupUFM regSlotMap reg - = do (instr', nReg) <- patchInstr reg instr - - modify $ \s -> s - { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) } - - return ( instr' - , ( [LiveInstr (RELOAD slot nReg) Nothing] - , [LiveInstr (SPILL nReg slot) Nothing])) - - | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg" - - --- | Rewrite uses of this virtual reg in an instr to use a different --- virtual reg. -patchInstr - :: Instruction instr - => Reg -> instr -> SpillM (instr, Reg) - -patchInstr reg instr - = do nUnique <- newUnique - - -- The register we're rewriting is supposed to be virtual. - -- If it's not then something has gone horribly wrong. - let nReg - = case reg of - RegVirtual vr - -> RegVirtual (renameVirtualReg nUnique vr) - - RegReal{} - -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" - - let instr' = patchReg1 reg nReg instr - return (instr', nReg) - - -patchReg1 - :: Instruction instr - => Reg -> Reg -> instr -> instr - -patchReg1 old new instr - = let patchF r - | r == old = new - | otherwise = r - in patchRegsOfInstr instr patchF - - --- Spiller monad -------------------------------------------------------------- --- | State monad for the spill code generator. -type SpillM a - = State SpillS a - --- | Spill code generator state. -data SpillS - = SpillS - { -- | Unique supply for generating fresh vregs. - stateUS :: UniqSupply - - -- | Spilled vreg vs the number of times it was loaded, stored. - , stateSpillSL :: UniqFM (Reg, Int, Int) } - - --- | Create a new spiller state. -initSpillS :: UniqSupply -> SpillS -initSpillS uniqueSupply - = SpillS - { stateUS = uniqueSupply - , stateSpillSL = emptyUFM } - - --- | Allocate a new unique in the spiller monad. -newUnique :: SpillM Unique -newUnique - = do us <- gets stateUS - case takeUniqFromSupply us of - (uniq, us') - -> do modify $ \s -> s { stateUS = us' } - return uniq - - --- | Add a spill/reload count to a stats record for a register. -accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int) -accSpillSL (r1, s1, l1) (_, s2, l2) - = (r1, s1 + s2, l1 + l2) - - --- Spiller stats -------------------------------------------------------------- --- | Spiller statistics. --- Tells us what registers were spilled. -data SpillStats - = SpillStats - { spillStoreLoad :: UniqFM (Reg, Int, Int) } - - --- | Extract spiller statistics from the spiller state. -makeSpillStats :: SpillS -> SpillStats -makeSpillStats s - = SpillStats - { spillStoreLoad = stateSpillSL s } - - -instance Outputable SpillStats where - ppr stats - = pprUFM (spillStoreLoad stats) - (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l)) diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs deleted file mode 100644 index bd8b449cbb..0000000000 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ /dev/null @@ -1,616 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Clean out unneeded spill\/reload instructions. --- --- Handling of join points --- ~~~~~~~~~~~~~~~~~~~~~~~ --- --- B1: B2: --- ... ... --- RELOAD SLOT(0), %r1 RELOAD SLOT(0), %r1 --- ... A ... ... B ... --- jump B3 jump B3 --- --- B3: ... C ... --- RELOAD SLOT(0), %r1 --- ... --- --- The Plan --- ~~~~~~~~ --- As long as %r1 hasn't been written to in A, B or C then we don't need --- the reload in B3. --- --- What we really care about here is that on the entry to B3, %r1 will --- always have the same value that is in SLOT(0) (ie, %r1 is _valid_) --- --- This also works if the reloads in B1\/B2 were spills instead, because --- spilling %r1 to a slot makes that slot have the same value as %r1. --- -module RegAlloc.Graph.SpillClean ( - cleanSpills -) where -import GhcPrelude - -import RegAlloc.Liveness -import Instruction -import Reg - -import GHC.Cmm.BlockId -import GHC.Cmm -import UniqSet -import UniqFM -import Unique -import State -import Outputable -import GHC.Platform -import GHC.Cmm.Dataflow.Collections - -import Data.List -import Data.Maybe -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - - --- | The identification number of a spill slot. --- A value is stored in a spill slot when we don't have a free --- register to hold it. -type Slot = Int - - --- | Clean out unneeded spill\/reloads from this top level thing. -cleanSpills - :: Instruction instr - => Platform - -> LiveCmmDecl statics instr - -> LiveCmmDecl statics instr - -cleanSpills platform cmm - = evalState (cleanSpin platform 0 cmm) initCleanS - - --- | Do one pass of cleaning. -cleanSpin - :: Instruction instr - => Platform - -> Int -- ^ Iteration number for the cleaner. - -> LiveCmmDecl statics instr -- ^ Liveness annotated code to clean. - -> CleanM (LiveCmmDecl statics instr) - -cleanSpin platform spinCount code - = do - -- Initialise count of cleaned spill and reload instructions. - modify $ \s -> s - { sCleanedSpillsAcc = 0 - , sCleanedReloadsAcc = 0 - , sReloadedBy = emptyUFM } - - code_forward <- mapBlockTopM (cleanBlockForward platform) code - code_backward <- cleanTopBackward code_forward - - -- During the cleaning of each block we collected information about - -- what regs were valid across each jump. Based on this, work out - -- whether it will be safe to erase reloads after join points for - -- the next pass. - collateJoinPoints - - -- Remember how many spill and reload instructions we cleaned in this pass. - spills <- gets sCleanedSpillsAcc - reloads <- gets sCleanedReloadsAcc - modify $ \s -> s - { sCleanedCount = (spills, reloads) : sCleanedCount s } - - -- If nothing was cleaned in this pass or the last one - -- then we're done and it's time to bail out. - cleanedCount <- gets sCleanedCount - if take 2 cleanedCount == [(0, 0), (0, 0)] - then return code - - -- otherwise go around again - else cleanSpin platform (spinCount + 1) code_backward - - -------------------------------------------------------------------------------- --- | Clean out unneeded reload instructions, --- while walking forward over the code. -cleanBlockForward - :: Instruction instr - => Platform - -> LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) - -cleanBlockForward platform (BasicBlock blockId instrs) - = do - -- See if we have a valid association for the entry to this block. - jumpValid <- gets sJumpValid - let assoc = case lookupUFM jumpValid blockId of - Just assoc -> assoc - Nothing -> emptyAssoc - - instrs_reload <- cleanForward platform blockId assoc [] instrs - return $ BasicBlock blockId instrs_reload - - - --- | Clean out unneeded reload instructions. --- --- Walking forwards across the code --- On a reload, if we know a reg already has the same value as a slot --- then we don't need to do the reload. --- -cleanForward - :: Instruction instr - => Platform - -> BlockId -- ^ the block that we're currently in - -> Assoc Store -- ^ two store locations are associated if - -- they have the same value - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) - -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) - -cleanForward _ _ _ acc [] - = return acc - --- Rewrite live range joins via spill slots to just a spill and a reg-reg move --- hopefully the spill will be also be cleaned in the next pass -cleanForward platform blockId assoc acc (li1 : li2 : instrs) - - | LiveInstr (SPILL reg1 slot1) _ <- li1 - , LiveInstr (RELOAD slot2 reg2) _ <- li2 - , slot1 == slot2 - = do - modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - cleanForward platform blockId assoc acc - $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing - : instrs - -cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) - | Just (r1, r2) <- takeRegRegMoveInstr i1 - = if r1 == r2 - -- Erase any left over nop reg reg moves while we're here - -- this will also catch any nop moves that the previous case - -- happens to add. - then cleanForward platform blockId assoc acc instrs - - -- If r1 has the same value as some slots and we copy r1 to r2, - -- then r2 is now associated with those slots instead - else do let assoc' = addAssoc (SReg r1) (SReg r2) - $ delAssoc (SReg r2) - $ assoc - - cleanForward platform blockId assoc' (li : acc) instrs - - -cleanForward platform blockId assoc acc (li : instrs) - - -- Update association due to the spill. - | LiveInstr (SPILL reg slot) _ <- li - = let assoc' = addAssoc (SReg reg) (SSlot slot) - $ delAssoc (SSlot slot) - $ assoc - in cleanForward platform blockId assoc' (li : acc) instrs - - -- Clean a reload instr. - | LiveInstr (RELOAD{}) _ <- li - = do (assoc', mli) <- cleanReload platform blockId assoc li - case mli of - Nothing -> cleanForward platform blockId assoc' acc - instrs - - Just li' -> cleanForward platform blockId assoc' (li' : acc) - instrs - - -- Remember the association over a jump. - | LiveInstr instr _ <- li - , targets <- jumpDestsOfInstr instr - , not $ null targets - = do mapM_ (accJumpValid assoc) targets - cleanForward platform blockId assoc (li : acc) instrs - - -- Writing to a reg changes its value. - | LiveInstr instr _ <- li - , RU _ written <- regUsageOfInstr platform instr - = let assoc' = foldr delAssoc assoc (map SReg $ nub written) - in cleanForward platform blockId assoc' (li : acc) instrs - - - --- | Try and rewrite a reload instruction to something more pleasing -cleanReload - :: Instruction instr - => Platform - -> BlockId - -> Assoc Store - -> LiveInstr instr - -> CleanM (Assoc Store, Maybe (LiveInstr instr)) - -cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) - - -- If the reg we're reloading already has the same value as the slot - -- then we can erase the instruction outright. - | elemAssoc (SSlot slot) (SReg reg) assoc - = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - return (assoc, Nothing) - - -- If we can find another reg with the same value as this slot then - -- do a move instead of a reload. - | Just reg2 <- findRegOfSlot assoc slot - = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - - let assoc' = addAssoc (SReg reg) (SReg reg2) - $ delAssoc (SReg reg) - $ assoc - - return ( assoc' - , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) - - -- Gotta keep this instr. - | otherwise - = do -- Update the association. - let assoc' - = addAssoc (SReg reg) (SSlot slot) - -- doing the reload makes reg and slot the same value - $ delAssoc (SReg reg) - -- reg value changes on reload - $ assoc - - -- Remember that this block reloads from this slot. - accBlockReloadsSlot blockId slot - - return (assoc', Just li) - -cleanReload _ _ _ _ - = panic "RegSpillClean.cleanReload: unhandled instr" - - -------------------------------------------------------------------------------- --- | Clean out unneeded spill instructions, --- while walking backwards over the code. --- --- If there were no reloads from a slot between a spill and the last one --- then the slot was never read and we don't need the spill. --- --- SPILL r0 -> s1 --- RELOAD s1 -> r2 --- SPILL r3 -> s1 <--- don't need this spill --- SPILL r4 -> s1 --- RELOAD s1 -> r5 --- --- Maintain a set of --- "slots which were spilled to but not reloaded from yet" --- --- Walking backwards across the code: --- a) On a reload from a slot, remove it from the set. --- --- a) On a spill from a slot --- If the slot is in set then we can erase the spill, --- because it won't be reloaded from until after the next spill. --- --- otherwise --- keep the spill and add the slot to the set --- --- TODO: This is mostly inter-block --- we should really be updating the noReloads set as we cross jumps also. --- --- TODO: generate noReloads from liveSlotsOnEntry --- -cleanTopBackward - :: Instruction instr - => LiveCmmDecl statics instr - -> CleanM (LiveCmmDecl statics instr) - -cleanTopBackward cmm - = case cmm of - CmmData{} - -> return cmm - - CmmProc info label live sccs - | LiveInfo _ _ _ liveSlotsOnEntry <- info - -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs - return $ CmmProc info label live sccs' - - -cleanBlockBackward - :: Instruction instr - => BlockMap IntSet - -> LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) - -cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs) - = do instrs_spill <- cleanBackward liveSlotsOnEntry emptyUniqSet [] instrs - return $ BasicBlock blockId instrs_spill - - - -cleanBackward - :: Instruction instr - => BlockMap IntSet -- ^ Slots live on entry to each block - -> UniqSet Int -- ^ Slots that have been spilled, but not reloaded from - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ Instrs to clean (in forwards order) - -> CleanM [LiveInstr instr] -- ^ Cleaned instrs (in backwards order) - -cleanBackward liveSlotsOnEntry noReloads acc lis - = do reloadedBy <- gets sReloadedBy - cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis - - -cleanBackward' - :: Instruction instr - => BlockMap IntSet - -> UniqFM [BlockId] - -> UniqSet Int - -> [LiveInstr instr] - -> [LiveInstr instr] - -> State CleanS [LiveInstr instr] - -cleanBackward' _ _ _ acc [] - = return acc - -cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs) - - -- If nothing ever reloads from this slot then we don't need the spill. - | LiveInstr (SPILL _ slot) _ <- li - , Nothing <- lookupUFM reloadedBy (SSlot slot) - = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } - cleanBackward liveSlotsOnEntry noReloads acc instrs - - | LiveInstr (SPILL _ slot) _ <- li - = if elementOfUniqSet slot noReloads - - -- We can erase this spill because the slot won't be read until - -- after the next one - then do - modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } - cleanBackward liveSlotsOnEntry noReloads acc instrs - - else do - -- This slot is being spilled to, but we haven't seen any reloads yet. - let noReloads' = addOneToUniqSet noReloads slot - cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs - - -- if we reload from a slot then it's no longer unused - | LiveInstr (RELOAD slot _) _ <- li - , noReloads' <- delOneFromUniqSet noReloads slot - = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs - - -- If a slot is live in a jump target then assume it's reloaded there. - -- - -- TODO: A real dataflow analysis would do a better job here. - -- If the target block _ever_ used the slot then we assume - -- it always does, but if those reloads are cleaned the slot - -- liveness map doesn't get updated. - | LiveInstr instr _ <- li - , targets <- jumpDestsOfInstr instr - = do - let slotsReloadedByTargets - = IntSet.unions - $ catMaybes - $ map (flip mapLookup liveSlotsOnEntry) - $ targets - - let noReloads' - = foldl' delOneFromUniqSet noReloads - $ IntSet.toList slotsReloadedByTargets - - cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs - -#if __GLASGOW_HASKELL__ <= 810 - -- some other instruction - | otherwise - = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs -#endif - - --- | Combine the associations from all the inward control flow edges. --- -collateJoinPoints :: CleanM () -collateJoinPoints - = modify $ \s -> s - { sJumpValid = mapUFM intersects (sJumpValidAcc s) - , sJumpValidAcc = emptyUFM } - -intersects :: [Assoc Store] -> Assoc Store -intersects [] = emptyAssoc -intersects assocs = foldl1' intersectAssoc assocs - - --- | See if we have a reg with the same value as this slot in the association table. -findRegOfSlot :: Assoc Store -> Int -> Maybe Reg -findRegOfSlot assoc slot - | close <- closeAssoc (SSlot slot) assoc - , Just (SReg reg) <- find isStoreReg $ nonDetEltsUniqSet close - -- See Note [Unique Determinism and code generation] - = Just reg - - | otherwise - = Nothing - - -------------------------------------------------------------------------------- --- | Cleaner monad. -type CleanM - = State CleanS - --- | Cleaner state. -data CleanS - = CleanS - { -- | Regs which are valid at the start of each block. - sJumpValid :: UniqFM (Assoc Store) - - -- | Collecting up what regs were valid across each jump. - -- in the next pass we can collate these and write the results - -- to sJumpValid. - , sJumpValidAcc :: UniqFM [Assoc Store] - - -- | Map of (slot -> blocks which reload from this slot) - -- used to decide if whether slot spilled to will ever be - -- reloaded from on this path. - , sReloadedBy :: UniqFM [BlockId] - - -- | Spills and reloads cleaned each pass (latest at front) - , sCleanedCount :: [(Int, Int)] - - -- | Spills and reloads that have been cleaned in this pass so far. - , sCleanedSpillsAcc :: Int - , sCleanedReloadsAcc :: Int } - - --- | Construct the initial cleaner state. -initCleanS :: CleanS -initCleanS - = CleanS - { sJumpValid = emptyUFM - , sJumpValidAcc = emptyUFM - - , sReloadedBy = emptyUFM - - , sCleanedCount = [] - - , sCleanedSpillsAcc = 0 - , sCleanedReloadsAcc = 0 } - - --- | Remember the associations before a jump. -accJumpValid :: Assoc Store -> BlockId -> CleanM () -accJumpValid assocs target - = modify $ \s -> s { - sJumpValidAcc = addToUFM_C (++) - (sJumpValidAcc s) - target - [assocs] } - - -accBlockReloadsSlot :: BlockId -> Slot -> CleanM () -accBlockReloadsSlot blockId slot - = modify $ \s -> s { - sReloadedBy = addToUFM_C (++) - (sReloadedBy s) - (SSlot slot) - [blockId] } - - -------------------------------------------------------------------------------- --- A store location can be a stack slot or a register -data Store - = SSlot Int - | SReg Reg - - --- | Check if this is a reg store. -isStoreReg :: Store -> Bool -isStoreReg ss - = case ss of - SSlot _ -> False - SReg _ -> True - - --- Spill cleaning is only done once all virtuals have been allocated to realRegs -instance Uniquable Store where - getUnique (SReg r) - | RegReal (RealRegSingle i) <- r - = mkRegSingleUnique i - - | RegReal (RealRegPair r1 r2) <- r - = mkRegPairUnique (r1 * 65535 + r2) - - | otherwise - = error $ "RegSpillClean.getUnique: found virtual reg during spill clean," - ++ "only real regs expected." - - getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok - - -instance Outputable Store where - ppr (SSlot i) = text "slot" <> int i - ppr (SReg r) = ppr r - - -------------------------------------------------------------------------------- --- Association graphs. --- In the spill cleaner, two store locations are associated if they are known --- to hold the same value. --- -type Assoc a = UniqFM (UniqSet a) - --- | An empty association -emptyAssoc :: Assoc a -emptyAssoc = emptyUFM - - --- | Add an association between these two things. -addAssoc :: Uniquable a - => a -> a -> Assoc a -> Assoc a - -addAssoc a b m - = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b) - m2 = addToUFM_C unionUniqSets m1 b (unitUniqSet a) - in m2 - - --- | Delete all associations to a node. -delAssoc :: (Uniquable a) - => a -> Assoc a -> Assoc a - -delAssoc a m - | Just aSet <- lookupUFM m a - , m1 <- delFromUFM m a - = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet - -- It's OK to use nonDetFoldUFM here because deletion is commutative - - | otherwise = m - - --- | Delete a single association edge (a -> b). -delAssoc1 :: Uniquable a - => a -> a -> Assoc a -> Assoc a - -delAssoc1 a b m - | Just aSet <- lookupUFM m a - = addToUFM m a (delOneFromUniqSet aSet b) - - | otherwise = m - - --- | Check if these two things are associated. -elemAssoc :: (Uniquable a) - => a -> a -> Assoc a -> Bool - -elemAssoc a b m - = elementOfUniqSet b (closeAssoc a m) - - --- | Find the refl. trans. closure of the association from this point. -closeAssoc :: (Uniquable a) - => a -> Assoc a -> UniqSet a - -closeAssoc a assoc - = closeAssoc' assoc emptyUniqSet (unitUniqSet a) - where - closeAssoc' assoc visited toVisit - = case nonDetEltsUniqSet toVisit of - -- See Note [Unique Determinism and code generation] - - -- nothing else to visit, we're done - [] -> visited - - (x:_) - -- we've already seen this node - | elementOfUniqSet x visited - -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x) - - -- haven't seen this node before, - -- remember to visit all its neighbors - | otherwise - -> let neighbors - = case lookupUFM assoc x of - Nothing -> emptyUniqSet - Just set -> set - - in closeAssoc' assoc - (addOneToUniqSet visited x) - (unionUniqSets toVisit neighbors) - --- | Intersect two associations. -intersectAssoc :: Assoc a -> Assoc a -> Assoc a -intersectAssoc a b - = intersectUFM_C (intersectUniqSets) a b diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs deleted file mode 100644 index 4870bf5269..0000000000 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-} -module RegAlloc.Graph.SpillCost ( - SpillCostRecord, - plusSpillCostRecord, - pprSpillCostRecord, - - SpillCostInfo, - zeroSpillCostInfo, - plusSpillCostInfo, - - slurpSpillCostInfo, - chooseSpill, - - lifeMapFromSpillCostInfo -) where -import GhcPrelude - -import RegAlloc.Liveness -import Instruction -import RegClass -import Reg - -import GraphBase - -import GHC.Cmm.Dataflow.Collections (mapLookup) -import GHC.Cmm.Dataflow.Label -import GHC.Cmm -import UniqFM -import UniqSet -import Digraph (flattenSCCs) -import Outputable -import GHC.Platform -import State -import CFG - -import Data.List (nub, minimumBy) -import Data.Maybe -import Control.Monad (join) - - --- | Records the expected cost to spill some register. -type SpillCostRecord - = ( VirtualReg -- register name - , Int -- number of writes to this reg - , Int -- number of reads from this reg - , Int) -- number of instrs this reg was live on entry to - - --- | Map of `SpillCostRecord` -type SpillCostInfo - = UniqFM SpillCostRecord - -type SpillCostState = State (UniqFM SpillCostRecord) () - --- | An empty map of spill costs. -zeroSpillCostInfo :: SpillCostInfo -zeroSpillCostInfo = emptyUFM - - --- | Add two spill cost infos. -plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo -plusSpillCostInfo sc1 sc2 - = plusUFM_C plusSpillCostRecord sc1 sc2 - - --- | Add two spill cost records. -plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord -plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) - | r1 == r2 = (r1, a1 + a2, b1 + b2, c1 + c2) - | otherwise = error "RegSpillCost.plusRegInt: regs don't match" - - --- | Slurp out information used for determining spill costs. --- --- For each vreg, the number of times it was written to, read from, --- and the number of instructions it was live on entry to (lifetime) --- -slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr) - => Platform - -> Maybe CFG - -> LiveCmmDecl statics instr - -> SpillCostInfo - -slurpSpillCostInfo platform cfg cmm - = execState (countCmm cmm) zeroSpillCostInfo - where - countCmm CmmData{} = return () - countCmm (CmmProc info _ _ sccs) - = mapM_ (countBlock info freqMap) - $ flattenSCCs sccs - where - LiveInfo _ entries _ _ = info - freqMap = (fst . mkGlobalWeights (head entries)) <$> cfg - - -- Lookup the regs that are live on entry to this block in - -- the info table from the CmmProc. - countBlock info freqMap (BasicBlock blockId instrs) - | LiveInfo _ _ blockLive _ <- info - , Just rsLiveEntry <- mapLookup blockId blockLive - , rsLiveEntry_virt <- takeVirtuals rsLiveEntry - = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs - - | otherwise - = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block" - - - countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState - countLIs _ _ [] - = return () - - -- Skip over comment and delta pseudo instrs. - countLIs scale rsLive (LiveInstr instr Nothing : lis) - | isMetaInstr instr - = countLIs scale rsLive lis - - | otherwise - = pprPanic "RegSpillCost.slurpSpillCostInfo" - $ text "no liveness information on instruction " <> ppr instr - - countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis) - = do - -- Increment the lifetime counts for regs live on entry to this instr. - mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry - -- This is non-deterministic but we do not - -- currently support deterministic code-generation. - -- See Note [Unique Determinism and code generation] - - -- Increment counts for what regs were read/written from. - let (RU read written) = regUsageOfInstr platform instr - mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read - mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written - - -- Compute liveness for entry to next instruction. - let liveDieRead_virt = takeVirtuals (liveDieRead live) - let liveDieWrite_virt = takeVirtuals (liveDieWrite live) - let liveBorn_virt = takeVirtuals (liveBorn live) - - let rsLiveAcross - = rsLiveEntry `minusUniqSet` liveDieRead_virt - - let rsLiveNext - = (rsLiveAcross `unionUniqSets` liveBorn_virt) - `minusUniqSet` liveDieWrite_virt - - countLIs scale rsLiveNext lis - - incDefs count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0) - incUses count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0) - incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1) - - blockFreq :: Maybe (LabelMap Double) -> Label -> Double - blockFreq freqs bid - | Just freq <- join (mapLookup bid <$> freqs) - = max 1.0 (10000 * freq) - | otherwise - = 1.0 -- Only if no cfg given - --- | Take all the virtual registers from this set. -takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg -takeVirtuals set = mkUniqSet - [ vr | RegVirtual vr <- nonDetEltsUniqSet set ] - -- See Note [Unique Determinism and code generation] - - --- | Choose a node to spill from this graph -chooseSpill - :: SpillCostInfo - -> Graph VirtualReg RegClass RealReg - -> VirtualReg - -chooseSpill info graph - = let cost = spillCost_length info graph - node = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2)) - $ nonDetEltsUFM $ graphMap graph - -- See Note [Unique Determinism and code generation] - - in nodeId node - - -------------------------------------------------------------------------------- --- | Chaitins spill cost function is: --- --- cost = sum loadCost * freq (u) + sum storeCost * freq (d) --- u <- uses (v) d <- defs (v) --- --- There are no loops in our code at the moment, so we can set the freq's to 1. --- --- If we don't have live range splitting then Chaitins function performs badly --- if we have lots of nested live ranges and very few registers. --- --- v1 v2 v3 --- def v1 . --- use v1 . --- def v2 . . --- def v3 . . . --- use v1 . . . --- use v3 . . . --- use v2 . . --- use v1 . --- --- defs uses degree cost --- v1: 1 3 3 1.5 --- v2: 1 2 3 1.0 --- v3: 1 1 3 0.666 --- --- v3 has the lowest cost, but if we only have 2 hardregs and we insert --- spill code for v3 then this isn't going to improve the colorability of --- the graph. --- --- When compiling SHA1, which as very long basic blocks and some vregs --- with very long live ranges the allocator seems to try and spill from --- the inside out and eventually run out of stack slots. --- --- Without live range splitting, its's better to spill from the outside --- in so set the cost of very long live ranges to zero --- - --- spillCost_chaitin --- :: SpillCostInfo --- -> Graph VirtualReg RegClass RealReg --- -> VirtualReg --- -> Float - --- spillCost_chaitin info graph reg --- -- Spilling a live range that only lives for 1 instruction --- -- isn't going to help us at all - and we definitely want to avoid --- -- trying to re-spill previously inserted spill code. --- | lifetime <= 1 = 1/0 - --- -- It's unlikely that we'll find a reg for a live range this long --- -- better to spill it straight up and not risk trying to keep it around --- -- and have to go through the build/color cycle again. - --- -- To facility this we scale down the spill cost of long ranges. --- -- This makes sure long ranges are still spilled first. --- -- But this way spill cost remains relevant for long live --- -- ranges. --- | lifetime >= 128 --- = (spillCost / conflicts) / 10.0 - - --- -- Otherwise revert to chaitin's regular cost function. --- | otherwise = (spillCost / conflicts) --- where --- !spillCost = fromIntegral (uses + defs) :: Float --- conflicts = fromIntegral (nodeDegree classOfVirtualReg graph reg) --- (_, defs, uses, lifetime) --- = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg - - --- Just spill the longest live range. -spillCost_length - :: SpillCostInfo - -> Graph VirtualReg RegClass RealReg - -> VirtualReg - -> Float - -spillCost_length info _ reg - | lifetime <= 1 = 1/0 - | otherwise = 1 / fromIntegral lifetime - where (_, _, _, lifetime) - = fromMaybe (reg, 0, 0, 0) - $ lookupUFM info reg - - --- | Extract a map of register lifetimes from a `SpillCostInfo`. -lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int) -lifeMapFromSpillCostInfo info - = listToUFM - $ map (\(r, _, _, life) -> (r, (r, life))) - $ nonDetEltsUFM info - -- See Note [Unique Determinism and code generation] - - --- | Determine the degree (number of neighbors) of this node which --- have the same class. -nodeDegree - :: (VirtualReg -> RegClass) - -> Graph VirtualReg RegClass RealReg - -> VirtualReg - -> Int - -nodeDegree classOfVirtualReg graph reg - | Just node <- lookupUFM (graphMap graph) reg - - , virtConflicts - <- length - $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg) - $ nonDetEltsUniqSet - -- See Note [Unique Determinism and code generation] - $ nodeConflicts node - - = virtConflicts + sizeUniqSet (nodeExclusions node) - - | otherwise - = 0 - - --- | Show a spill cost record, including the degree from the graph --- and final calculated spill cost. -pprSpillCostRecord - :: (VirtualReg -> RegClass) - -> (Reg -> SDoc) - -> Graph VirtualReg RegClass RealReg - -> SpillCostRecord - -> SDoc - -pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) - = hsep - [ pprReg (RegVirtual reg) - , ppr uses - , ppr defs - , ppr life - , ppr $ nodeDegree regClass graph reg - , text $ show $ (fromIntegral (uses + defs) - / fromIntegral (nodeDegree regClass graph reg) :: Float) ] - diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs deleted file mode 100644 index 2159548437..0000000000 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- | Carries interesting info for debugging / profiling of the --- graph coloring register allocator. -module RegAlloc.Graph.Stats ( - RegAllocStats (..), - - pprStats, - pprStatsSpills, - pprStatsLifetimes, - pprStatsConflict, - pprStatsLifeConflict, - - countSRMs, addSRM -) where - -import GhcPrelude - -import qualified GraphColor as Color -import RegAlloc.Liveness -import RegAlloc.Graph.Spill -import RegAlloc.Graph.SpillCost -import RegAlloc.Graph.TrivColorable -import Instruction -import RegClass -import Reg -import TargetReg - -import Outputable -import UniqFM -import UniqSet -import State - --- | Holds interesting statistics from the register allocator. -data RegAllocStats statics instr - - -- Information about the initial conflict graph. - = RegAllocStatsStart - { -- | Initial code, with liveness. - raLiveCmm :: [LiveCmmDecl statics instr] - - -- | The initial, uncolored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg - - -- | Information to help choose which regs to spill. - , raSpillCosts :: SpillCostInfo } - - - -- Information about an intermediate graph. - -- This is one that we couldn't color, so had to insert spill code - -- instruction stream. - | RegAllocStatsSpill - { -- | Code we tried to allocate registers for. - raCode :: [LiveCmmDecl statics instr] - - -- | Partially colored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg - - -- | The regs that were coalesced. - , raCoalesced :: UniqFM VirtualReg - - -- | Spiller stats. - , raSpillStats :: SpillStats - - -- | Number of instructions each reg lives for. - , raSpillCosts :: SpillCostInfo - - -- | Code with spill instructions added. - , raSpilled :: [LiveCmmDecl statics instr] } - - - -- a successful coloring - | RegAllocStatsColored - { -- | Code we tried to allocate registers for. - raCode :: [LiveCmmDecl statics instr] - - -- | Uncolored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg - - -- | Coalesced and colored graph. - , raGraphColored :: Color.Graph VirtualReg RegClass RealReg - - -- | Regs that were coalesced. - , raCoalesced :: UniqFM VirtualReg - - -- | Code with coalescings applied. - , raCodeCoalesced :: [LiveCmmDecl statics instr] - - -- | Code with vregs replaced by hregs. - , raPatched :: [LiveCmmDecl statics instr] - - -- | Code with unneeded spill\/reloads cleaned out. - , raSpillClean :: [LiveCmmDecl statics instr] - - -- | Final code. - , raFinal :: [NatCmmDecl statics instr] - - -- | Spill\/reload\/reg-reg moves present in this code. - , raSRMs :: (Int, Int, Int) } - - -instance (Outputable statics, Outputable instr) - => Outputable (RegAllocStats statics instr) where - - ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform -> - text "# Start" - $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) - $$ text "" - $$ text "# Initial register conflict graph." - $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - (raGraph s) - - - ppr (s@RegAllocStatsSpill{}) = - text "# Spill" - - $$ text "# Code with liveness information." - $$ ppr (raCode s) - $$ text "" - - $$ (if (not $ isNullUFM $ raCoalesced s) - then text "# Registers coalesced." - $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) - $$ text "" - else empty) - - $$ text "# Spills inserted." - $$ ppr (raSpillStats s) - $$ text "" - - $$ text "# Code with spills inserted." - $$ ppr (raSpilled s) - - - ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) - = sdocWithPlatform $ \platform -> - text "# Colored" - - $$ text "# Code with liveness information." - $$ ppr (raCode s) - $$ text "" - - $$ text "# Register conflict graph (colored)." - $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - (raGraphColored s) - $$ text "" - - $$ (if (not $ isNullUFM $ raCoalesced s) - then text "# Registers coalesced." - $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr) - $$ text "" - else empty) - - $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) - $$ text "" - - $$ text "# Native code after register allocation." - $$ ppr (raPatched s) - $$ text "" - - $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) - $$ text "" - - $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) - $$ text "" - $$ text "# Score:" - $$ (text "# spills inserted: " <> int spills) - $$ (text "# reloads inserted: " <> int reloads) - $$ (text "# reg-reg moves remaining: " <> int moves) - $$ text "" - - --- | Do all the different analysis on this list of RegAllocStats -pprStats - :: [RegAllocStats statics instr] - -> Color.Graph VirtualReg RegClass RealReg - -> SDoc - -pprStats stats graph - = let outSpills = pprStatsSpills stats - outLife = pprStatsLifetimes stats - outConflict = pprStatsConflict stats - outScatter = pprStatsLifeConflict stats graph - - in vcat [outSpills, outLife, outConflict, outScatter] - - --- | Dump a table of how many spill loads \/ stores were inserted for each vreg. -pprStatsSpills - :: [RegAllocStats statics instr] -> SDoc - -pprStatsSpills stats - = let - finals = [ s | s@RegAllocStatsColored{} <- stats] - - -- sum up how many stores\/loads\/reg-reg-moves were left in the code - total = foldl' addSRM (0, 0, 0) - $ map raSRMs finals - - in ( text "-- spills-added-total" - $$ text "-- (stores, loads, reg_reg_moves_remaining)" - $$ ppr total - $$ text "") - - --- | Dump a table of how long vregs tend to live for in the initial code. -pprStatsLifetimes - :: [RegAllocStats statics instr] -> SDoc - -pprStatsLifetimes stats - = let info = foldl' plusSpillCostInfo zeroSpillCostInfo - [ raSpillCosts s - | s@RegAllocStatsStart{} <- stats ] - - lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info - - in ( text "-- vreg-population-lifetimes" - $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)" - $$ pprUFM lifeBins (vcat . map ppr) - $$ text "\n") - - -binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int) -binLifetimeCount fm - = let lifes = map (\l -> (l, (l, 1))) - $ map snd - $ nonDetEltsUFM fm - -- See Note [Unique Determinism and code generation] - - in addListToUFM_C - (\(l1, c1) (_, c2) -> (l1, c1 + c2)) - emptyUFM - lifes - - --- | Dump a table of how many conflicts vregs tend to have in the initial code. -pprStatsConflict - :: [RegAllocStats statics instr] -> SDoc - -pprStatsConflict stats - = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) - emptyUFM - $ map Color.slurpNodeConflictCount - [ raGraph s | s@RegAllocStatsStart{} <- stats ] - - in ( text "-- vreg-conflicts" - $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)" - $$ pprUFM confMap (vcat . map ppr) - $$ text "\n") - - --- | For every vreg, dump how many conflicts it has, and its lifetime. --- Good for making a scatter plot. -pprStatsLifeConflict - :: [RegAllocStats statics instr] - -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph - -> SDoc - -pprStatsLifeConflict stats graph - = let lifeMap = lifeMapFromSpillCostInfo - $ foldl' plusSpillCostInfo zeroSpillCostInfo - $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ] - - scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of - Just (_, l) -> l - Nothing -> 0 - Just node = Color.lookupNode graph r - in parens $ hcat $ punctuate (text ", ") - [ doubleQuotes $ ppr $ Color.nodeId node - , ppr $ sizeUniqSet (Color.nodeConflicts node) - , ppr $ lifetime ]) - $ map Color.nodeId - $ nonDetEltsUFM - -- See Note [Unique Determinism and code generation] - $ Color.graphMap graph - - in ( text "-- vreg-conflict-lifetime" - $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)" - $$ (vcat scatter) - $$ text "\n") - - --- | Count spill/reload/reg-reg moves. --- Lets us see how well the register allocator has done. -countSRMs - :: Instruction instr - => LiveCmmDecl statics instr -> (Int, Int, Int) - -countSRMs cmm - = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) - - -countSRM_block - :: Instruction instr - => GenBasicBlock (LiveInstr instr) - -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) - -countSRM_block (BasicBlock i instrs) - = do instrs' <- mapM countSRM_instr instrs - return $ BasicBlock i instrs' - - -countSRM_instr - :: Instruction instr - => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr) - -countSRM_instr li - | LiveInstr SPILL{} _ <- li - = do modify $ \(s, r, m) -> (s + 1, r, m) - return li - - | LiveInstr RELOAD{} _ <- li - = do modify $ \(s, r, m) -> (s, r + 1, m) - return li - - | LiveInstr instr _ <- li - , Just _ <- takeRegRegMoveInstr instr - = do modify $ \(s, r, m) -> (s, r, m + 1) - return li - - | otherwise - = return li - - --- sigh.. -addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int) -addSRM (s1, r1, m1) (s2, r2, m2) - = let !s = s1 + s2 - !r = r1 + r2 - !m = m1 + m2 - in (s, r, m) - diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs deleted file mode 100644 index cc2ad7d594..0000000000 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE CPP #-} - -module RegAlloc.Graph.TrivColorable ( - trivColorable, -) - -where - -#include "HsVersions.h" - -import GhcPrelude - -import RegClass -import Reg - -import GraphBase - -import UniqSet -import GHC.Platform -import Panic - --- trivColorable --------------------------------------------------------------- - --- trivColorable function for the graph coloring allocator --- --- This gets hammered by scanGraph during register allocation, --- so needs to be fairly efficient. --- --- NOTE: This only works for architectures with just RcInteger and RcDouble --- (which are disjoint) ie. x86, x86_64 and ppc --- --- The number of allocatable regs is hard coded in here so we can do --- a fast comparison in trivColorable. --- --- It's ok if these numbers are _less_ than the actual number of free --- regs, but they can't be more or the register conflict --- graph won't color. --- --- If the graph doesn't color then the allocator will panic, but it won't --- generate bad object code or anything nasty like that. --- --- There is an allocatableRegsInClass :: RegClass -> Int, but doing --- the unboxing is too slow for us here. --- TODO: Is that still true? Could we use allocatableRegsInClass --- without losing performance now? --- --- Look at includes/stg/MachRegs.h to get the numbers. --- - - --- Disjoint registers ---------------------------------------------------------- --- --- The definition has been unfolded into individual cases for speed. --- Each architecture has a different register setup, so we use a --- different regSqueeze function for each. --- -accSqueeze - :: Int - -> Int - -> (reg -> Int) - -> UniqSet reg - -> Int - -accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us) - -- See Note [Unique Determinism and code generation] - where acc count [] = count - acc count _ | count >= maxCount = count - acc count (r:rs) = acc (count + squeeze r) rs - -{- Note [accSqueeze] -~~~~~~~~~~~~~~~~~~~~ -BL 2007/09 -Doing a nice fold over the UniqSet makes trivColorable use -32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs. -Therefore the UniqFM is made non-abstract and we use custom fold. - -MS 2010/04 -When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal -representation any more. But it is imperative that the accSqueeze stops -the folding if the count gets greater or equal to maxCount. We thus convert -UniqFM to a (lazy) list, do the fold and stops if necessary, which was -the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows. -(original = previous implementation, folding = fold of the whole UFM, - lazyFold = the current implementation, - hackFold = using internal representation of Data.IntMap) - - original folding hackFold lazyFold - -O -fasm (used everywhere) 31.509s 30.387s 30.791s 30.603s - 100.00% 96.44% 97.72% 97.12% - -fregs-graph 67.938s 74.875s 62.673s 64.679s - 100.00% 110.21% 92.25% 95.20% - -fregs-iterative 89.761s 143.913s 81.075s 86.912s - 100.00% 160.33% 90.32% 96.83% - -fnew-codegen 38.225s 37.142s 37.551s 37.119s - 100.00% 97.17% 98.24% 97.11% - -fnew-codegen -fregs-graph 91.786s 91.51s 87.368s 86.88s - 100.00% 99.70% 95.19% 94.65% - -fnew-codegen -fregs-iterative 206.72s 343.632s 194.694s 208.677s - 100.00% 166.23% 94.18% 100.95% --} - -trivColorable - :: Platform - -> (RegClass -> VirtualReg -> Int) - -> (RegClass -> RealReg -> Int) - -> Triv VirtualReg RegClass RealReg - -trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions - | let cALLOCATABLE_REGS_INTEGER - = (case platformArch platform of - ArchX86 -> 3 - ArchX86_64 -> 5 - ArchPPC -> 16 - ArchSPARC -> 14 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 15 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchS390X -> panic "trivColorable ArchS390X" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER - (virtualRegSqueeze RcInteger) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_INTEGER - (realRegSqueeze RcInteger) - exclusions - - = count3 < cALLOCATABLE_REGS_INTEGER - -trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions - | let cALLOCATABLE_REGS_FLOAT - = (case platformArch platform of - -- On x86_64 and x86, Float and RcDouble - -- use the same registers, - -- so we only use RcDouble to represent the - -- register allocation problem on those types. - ArchX86 -> 0 - ArchX86_64 -> 0 - ArchPPC -> 0 - ArchSPARC -> 22 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 0 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchS390X -> panic "trivColorable ArchS390X" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT - (virtualRegSqueeze RcFloat) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_FLOAT - (realRegSqueeze RcFloat) - exclusions - - = count3 < cALLOCATABLE_REGS_FLOAT - -trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions - | let cALLOCATABLE_REGS_DOUBLE - = (case platformArch platform of - ArchX86 -> 8 - -- in x86 32bit mode sse2 there are only - -- 8 XMM registers xmm0 ... xmm7 - ArchX86_64 -> 10 - -- in x86_64 there are 16 XMM registers - -- xmm0 .. xmm15, here 10 is a - -- "dont need to solve conflicts" count that - -- was chosen at some point in the past. - ArchPPC -> 26 - ArchSPARC -> 11 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" - ArchPPC_64 _ -> 20 - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" - ArchMipseb -> panic "trivColorable ArchMipseb" - ArchMipsel -> panic "trivColorable ArchMipsel" - ArchS390X -> panic "trivColorable ArchS390X" - ArchJavaScript-> panic "trivColorable ArchJavaScript" - ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE - (virtualRegSqueeze RcDouble) - conflicts - - , count3 <- accSqueeze count2 cALLOCATABLE_REGS_DOUBLE - (realRegSqueeze RcDouble) - exclusions - - = count3 < cALLOCATABLE_REGS_DOUBLE - - - - --- Specification Code ---------------------------------------------------------- --- --- The trivColorable function for each particular architecture should --- implement the following function, but faster. --- - -{- -trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool -trivColorable classN conflicts exclusions - = let - - acc :: Reg -> (Int, Int) -> (Int, Int) - acc r (cd, cf) - = case regClass r of - RcInteger -> (cd+1, cf) - RcFloat -> (cd, cf+1) - _ -> panic "Regs.trivColorable: reg class not handled" - - tmp = nonDetFoldUFM acc (0, 0) conflicts - (countInt, countFloat) = nonDetFoldUFM acc tmp exclusions - - squeese = worst countInt classN RcInteger - + worst countFloat classN RcFloat - - in squeese < allocatableRegsInClass classN - --- | Worst case displacement --- node N of classN has n neighbors of class C. --- --- We currently only have RcInteger and RcDouble, which don't conflict at all. --- This is a bit boring compared to what's in RegArchX86. --- -worst :: Int -> RegClass -> RegClass -> Int -worst n classN classC - = case classN of - RcInteger - -> case classC of - RcInteger -> min n (allocatableRegsInClass RcInteger) - RcFloat -> 0 - - RcDouble - -> case classC of - RcFloat -> min n (allocatableRegsInClass RcFloat) - RcInteger -> 0 - --- allocatableRegs is allMachRegNos with the fixed-use regs removed. --- i.e., these are the regs for which we are prepared to allow the --- register allocator to attempt to map VRegs to. -allocatableRegs :: [RegNo] -allocatableRegs - = let isFree i = freeReg i - in filter isFree allMachRegNos - - --- | The number of regs in each class. --- We go via top level CAFs to ensure that we're not recomputing --- the length of these lists each time the fn is called. -allocatableRegsInClass :: RegClass -> Int -allocatableRegsInClass cls - = case cls of - RcInteger -> allocatableRegsInteger - RcFloat -> allocatableRegsDouble - -allocatableRegsInteger :: Int -allocatableRegsInteger - = length $ filter (\r -> regClass r == RcInteger) - $ map RealReg allocatableRegs - -allocatableRegsFloat :: Int -allocatableRegsFloat - = length $ filter (\r -> regClass r == RcFloat - $ map RealReg allocatableRegs --} |