diff options
Diffstat (limited to 'compiler/nativeGen/RegAlloc')
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/Main.hs | 146 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/Spill.hs | 6 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/SpillClean.hs | 5 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/SpillCost.hs | 71 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/Stats.hs | 40 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs | 253 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/Base.hs | 8 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs | 13 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/Main.hs | 425 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs | 210 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs | 2 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Liveness.hs | 5 |
12 files changed, 681 insertions, 503 deletions
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 2e584617e9..94b18aeb0a 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -11,6 +11,7 @@ module RegAlloc.Graph.Main ( where import qualified GraphColor as Color +import qualified GraphBase as Color import RegAlloc.Liveness import RegAlloc.Graph.Spill import RegAlloc.Graph.SpillClean @@ -47,7 +48,7 @@ maxSpinCount = 10 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 +60,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 +72,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 +99,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 +136,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 @@ -225,7 +242,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code buildGraph :: Instruction instr => [LiveCmmTop instr] - -> UniqSM (Color.Graph Reg RegClass Reg) + -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code = do @@ -252,19 +269,20 @@ buildGraph code -- 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 @@ -274,26 +292,33 @@ graphAddConflictSet set graph -- 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 - | otherwise - = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph + | RegVirtual vr1 <- r1 + , RegVirtual vr2 <- r2 + = Color.addCoalesce + (vr1, classOfVirtualReg vr1) + (vr2, classOfVirtualReg vr2) + graph - where regWithClass r = (r, targetRegClass r) + | otherwise + = panic "RegAlloc.Graph.Main.graphAddCoalesce: can't coalesce two real regs" -- | 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 +326,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,34 +354,39 @@ 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 + = 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 = case reg of - RealReg _ -> () VirtualRegI _ -> () VirtualRegHi _ -> () VirtualRegF _ -> () VirtualRegD _ -> () +seqRealReg :: RealReg -> () +seqRealReg reg + = case reg of + RealRegSingle _ -> () + RealRegPair _ _ -> () + seqRegClass :: RegClass -> () seqRegClass c = case c of @@ -358,17 +394,23 @@ seqRegClass c RcFloat -> () RcDouble -> () -seqMaybeReg :: Maybe Reg -> () -seqMaybeReg mr +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 diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index e6e5622a02..ce34b513a1 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -37,7 +37,7 @@ regSpill :: Instruction instr => [LiveCmmTop instr] -- ^ the code -> UniqSet Int -- ^ available stack slots - -> UniqSet Reg -- ^ the regs to spill + -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM ([LiveCmmTop instr] -- code will spill instructions , UniqSet Int -- left over slots @@ -190,7 +190,9 @@ patchInstr patchInstr reg instr = do nUnique <- newUnique - let nReg = renameVirtualReg nUnique reg + 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) diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 4f129c468a..9d0dcf9236 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -436,9 +436,12 @@ isStoreReg ss -- instance Uniquable Store where getUnique (SReg r) - | RealReg i <- r + | RegReal (RealRegSingle i) <- r = mkUnique 'R' i + | RegReal (RealRegPair r1 r2) <- r + = mkUnique 'P' (r1 * 65535 + r2) + | otherwise = error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected." diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index d4dd75a4b7..ff3f76a545 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -36,10 +36,10 @@ import Data.Maybe import Control.Monad type SpillCostRecord - = ( Reg -- 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 + = ( 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 type SpillCostInfo = UniqFM SpillCostRecord @@ -83,7 +83,11 @@ slurpSpillCostInfo cmm countBlock info (BasicBlock blockId instrs) | LiveInfo _ _ blockLive <- info , Just rsLiveEntry <- lookupBlockEnv blockLive blockId - = countLIs rsLiveEntry instrs + + , rsLiveEntry_virt <- mapUniqSet (\(RegVirtual vr) -> vr) + $ filterUniqSet isVirtualReg rsLiveEntry + + = countLIs rsLiveEntry_virt instrs | otherwise = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block" @@ -113,16 +117,24 @@ slurpSpillCostInfo cmm -- increment counts for what regs were read/written from let (RU read written) = regUsageOfInstr instr - mapM_ incUses $ filter (not . isRealReg) $ nub read - mapM_ incDefs $ filter (not . isRealReg) $ nub written + mapM_ incUses $ catMaybes $ map takeVirtualReg $ nub read + mapM_ incDefs $ catMaybes $ map takeVirtualReg $ nub written -- compute liveness for entry to next instruction. + let takeVirtuals set + = mapUniqSet (\(RegVirtual vr) -> vr) + $ filterUniqSet isVirtualReg set + + let liveDieRead_virt = takeVirtuals (liveDieRead live) + let liveDieWrite_virt = takeVirtuals (liveDieWrite live) + let liveBorn_virt = takeVirtuals (liveBorn live) + let rsLiveAcross - = rsLiveEntry `minusUniqSet` (liveDieRead live) + = rsLiveEntry `minusUniqSet` liveDieRead_virt let rsLiveNext - = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) + = (rsLiveAcross `unionUniqSets` liveBorn_virt) + `minusUniqSet` liveDieWrite_virt countLIs rsLiveNext lis @@ -135,8 +147,8 @@ slurpSpillCostInfo cmm chooseSpill :: SpillCostInfo - -> Graph Reg RegClass Reg - -> Reg + -> Graph VirtualReg RegClass RealReg + -> VirtualReg chooseSpill info graph = let cost = spillCost_length info graph @@ -212,19 +224,20 @@ spillCost_chaitin info graph reg -- Just spill the longest live range. spillCost_length :: SpillCostInfo - -> Graph Reg RegClass Reg - -> Reg + -> 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 + = fromMaybe (reg, 0, 0, 0) + $ lookupUFM info reg -lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (Reg, Int) +lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int) lifeMapFromSpillCostInfo info = listToUFM $ map (\(r, _, _, life) -> (r, (r, life))) @@ -233,13 +246,19 @@ lifeMapFromSpillCostInfo info -- | Work out the degree (number of neighbors) of this node which have the same class. nodeDegree - :: (Reg -> RegClass) - -> Graph Reg RegClass Reg -> Reg -> Int + :: (VirtualReg -> RegClass) + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + -> Int -nodeDegree regClass graph reg +nodeDegree classOfVirtualReg graph reg | Just node <- lookupUFM (graphMap graph) reg - , virtConflicts <- length $ filter (\r -> regClass r == regClass reg) - $ uniqSetToList $ nodeConflicts node + + , virtConflicts <- length + $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg) + $ uniqSetToList + $ nodeConflicts node + = virtConflicts + sizeUniqSet (nodeExclusions node) | otherwise @@ -248,16 +267,20 @@ nodeDegree regClass graph reg -- | Show a spill cost record, including the degree from the graph and final calulated spill cos pprSpillCostRecord - :: (Reg -> RegClass) + :: (VirtualReg -> RegClass) -> (Reg -> SDoc) - -> Graph Reg RegClass Reg -> SpillCostRecord -> SDoc + -> Graph VirtualReg RegClass RealReg + -> SpillCostRecord + -> SDoc pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) = hsep - [ pprReg reg + [ 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 index 5e3dd3265b..10ab0cbcfb 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -39,27 +39,27 @@ data RegAllocStats instr -- initial graph = RegAllocStatsStart - { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness - , raGraph :: Color.Graph Reg RegClass Reg -- ^ the initial, uncolored graph - , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill + { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness + , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph + , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill -- a spill stage | RegAllocStatsSpill - { raGraph :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph - , raCoalesced :: UniqFM Reg -- ^ the regs that were coaleced - , raSpillStats :: SpillStats -- ^ spiller stats - , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for - , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added + { raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph + , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced + , raSpillStats :: SpillStats -- ^ spiller stats + , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for + , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added -- a successful coloring | RegAllocStatsColored - { raGraph :: Color.Graph Reg RegClass Reg -- ^ the uncolored graph - , raGraphColored :: Color.Graph Reg RegClass Reg -- ^ the coalesced and colored graph - , raCoalesced :: UniqFM Reg -- ^ the regs that were coaleced - , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs - , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out - , raFinal :: [NatCmmTop instr] -- ^ final code - , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code + { raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph + , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph + , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced + , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs + , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out + , raFinal :: [NatCmmTop instr] -- ^ final code + , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code instance Outputable instr => Outputable (RegAllocStats instr) where @@ -132,7 +132,11 @@ instance Outputable instr => Outputable (RegAllocStats instr) where $$ text "" -- | Do all the different analysis on this list of RegAllocStats -pprStats :: [RegAllocStats instr] -> Color.Graph Reg RegClass Reg -> SDoc +pprStats + :: [RegAllocStats instr] + -> Color.Graph VirtualReg RegClass RealReg + -> SDoc + pprStats stats graph = let outSpills = pprStatsSpills stats outLife = pprStatsLifetimes stats @@ -176,7 +180,7 @@ pprStatsLifetimes stats $$ (vcat $ map ppr $ eltsUFM lifeBins) $$ text "\n") -binLifetimeCount :: UniqFM (Reg, Int) -> UniqFM (Int, Int) +binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int) binLifetimeCount fm = let lifes = map (\l -> (l, (l, 1))) $ map snd @@ -208,7 +212,7 @@ pprStatsConflict stats -- good for making a scatter plot. pprStatsLifeConflict :: [RegAllocStats instr] - -> Color.Graph Reg RegClass Reg -- ^ global register conflict graph + -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph -> SDoc pprStatsLifeConflict stats graph diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index df04606313..5f3f0ac495 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-unused-binds #-} module RegAlloc.Graph.TrivColorable ( trivColorable, @@ -15,51 +16,136 @@ import GraphBase import UniqFM import FastTypes -{- --- 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 = isFastTrue (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 - RcDouble -> allocatableRegsDouble - RcFloat -> panic "Regs.allocatableRegsInClass: no match\n" - -allocatableRegsInteger :: Int -allocatableRegsInteger - = length $ filter (\r -> regClass r == RcInteger) - $ map RealReg allocatableRegs - -allocatableRegsDouble :: Int -allocatableRegsDouble - = length $ filter (\r -> regClass r == RcDouble) - $ map RealReg allocatableRegs --} - -- 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 arcitectures with just RcInteger and RcDouble -- (which are disjoint) ie. x86, x86_64 and ppc -- - -- 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.lhs from darcs. +-- +-- The number of allocatable regs is hard coded here so we can do a fast +-- comparision 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. +-- +-- Look at includes/MachRegs.h to get these numbers. +-- + +#if i386_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER (_ILIT(3)) +#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6)) +#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) + + +#elif x86_64_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER (_ILIT(5)) +#define ALLOCATABLE_REGS_DOUBLE (_ILIT(2)) +#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) + + +#elif powerpc_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER (_ILIT(16)) +#define ALLOCATABLE_REGS_DOUBLE (_ILIT(26)) +#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) + + +#elif sparc_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER (_ILIT(14)) +#define ALLOCATABLE_REGS_DOUBLE (_ILIT(11)) +#define ALLOCATABLE_REGS_FLOAT (_ILIT(22)) + + +#else +#error ToDo: choose which trivColorable function to use for this architecture. +#endif + + + +-- 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 + :: FastInt + -> FastInt + -> (reg -> FastInt) + -> UniqFM reg + -> FastInt + +accSqueeze count maxCount squeeze ufm + = case ufm of + NodeUFM _ _ left right + -> case accSqueeze count maxCount squeeze right of + count' -> case count' >=# maxCount of + False -> accSqueeze count' maxCount squeeze left + True -> count' + + LeafUFM _ reg -> count +# squeeze reg + EmptyUFM -> count + + +trivColorable + :: (RegClass -> VirtualReg -> FastInt) + -> (RegClass -> RealReg -> FastInt) + -> Triv VirtualReg RegClass RealReg + +trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions + | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_INTEGER + (virtualRegSqueeze RcInteger) + conflicts + + , count3 <- accSqueeze count2 ALLOCATABLE_REGS_INTEGER + (realRegSqueeze RcInteger) + exclusions + + = count3 <# ALLOCATABLE_REGS_INTEGER + +trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions + | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_FLOAT + (virtualRegSqueeze RcFloat) + conflicts + + , count3 <- accSqueeze count2 ALLOCATABLE_REGS_FLOAT + (realRegSqueeze RcFloat) + exclusions + + = count3 <# ALLOCATABLE_REGS_FLOAT + +trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions + | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_DOUBLE + (virtualRegSqueeze RcDouble) + conflicts + + , count3 <- accSqueeze count2 ALLOCATABLE_REGS_DOUBLE + (realRegSqueeze RcDouble) + exclusions + + = count3 <# ALLOCATABLE_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 @@ -69,14 +155,14 @@ trivColorable classN conflicts exclusions acc r (cd, cf) = case regClass r of RcInteger -> (cd+1, cf) - RcDouble -> (cd, cf+1) + RcFloat -> (cd, cf+1) _ -> panic "Regs.trivColorable: reg class not handled" tmp = foldUniqSet acc (0, 0) conflicts (countInt, countFloat) = foldUniqSet acc tmp exclusions squeese = worst countInt classN RcInteger - + worst countFloat classN RcDouble + + worst countFloat classN RcFloat in squeese < allocatableRegsInClass classN @@ -92,85 +178,38 @@ worst n classN classC RcInteger -> case classC of RcInteger -> min n (allocatableRegsInClass RcInteger) - RcDouble -> 0 + RcFloat -> 0 RcDouble -> case classC of - RcDouble -> min n (allocatableRegsInClass RcDouble) + RcFloat -> min n (allocatableRegsInClass RcFloat) RcInteger -> 0 --} - --- The number of allocatable regs is hard coded here so we can do a fast comparision --- 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. --- --- There is an allocatableRegsInClass :: RegClass -> Int, but doing the unboxing --- is too slow for us here. --- --- Compare Regs.freeRegs and MachRegs.h to get these numbers. --- -#if i386_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(3)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) - -#elif x86_64_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(5)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(2)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(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 = isFastTrue (freeReg i) + in filter isFree allMachRegNos -#elif powerpc_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(16)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(26)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) -#elif sparc_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(14)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(8)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(6)) +-- | 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 -#else -#error ToDo: define ALLOCATABLE_REGS_INTEGER and ALLOCATABLE_REGS_DOUBLE -#endif +allocatableRegsInteger :: Int +allocatableRegsInteger + = length $ filter (\r -> regClass r == RcInteger) + $ map RealReg allocatableRegs -trivColorable - :: (Reg -> RegClass) - -> Triv Reg RegClass Reg - -trivColorable regClass _ conflicts exclusions - = {-# SCC "trivColorable" #-} - let - isSqueesed cI cF ufm - = case ufm of - NodeUFM _ _ left right - -> case isSqueesed cI cF right of - (# s, cI', cF' #) - -> case s of - False -> isSqueesed cI' cF' left - True -> (# True, cI', cF' #) - - LeafUFM _ reg - -> case regClass reg of - RcInteger - -> case cI +# _ILIT(1) of - cI' -> (# cI' >=# ALLOCATABLE_REGS_INTEGER, cI', cF #) - - RcDouble - -> case cF +# _ILIT(1) of - cF' -> (# cF' >=# ALLOCATABLE_REGS_DOUBLE, cI, cF' #) - - RcFloat - -> case cF +# _ILIT(1) of - cF' -> (# cF' >=# ALLOCATABLE_REGS_FLOAT, cI, cF' #) - - EmptyUFM - -> (# False, cI, cF #) - - in case isSqueesed (_ILIT(0)) (_ILIT(0)) conflicts of - (# False, cI', cF' #) - -> case isSqueesed cI' cF' exclusions of - (# s, _, _ #) -> not s - - (# True, _, _ #) - -> False +allocatableRegsFloat :: Int +allocatableRegsFloat + = length $ filter (\r -> regClass r == RcFloat + $ map RealReg allocatableRegs +-} diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs index 45fd640804..26262327c9 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Base.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs @@ -51,14 +51,14 @@ type BlockAssignment -- data Loc -- | vreg is in a register - = InReg {-# UNPACK #-} !RegNo + = InReg {-# UNPACK #-} !RealReg -- | vreg is held in a stack slot - | InMem {-# UNPACK #-} !StackSlot + | InMem {-# UNPACK #-} !StackSlot -- | vreg is held in both a register and a stack slot - | InBoth {-# UNPACK #-} !RegNo + | InBoth {-# UNPACK #-} !RealReg {-# UNPACK #-} !StackSlot deriving (Eq, Show, Ord) @@ -67,7 +67,7 @@ instance Outputable Loc where -- | Get the reg numbers stored in this Loc. -regsOfLoc :: Loc -> [RegNo] +regsOfLoc :: Loc -> [RealReg] regsOfLoc (InReg r) = [r] regsOfLoc (InBoth r _) = [r] regsOfLoc (InMem _) = [] diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index 7d2cbcd7a7..8ff06eb886 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -110,7 +110,8 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) -- this is the first time we jumped to this block. joinToTargets_first block_live new_blocks block_id instr dest dests - block_assig src_assig to_free + block_assig src_assig + (to_free :: [RealReg]) = do -- free up the regs that are not live on entry to this block. freeregs <- getFreeRegsR @@ -292,10 +293,10 @@ handleComponent delta instr = do -- spill the source into its slot (instrSpill, slot) - <- spillR (RealReg sreg) vreg + <- spillR (RegReal sreg) vreg -- reload into destination reg - instrLoad <- loadR (RealReg dreg) slot + instrLoad <- loadR (RegReal dreg) slot remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest) @@ -320,15 +321,15 @@ makeMove makeMove _ vreg (InReg src) (InReg dst) = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr (RealReg src) (RealReg dst) + return $ mkRegRegMoveInstr (RegReal src) (RegReal dst) makeMove delta vreg (InMem src) (InReg dst) = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr (RealReg dst) delta src + return $ mkLoadInstr (RegReal dst) delta src makeMove delta vreg (InReg src) (InMem dst) = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr (RealReg src) delta dst + return $ mkSpillInstr (RegReal src) delta dst -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share stack slots between vregs. diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 47529d2c96..00e01d7ebc 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -101,8 +101,6 @@ import RegAlloc.Liveness import Instruction import Reg --- import PprMach - import BlockId import Cmm hiding (RegSet) @@ -256,7 +254,9 @@ initBlock id -- no prior info about this block: assume everything is -- free and the assignment is empty. Nothing - -> do setFreeRegsR initFreeRegs + -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) + + setFreeRegsR initFreeRegs setAssigR emptyRegMap -- load info about register assignments leading into this block. @@ -330,7 +330,7 @@ raInsn block_live new_instrs id (Instr instr (Just live)) not (dst `elemUFM` assig), Just (InReg _) <- (lookupUFM assig src) -> do case src of - RealReg i -> setAssigR (addToUFM assig dst (InReg i)) + (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) -- if src is a fixed reg, then we just map dest to this -- reg in the assignment. src must be an allocatable reg, -- otherwise it wouldn't be in r_dying. @@ -361,27 +361,30 @@ raInsn _ _ _ instr genRaInsn block_live new_instrs block_id instr r_dying w_dying = case regUsageOfInstr instr of { RU read written -> - case partition isRealReg written of { (real_written1,virt_written) -> do - let - real_written = [ r | RealReg r <- real_written1 ] + let real_written = [ rr | (RegReal rr) <- written ] + let virt_written = [ vr | (RegVirtual vr) <- written ] - -- we don't need to do anything with real registers that are - -- only read by this instr. (the list is typically ~2 elements, - -- so using nub isn't a problem). - virt_read = nub (filter isVirtualReg read) - -- in + -- we don't need to do anything with real registers that are + -- only read by this instr. (the list is typically ~2 elements, + -- so using nub isn't a problem). + let virt_read = nub [ vr | (RegVirtual vr) <- read ] -- (a) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying - + clobber_saves <- saveClobberedTemps real_written r_dying -{- freeregs <- getFreeRegsR + -- debugging +{- freeregs <- getFreeRegsR assig <- getAssigR pprTrace "genRaInsn" - (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written - $$ text (show freeregs) $$ ppr assig) - $ do + (ppr instr + $$ text "r_dying = " <+> ppr r_dying + $$ text "w_dying = " <+> ppr w_dying + $$ text "virt_read = " <+> ppr virt_read + $$ text "virt_written = " <+> ppr virt_written + $$ text "freeregs = " <+> text (show freeregs) + $$ text "assig = " <+> ppr assig) + $ do -} -- (b), (c) allocate real regs for all regs read by this instruction. @@ -412,17 +415,20 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = let -- (i) Patch the instruction - patch_map = listToUFM [ (t,RealReg r) | - (t,r) <- zip virt_read r_allocd - ++ zip virt_written w_allocd ] + patch_map + = listToUFM + [ (t, RegReal r) + | (t, r) <- zip virt_read r_allocd + ++ zip virt_written w_allocd ] + + patched_instr + = patchRegsOfInstr adjusted_instr patchLookup - patched_instr = patchRegsOfInstr adjusted_instr patchLookup - patchLookup x = case lookupUFM patch_map x of - Nothing -> x - Just y -> y - -- in + patchLookup x + = case lookupUFM patch_map x of + Nothing -> x + Just y -> y --- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do -- (j) free up stack slots for dead spilled regs -- TODO (can't be bothered right now) @@ -443,7 +449,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = return (code, fixup_blocks) - }} + } -- ----------------------------------------------------------------------------- -- releaseRegs @@ -455,79 +461,103 @@ releaseRegs regs = do where loop _ free _ | free `seq` False = undefined loop assig free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs + loop assig free (RegReal rr : rs) = loop assig (releaseReg rr free) rs loop assig free (r:rs) = case lookupUFM assig r of Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs _other -> loop (delFromUFM assig r) free rs + -- ----------------------------------------------------------------------------- -- Clobber real registers -{- -For each temp in a register that is going to be clobbered: - - if the temp dies after this instruction, do nothing - - otherwise, put it somewhere safe (another reg if possible, - otherwise spill and record InBoth in the assignment). - -for allocateRegs on the temps *read*, - - clobbered regs are allocatable. +-- For each temp in a register that is going to be clobbered: +-- - if the temp dies after this instruction, do nothing +-- - otherwise, put it somewhere safe (another reg if possible, +-- otherwise spill and record InBoth in the assignment). +-- - for allocateRegs on the temps *read*, +-- - clobbered regs are allocatable. +-- +-- for allocateRegs on the temps *written*, +-- - clobbered regs are not allocatable. +-- +-- TODO: instead of spilling, try to copy clobbered +-- temps to another register if possible. +-- -for allocateRegs on the temps *written*, - - clobbered regs are not allocatable. --} saveClobberedTemps :: Instruction instr - => [RegNo] -- real registers clobbered by this instruction + => [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM [instr] -- return: instructions to spill any temps that will -- be clobbered. -saveClobberedTemps [] _ = return [] -- common case -saveClobberedTemps clobbered dying = do - assig <- getAssigR - let - to_spill = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig, - reg `elem` clobbered, - temp `notElem` map getUnique dying ] - -- in - (instrs,assig') <- clobber assig [] to_spill - setAssigR assig' - return instrs - where - clobber assig instrs [] = return (instrs,assig) - clobber assig instrs ((temp,reg):rest) - = do - --ToDo: copy it to another register if possible - (spill,slot) <- spillR (RealReg reg) temp - recordSpill (SpillClobber temp) - - let new_assign = addToUFM assig temp (InBoth reg slot) - clobber new_assign (spill : {- COMMENT (fsLit "spill clobber") : -} instrs) rest - -clobberRegs :: [RegNo] -> RegM () -clobberRegs [] = return () -- common case -clobberRegs clobbered = do - freeregs <- getFreeRegsR --- setFreeRegsR $! foldr grabReg freeregs clobbered - setFreeRegsR $! foldr allocateReg freeregs clobbered +saveClobberedTemps [] _ + = return [] - assig <- getAssigR - setAssigR $! clobber assig (ufmToList assig) - where - -- if the temp was InReg and clobbered, then we will have - -- saved it in saveClobberedTemps above. So the only case - -- we have to worry about here is InBoth. Note that this - -- also catches temps which were loaded up during allocation - -- of read registers, not just those saved in saveClobberedTemps. - clobber assig [] = assig - clobber assig ((temp, InBoth reg slot) : rest) - | reg `elem` clobbered - = clobber (addToUFM assig temp (InMem slot)) rest - clobber assig (_:rest) - = clobber assig rest +saveClobberedTemps clobbered dying + = do + assig <- getAssigR + let to_spill + = [ (temp,reg) + | (temp, InReg reg) <- ufmToList assig + , any (realRegsAlias reg) clobbered + , temp `notElem` map getUnique dying ] + + (instrs,assig') <- clobber assig [] to_spill + setAssigR assig' + return instrs + + where + clobber assig instrs [] + = return (instrs, assig) + + clobber assig instrs ((temp, reg) : rest) + = do + (spill, slot) <- spillR (RegReal reg) temp + + -- record why this reg was spilled for profiling + recordSpill (SpillClobber temp) + + let new_assign = addToUFM assig temp (InBoth reg slot) + + clobber new_assign (spill : instrs) rest + + + +-- | Mark all these regal regs as allocated, +-- and kick out their vreg assignments. +-- +clobberRegs :: [RealReg] -> RegM () +clobberRegs [] + = return () + +clobberRegs clobbered + = do + freeregs <- getFreeRegsR + setFreeRegsR $! foldr allocateReg freeregs clobbered + + assig <- getAssigR + setAssigR $! clobber assig (ufmToList assig) + + where + -- if the temp was InReg and clobbered, then we will have + -- saved it in saveClobberedTemps above. So the only case + -- we have to worry about here is InBoth. Note that this + -- also catches temps which were loaded up during allocation + -- of read registers, not just those saved in saveClobberedTemps. + + clobber assig [] + = assig + + clobber assig ((temp, InBoth reg slot) : rest) + | any (realRegsAlias reg) clobbered + = clobber (addToUFM assig temp (InMem slot)) rest + + clobber assig (_:rest) + = clobber assig rest -- ----------------------------------------------------------------------------- -- allocateRegsAndSpill @@ -542,126 +572,145 @@ clobberRegs clobbered = do allocateRegsAndSpill :: Instruction instr => Bool -- True <=> reading (load up spilled regs) - -> [Reg] -- don't push these out + -> [VirtualReg] -- don't push these out -> [instr] -- spill insns - -> [RegNo] -- real registers allocated (accum.) - -> [Reg] -- temps to allocate - -> RegM ([instr], [RegNo]) + -> [RealReg] -- real registers allocated (accum.) + -> [VirtualReg] -- temps to allocate + -> RegM ( [instr] + , [RealReg]) allocateRegsAndSpill _ _ spills alloc [] - = return (spills,reverse alloc) - -allocateRegsAndSpill reading keep spills alloc (r:rs) = do - assig <- getAssigR - case lookupUFM assig r of - -- case (1a): already in a register - Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignemnt to be - -- InReg, because the memory value is no longer valid. - -- NB2. This is why we must process written registers here, even if they - -- are also read by the same instruction. - Just (InBoth my_reg _) -> do - when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- Not already in a register, so we need to find a free one... - loc -> do - freeregs <- getFreeRegsR - - case getFreeRegs (targetRegClass r) freeregs of - - -- case (2): we have a free register - my_reg:_ -> {- pprTrace "alloc" (ppr r <+> ppr my_reg <+> ppr freeClass) $ -} - do - spills' <- loadTemp reading r loc my_reg spills - let new_loc - | Just (InMem slot) <- loc, reading = InBoth my_reg slot - | otherwise = InReg my_reg - setAssigR (addToUFM assig r $! new_loc) - setFreeRegsR $ allocateReg my_reg freeregs - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- case (3): we need to push something out to free up a register - [] -> do - let - keep' = map getUnique keep - candidates1 = [ (temp,reg,mem) - | (temp, InBoth reg mem) <- ufmToList assig, - temp `notElem` keep', targetRegClass (RealReg reg) == targetRegClass r ] - candidates2 = [ (temp,reg) - | (temp, InReg reg) <- ufmToList assig, - temp `notElem` keep', targetRegClass (RealReg reg) == targetRegClass r ] - -- in - ASSERT2(not (null candidates1 && null candidates2), - text (show freeregs) <+> ppr r <+> ppr assig) do - - case candidates1 of - - -- we have a temporary that is in both register and mem, - -- just free up its register for use. - -- - (temp,my_reg,slot):_ -> do - spills' <- loadTemp reading r loc my_reg spills - let - assig1 = addToUFM assig temp (InMem slot) - assig2 = addToUFM assig1 r (InReg my_reg) - -- in - setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- otherwise, we need to spill a temporary that currently - -- resides in a register. - - - [] -> do - - -- TODO: plenty of room for optimisation in choosing which temp - -- to spill. We just pick the first one that isn't used in - -- the current instruction for now. - - let (temp_to_push_out, my_reg) - = case candidates2 of - [] -> panic $ "RegAllocLinear.allocRegsAndSpill: no spill candidates" - ++ "assignment: " ++ show (ufmToList assig) ++ "\n" - (x:_) -> x - - (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out - let spill_store = (if reading then id else reverse) - [ -- COMMENT (fsLit "spill alloc") - spill_insn ] - - -- record that this temp was spilled - recordSpill (SpillAlloc temp_to_push_out) - - -- update the register assignment - let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) - setAssigR assig2 - - -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp reading r loc my_reg spills - - allocateRegsAndSpill reading keep - (spill_store ++ spills') - (my_reg:alloc) rs + = return (spills, reverse alloc) + +allocateRegsAndSpill reading keep spills alloc (r:rs) + = do assig <- getAssigR + case lookupUFM assig r of + -- case (1a): already in a register + Just (InReg my_reg) -> + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- case (1b): already in a register (and memory) + -- NB1. if we're writing this register, update its assignemnt to be + -- InReg, because the memory value is no longer valid. + -- NB2. This is why we must process written registers here, even if they + -- are also read by the same instruction. + Just (InBoth my_reg _) + -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- Not already in a register, so we need to find a free one... + loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig + +allocRegsAndSpill_spill reading keep spills alloc r rs loc assig + = do + freeRegs <- getFreeRegsR + let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs + + case freeRegs_thisClass of + + -- case (2): we have a free register + (my_reg : _) -> + do spills' <- loadTemp reading r loc my_reg spills + + let new_loc + -- if the tmp was in a slot, then now its in a reg as well + | Just (InMem slot) <- loc + , reading + = InBoth my_reg slot + + -- tmp has been loaded into a reg + | otherwise + = InReg my_reg + + setAssigR (addToUFM assig r $! new_loc) + setFreeRegsR $ allocateReg my_reg freeRegs + + allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs + + + -- case (3): we need to push something out to free up a register + [] -> + do let keep' = map getUnique keep + + -- the vregs we could kick out that are already in a slot + let candidates_inBoth + = [ (temp, reg, mem) + | (temp, InBoth reg mem) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg reg == classOfVirtualReg r ] + + -- the vregs we could kick out that are only in a reg + -- this would require writing the reg to a new slot before using it. + let candidates_inReg + = [ (temp, reg) + | (temp, InReg reg) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg reg == classOfVirtualReg r ] + + let result + + -- we have a temporary that is in both register and mem, + -- just free up its register for use. + | (temp, my_reg, slot) : _ <- candidates_inBoth + = do spills' <- loadTemp reading r loc my_reg spills + let assig1 = addToUFM assig temp (InMem slot) + let assig2 = addToUFM assig1 r (InReg my_reg) + + setAssigR assig2 + allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + + -- otherwise, we need to spill a temporary that currently + -- resides in a register. + | (temp_to_push_out, (my_reg :: RealReg)) : _ + <- candidates_inReg + = do + (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out + let spill_store = (if reading then id else reverse) + [ -- COMMENT (fsLit "spill alloc") + spill_insn ] + + -- record that this temp was spilled + recordSpill (SpillAlloc temp_to_push_out) + + -- update the register assignment + let assig1 = addToUFM assig temp_to_push_out (InMem slot) + let assig2 = addToUFM assig1 r (InReg my_reg) + setAssigR assig2 + + -- if need be, load up a spilled temp into the reg we've just freed up. + spills' <- loadTemp reading r loc my_reg spills + + allocateRegsAndSpill reading keep + (spill_store ++ spills') + (my_reg:alloc) rs + + + -- there wasn't anything to spill, so we're screwed. + | otherwise + = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") + $ vcat + [ text "allocating vreg: " <> text (show r) + , text "assignment: " <> text (show $ ufmToList assig) + , text "freeRegs: " <> text (show freeRegs) + , text "initFreeRegs: " <> text (show initFreeRegs) ] + + result + -- | Load up a spilled temporary if we need to. loadTemp :: Instruction instr => Bool - -> Reg -- the temp being loaded + -> VirtualReg -- the temp being loaded -> Maybe Loc -- the current location of this temp - -> RegNo -- the hreg to load the temp into + -> RealReg -- the hreg to load the temp into -> [instr] -> RegM [instr] loadTemp True vreg (Just (InMem slot)) hreg spills = do - insn <- loadR (RealReg hreg) slot + insn <- loadR (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs index ac16d8a640..d828347433 100644 --- a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs @@ -33,8 +33,9 @@ data FreeRegs !Word32 -- int reg bitmap regs 0..31 !Word32 -- float reg bitmap regs 32..63 !Word32 -- double reg bitmap regs 32..63 - deriving( Show ) +instance Show FreeRegs where + show = showFreeRegs -- | A reg map where no regs are free to be allocated. noFreeRegs :: FreeRegs @@ -42,129 +43,144 @@ noFreeRegs = FreeRegs 0 0 0 -- | The initial set of free regs. --- Don't treat the top half of reg pairs we're using as doubles as being free. initFreeRegs :: FreeRegs initFreeRegs - = regs - where --- freeDouble = getFreeRegs RcDouble regs - regs = foldr releaseReg noFreeRegs allocable - allocable = allocatableRegs \\ doublePairs - doublePairs = [43, 45, 47, 49, 51, 53] + = foldr releaseReg noFreeRegs allocatableRegs -- | Get all the free registers of this class. -getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazilly getFreeRegs cls (FreeRegs g f d) - | RcInteger <- cls = go g 1 0 - | RcFloat <- cls = go f 1 32 - | RcDouble <- cls = go d 1 32 + | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 + | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 + | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) where - go _ 0 _ = [] - go x m i | x .&. m /= 0 = i : (go x (m `shiftL` 1) $! i+1) - | otherwise = go x (m `shiftL` 1) $! i+1 -{- -showFreeRegs :: FreeRegs -> String -showFreeRegs regs - = "FreeRegs\n" - ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" - ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" - ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" --} - -{- --- | Check whether a reg is free -regIsFree :: RegNo -> FreeRegs -> Bool -regIsFree r (FreeRegs g f d) + go _ _ 0 _ + = [] - -- a general purpose reg - | r <= 31 - , mask <- 1 `shiftL` fromIntegral r - = g .&. mask /= 0 + go step bitmap mask ix + | bitmap .&. mask /= 0 + = ix : (go step bitmap (mask `shiftL` step) $! ix + step) - -- use the first 22 float regs as double precision - | r >= 32 - , r <= 53 - , mask <- 1 `shiftL` (fromIntegral r - 32) - = d .&. mask /= 0 + | otherwise + = go step bitmap (mask `shiftL` step) $! ix + step - -- use the last 10 float regs as single precision - | otherwise - , mask <- 1 `shiftL` (fromIntegral r - 32) - = f .&. mask /= 0 --} -- | Grab a register. -grabReg :: RegNo -> FreeRegs -> FreeRegs -grabReg r (FreeRegs g f d) +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg + reg@(RealRegSingle r) + (FreeRegs g f d) + -- can't allocate free regs + | not $ isFastTrue (freeReg r) + = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) + -- a general purpose reg | r <= 31 - , mask <- complement (1 `shiftL` fromIntegral r) - = FreeRegs (g .&. mask) f d - - -- use the first 22 float regs as double precision - | r >= 32 - , r <= 53 - , mask <- complement (1 `shiftL` (fromIntegral r - 32)) - = FreeRegs g f (d .&. mask) - - -- use the last 10 float regs as single precision - | otherwise - , mask <- complement (1 `shiftL` (fromIntegral r - 32)) - = FreeRegs g (f .&. mask) d + = let mask = complement (bitMask r) + in FreeRegs + (g .&. mask) + f + d + + -- a float reg + | r >= 32, r <= 63 + = let mask = complement (bitMask (r - 32)) + + -- the mask of the double this FP reg aliases + maskLow = if r `mod` 2 == 0 + then complement (bitMask (r - 32)) + else complement (bitMask (r - 32 - 1)) + in FreeRegs + g + (f .&. mask) + (d .&. maskLow) + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) + +allocateReg + reg@(RealRegPair r1 r2) + (FreeRegs g f d) + + | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 + , r2 >= 32, r2 <= 63 + = let mask1 = complement (bitMask (r1 - 32)) + mask2 = complement (bitMask (r2 - 32)) + in + FreeRegs + g + ((f .&. mask1) .&. mask2) + (d .&. mask1) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) + -- | Release a register from allocation. -- The register liveness information says that most regs die after a C call, -- but we still don't want to allocate to some of them. -- -releaseReg :: RegNo -> FreeRegs -> FreeRegs -releaseReg r regs@(FreeRegs g f d) +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg + reg@(RealRegSingle r) + regs@(FreeRegs g f d) + -- don't release pinned reg | not $ isFastTrue (freeReg r) = regs - - -- don't release the high part of double regs - -- this prevents them from being allocated as single precison regs. - | r == 39 = regs - | r == 41 = regs - | r == 43 = regs - | r == 45 = regs - | r == 47 = regs - | r == 49 = regs - | r == 51 = regs - | r == 53 = regs - + -- a general purpose reg | r <= 31 - , mask <- 1 `shiftL` fromIntegral r - = FreeRegs (g .|. mask) f d - - -- use the first 22 float regs as double precision - | r >= 32 - , r <= 53 - , mask <- 1 `shiftL` (fromIntegral r - 32) - = FreeRegs g f (d .|. mask) - - -- use the last 10 float regs as single precision - | otherwise - , mask <- 1 `shiftL` (fromIntegral r - 32) - = FreeRegs g (f .|. mask) d - - --- | Allocate a register in the map. -allocateReg :: RegNo -> FreeRegs -> FreeRegs -allocateReg r regs -- (FreeRegs g f d) - - -- if the reg isn't actually free then we're in trouble -{- | not $ regIsFree r regs - = pprPanic - "RegAllocLinear.allocateReg" - (text "reg " <> ppr r <> text " is not free") --} + = let mask = bitMask r + in FreeRegs (g .|. mask) f d + + -- a float reg + | r >= 32, r <= 63 + = let mask = bitMask (r - 32) + + -- the mask of the double this FP reg aliases + maskLow = if r `mod` 2 == 0 + then bitMask (r - 32) + else bitMask (r - 32 - 1) + in FreeRegs + g + (f .|. mask) + (d .|. maskLow) + | otherwise - = grabReg r regs + = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) + +releaseReg + reg@(RealRegPair r1 r2) + (FreeRegs g f d) + + | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 + , r2 >= 32, r2 <= 63 + = let mask1 = bitMask (r1 - 32) + mask2 = bitMask (r2 - 32) + in + FreeRegs + g + ((f .|. mask1) .|. mask2) + (d .|. mask1) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) + + + +bitMask :: Int -> Word32 +bitMask n = 1 `shiftL` n + + +showFreeRegs :: FreeRegs -> String +showFreeRegs regs + = "FreeRegs\n" + ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" + ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" + ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs index eedaca8cc0..2b69da0093 100644 --- a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs @@ -28,7 +28,7 @@ getFreeRegs cls f = go f 0 where go 0 _ = [] go n m - | n .&. 1 /= 0 && regClass (RealReg m) == cls + | n .&. 1 /= 0 && regClass (regSingle m) == cls = m : (go (n `shiftR` 1) $! (m+1)) | otherwise diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 8faab5af92..0c289c16e9 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -465,7 +465,8 @@ patchEraseLive patchF cmm patchCmm (CmmProc info label params (ListGraph comps)) | LiveInfo static id blockMap <- info - = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set + = let + patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set blockMap' = mapBlockEnv patchRegSet blockMap info' = LiveInfo static id blockMap' @@ -781,5 +782,3 @@ liveness1 liveregs blockmap instr live_branch_only) - - |