From cbc96da034482b769889c109f6cc822f42b12027 Mon Sep 17 00:00:00 2001 From: "Ben.Lippmeier@anu.edu.au" Date: Mon, 2 Feb 2009 05:53:01 +0000 Subject: [PATCH] NCG: Split linear allocator into separate modules. --- compiler/nativeGen/AsmCodeGen.lhs | 4 +- compiler/nativeGen/RegAlloc/Linear/Base.hs | 128 +++++ compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs | 41 ++ .../{RegAllocLinear.hs => RegAlloc/Linear/Main.hs} | 500 +------------------- compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs | 54 +++ .../nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs | 168 +++++++ compiler/nativeGen/RegAlloc/Linear/StackMap.hs | 72 +++ compiler/nativeGen/RegAlloc/Linear/State.hs | 139 ++++++ compiler/nativeGen/RegAlloc/Linear/Stats.hs | 82 ++++ compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs | 40 ++ compiler/nativeGen/RegAllocInfo.hs | 13 +- 11 files changed, 749 insertions(+), 492 deletions(-) create mode 100644 compiler/nativeGen/RegAlloc/Linear/Base.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs rename compiler/nativeGen/{RegAllocLinear.hs => RegAlloc/Linear/Main.hs} (63%) create mode 100644 compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/StackMap.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/State.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/Stats.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 70b042b..33f7628 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -28,7 +28,9 @@ import NCGMonad import PositionIndependentCode import RegLiveness import RegCoalesce -import qualified RegAllocLinear as Linear + +import qualified RegAlloc.Linear.Main as Linear + import qualified RegAllocColor as Color import qualified RegAllocStats as Color import qualified GraphColor as Color diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs new file mode 100644 index 0000000..95c9965 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs @@ -0,0 +1,128 @@ + +-- | Put common type definitions here to break recursive module dependencies. + +module RegAlloc.Linear.Base ( + BlockAssignment, + Loc(..), + + -- for stats + SpillReason(..), + RegAllocStats(..), + + -- the allocator monad + RA_State(..), + RegM(..) +) + +where + +import RegAlloc.Linear.FreeRegs +import RegAlloc.Linear.StackMap + +import RegLiveness +import MachRegs + +import Outputable +import Unique +import UniqFM +import UniqSupply + + +-- | Used to store the register assignment on entry to a basic block. +-- We use this to handle join points, where multiple branch instructions +-- target a particular label. We have to insert fixup code to make +-- the register assignments from the different sources match up. +-- +type BlockAssignment + = BlockMap (FreeRegs, RegMap Loc) + + +-- | Where a vreg is currently stored +-- A temporary can be marked as living in both a register and memory +-- (InBoth), for example if it was recently loaded from a spill location. +-- This makes it cheap to spill (no save instruction required), but we +-- have to be careful to turn this into InReg if the value in the +-- register is changed. + +-- This is also useful when a temporary is about to be clobbered. We +-- save it in a spill location, but mark it as InBoth because the current +-- instruction might still want to read it. +-- +data Loc + -- | vreg is in a register + = InReg {-# UNPACK #-} !RegNo + + -- | vreg is held in a stack slot + | InMem {-# UNPACK #-} !StackSlot + + + -- | vreg is held in both a register and a stack slot + | InBoth {-# UNPACK #-} !RegNo + {-# UNPACK #-} !StackSlot + deriving (Eq, Show, Ord) + +instance Outputable Loc where + ppr l = text (show l) + + +-- | Reasons why instructions might be inserted by the spiller. +-- Used when generating stats for -ddrop-asm-stats. +-- +data SpillReason + -- | vreg was spilled to a slot so we could use its + -- current hreg for another vreg + = SpillAlloc !Unique + + -- | vreg was moved because its hreg was clobbered + | SpillClobber !Unique + + -- | vreg was loaded from a spill slot + | SpillLoad !Unique + + -- | reg-reg move inserted during join to targets + | SpillJoinRR !Unique + + -- | reg-mem move inserted during join to targets + | SpillJoinRM !Unique + + +-- | Used to carry interesting stats out of the register allocator. +data RegAllocStats + = RegAllocStats + { ra_spillInstrs :: UniqFM [Int] } + + +-- | The register alloctor state +data RA_State + = RA_State + + -- | the current mapping from basic blocks to + -- the register assignments at the beginning of that block. + { ra_blockassig :: BlockAssignment + + -- | free machine registers + , ra_freeregs :: {-#UNPACK#-}!FreeRegs + + -- | assignment of temps to locations + , ra_assig :: RegMap Loc + + -- | current stack delta + , ra_delta :: Int + + -- | free stack slots for spilling + , ra_stack :: StackMap + + -- | unique supply for generating names for join point fixup blocks. + , ra_us :: UniqSupply + + -- | Record why things were spilled, for -ddrop-asm-stats. + -- Just keep a list here instead of a map of regs -> reasons. + -- We don't want to slow down the allocator if we're not going to emit the stats. + , ra_spills :: [SpillReason] } + + +-- | The register allocator monad type. +newtype RegM a + = RegM { unReg :: RA_State -> (# RA_State, a #) } + + diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs new file mode 100644 index 0000000..bee8c98 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -0,0 +1,41 @@ + +module RegAlloc.Linear.FreeRegs ( + FreeRegs(), + noFreeRegs, + releaseReg, + initFreeRegs, + getFreeRegs, + allocateReg +) + +#include "HsVersions.h" + +where + +-- ----------------------------------------------------------------------------- +-- The free register set +-- This needs to be *efficient* +-- Here's an inefficient 'executable specification' of the FreeRegs data type: +-- +-- type FreeRegs = [RegNo] +-- noFreeRegs = 0 +-- releaseReg n f = if n `elem` f then f else (n : f) +-- initFreeRegs = allocatableRegs +-- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f +-- allocateReg f r = filter (/= r) f + + +#if defined(powerpc_TARGET_ARCH) +import RegAlloc.Linear.PPC.FreeRegs + +#elif defined(sparc_TARGET_ARCH) +import RegAlloc.Linear.SPARC.FreeRegs + +#elif defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH) +import RegAlloc.Linear.X86.FreeRegs + +#else +#error "RegAlloc.Linear.FreeRegs not defined for this architecture." + +#endif + diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs similarity index 63% rename from compiler/nativeGen/RegAllocLinear.hs rename to compiler/nativeGen/RegAlloc/Linear/Main.hs index 0a0162f..6dde72a 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -81,13 +81,21 @@ The algorithm is roughly: -} -module RegAllocLinear ( +module RegAlloc.Linear.Main ( regAlloc, - RegAllocStats, pprStats + module RegAlloc.Linear.Base, + module RegAlloc.Linear.Stats ) where #include "HsVersions.h" + +import RegAlloc.Linear.State +import RegAlloc.Linear.Base +import RegAlloc.Linear.StackMap +import RegAlloc.Linear.FreeRegs +import RegAlloc.Linear.Stats + import BlockId import MachRegs import MachInstrs @@ -101,296 +109,14 @@ import UniqSet import UniqFM import UniqSupply import Outputable -import State import FastString import Data.Maybe import Data.List import Control.Monad -import Data.Word -import Data.Bits #include "../includes/MachRegs.h" --- ----------------------------------------------------------------------------- --- The free register set - --- This needs to be *efficient* - -{- Here's an inefficient 'executable specification' of the FreeRegs data type: -type FreeRegs = [RegNo] - -noFreeRegs = 0 -releaseReg n f = if n `elem` f then f else (n : f) -initFreeRegs = allocatableRegs -getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f -allocateReg f r = filter (/= r) f --} - -#if defined(powerpc_TARGET_ARCH) - --- The PowerPC has 32 integer and 32 floating point registers. --- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much --- better. --- Note that when getFreeRegs scans for free registers, it starts at register --- 31 and counts down. This is a hack for the PowerPC - the higher-numbered --- registers are callee-saves, while the lower regs are caller-saves, so it --- makes sense to start at the high end. --- Apart from that, the code does nothing PowerPC-specific, so feel free to --- add your favourite platform to the #if (if you have 64 registers but only --- 32-bit words). - -data FreeRegs = FreeRegs !Word32 !Word32 - deriving( Show ) -- The Show is used in an ASSERT - -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 0 - -releaseReg :: RegNo -> FreeRegs -> FreeRegs -releaseReg r (FreeRegs g f) - | r > 31 = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32))) - | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f - -initFreeRegs :: FreeRegs -initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs - -getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly -getFreeRegs cls (FreeRegs g f) - | RcDouble <- cls = go f (0x80000000) 63 - | RcInteger <- cls = go g (0x80000000) 31 - | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls) - where - go _ 0 _ = [] - go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1) - | otherwise = go x (m `shiftR` 1) $! i-1 - -allocateReg :: RegNo -> FreeRegs -> FreeRegs -allocateReg r (FreeRegs g f) - | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32))) - | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f - - -#elif defined(sparc_TARGET_ARCH) --------------------------------------------------------------------------------- --- SPARC is like PPC, except for twinning of floating point regs. --- When we allocate a double reg we must take an even numbered --- float reg, as well as the one after it. - - --- Holds bitmaps showing what registers are currently allocated. --- The float and double reg bitmaps overlap, but we only alloc --- float regs into the float map, and double regs into the double map. --- --- Free regs have a bit set in the corresponding bitmap. --- -data FreeRegs - = FreeRegs - !Word32 -- int reg bitmap regs 0..31 - !Word32 -- float reg bitmap regs 32..63 - !Word32 -- double reg bitmap regs 32..63 - deriving( Show ) - - --- | A reg map where no regs are free to be allocated. -noFreeRegs :: FreeRegs -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] - - --- | Get all the free registers of this class. -getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- 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 - | 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) - - -- a general purpose reg - | r <= 31 - , mask <- 1 `shiftL` fromIntegral r - = g .&. mask /= 0 - - -- use the first 22 float regs as double precision - | r >= 32 - , r <= 53 - , mask <- 1 `shiftL` (fromIntegral r - 32) - = d .&. mask /= 0 - - -- 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) - - -- 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 - - - --- | 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) - - -- used by STG machine, or otherwise unavailable - | r >= 0 && r <= 15 = regs - | r >= 17 && r <= 21 = regs - | r >= 24 && r <= 31 = regs - | r >= 32 && r <= 41 = regs - | r >= 54 && r <= 59 = regs - - -- never release the high part of double 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") --} - | otherwise - = grabReg r regs - - - --------------------------------------------------------------------------------- - --- If we have less than 32 registers, or if we have efficient 64-bit words, --- we will just use a single bitfield. - -#else - -# if defined(alpha_TARGET_ARCH) -type FreeRegs = Word64 -# else -type FreeRegs = Word32 -# endif - -noFreeRegs :: FreeRegs -noFreeRegs = 0 - -releaseReg :: RegNo -> FreeRegs -> FreeRegs -releaseReg n f = f .|. (1 `shiftL` n) - -initFreeRegs :: FreeRegs -initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs - -getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly -getFreeRegs cls f = go f 0 - where go 0 _ = [] - go n m - | n .&. 1 /= 0 && regClass (RealReg m) == cls - = m : (go (n `shiftR` 1) $! (m+1)) - | otherwise - = go (n `shiftR` 1) $! (m+1) - -- ToDo: there's no point looking through all the integer registers - -- in order to find a floating-point one. - -allocateReg :: RegNo -> FreeRegs -> FreeRegs -allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r) - -#endif - --- ----------------------------------------------------------------------------- --- The assignment of virtual registers to stack slots - --- We have lots of stack slots. Memory-to-memory moves are a pain on most --- architectures. Therefore, we avoid having to generate memory-to-memory moves --- by simply giving every virtual register its own stack slot. - --- The StackMap stack map keeps track of virtual register - stack slot --- associations and of which stack slots are still free. Once it has been --- associated, a stack slot is never "freed" or removed from the StackMap again, --- it remains associated until we are done with the current CmmProc. - -type StackSlot = Int -data StackMap = StackMap [StackSlot] (UniqFM StackSlot) - -emptyStackMap :: StackMap -emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM - -getStackSlotFor :: StackMap -> Unique -> (StackMap,Int) -getStackSlotFor (StackMap [] _) _ - = panic "RegAllocLinear.getStackSlotFor: out of stack slots, try -fregs-graph" - -- This happens with darcs' SHA1.hs, see #1993 - -getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg = - case lookupUFM reserved reg of - Just slot -> (fs,slot) - Nothing -> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot) -- ----------------------------------------------------------------------------- -- Top level of the register allocator @@ -436,27 +162,6 @@ regAlloc (CmmProc _ _ _ _) -- ----------------------------------------------------------------------------- -- Linear sweep to allocate registers -data Loc = InReg {-# UNPACK #-} !RegNo - | InMem {-# UNPACK #-} !Int -- stack slot - | InBoth {-# UNPACK #-} !RegNo - {-# UNPACK #-} !Int -- stack slot - deriving (Eq, Show, Ord) - -{- -A temporary can be marked as living in both a register and memory -(InBoth), for example if it was recently loaded from a spill location. -This makes it cheap to spill (no save instruction required), but we -have to be careful to turn this into InReg if the value in the -register is changed. - -This is also useful when a temporary is about to be clobbered. We -save it in a spill location, but mark it as InBoth because the current -instruction might still want to read it. --} - -instance Outputable Loc where - ppr l = text (show l) - -- | Do register allocation on some basic blocks. -- But be careful to allocate a block in an SCC only if it has @@ -548,8 +253,6 @@ linearRA block_live instr_acc fixups (instr:instrs) -- ----------------------------------------------------------------------------- -- Register allocation for a single instruction -type BlockAssignment = BlockMap (FreeRegs, RegMap Loc) - raInsn :: BlockMap RegSet -- Live temporaries at each basic block -> [Instr] -- new instructions (accum.) -> LiveInstr -- the instruction (with "deaths") @@ -1102,189 +805,6 @@ handleComponent _ _ (CyclicSCC _) -- ----------------------------------------------------------------------------- --- The register allocator's monad. - --- Here we keep all the state that the register allocator keeps track --- of as it walks the instructions in a basic block. - -data RA_State - = RA_State { - ra_blockassig :: BlockAssignment, - -- The current mapping from basic blocks to - -- the register assignments at the beginning of that block. - ra_freeregs :: {-#UNPACK#-}!FreeRegs, -- free machine registers - ra_assig :: RegMap Loc, -- assignment of temps to locations - ra_delta :: Int, -- current stack delta - ra_stack :: StackMap, -- free stack slots for spilling - ra_us :: UniqSupply, -- unique supply for generating names - -- for fixup blocks. - - -- Record why things were spilled, for -ddrop-asm-stats. - -- Just keep a list here instead of a map of regs -> reasons. - -- We don't want to slow down the allocator if we're not going to emit the stats. - ra_spills :: [SpillReason] - } - -newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) } - - -instance Monad RegM where - m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s } - return a = RegM $ \s -> (# s, a #) - -runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> StackMap -> UniqSupply - -> RegM a -> (BlockAssignment, StackMap, RegAllocStats, a) -runR block_assig freeregs assig stack us thing = - case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs, - ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack, - ra_us = us, ra_spills = [] }) of - (# state'@RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #) - -> (block_assig, stack', makeRAStats state', returned_thing) - -spillR :: Reg -> Unique -> RegM (Instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> - let (stack',slot) = getStackSlotFor stack temp - instr = mkSpillInstr reg delta slot - in - (# s{ra_stack=stack'}, (instr,slot) #) - -loadR :: Reg -> Int -> RegM Instr -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - (# s, mkLoadInstr reg delta slot #) - -getFreeRegsR :: RegM FreeRegs -getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> - (# s, freeregs #) - -setFreeRegsR :: FreeRegs -> RegM () -setFreeRegsR regs = RegM $ \ s -> - (# s{ra_freeregs = regs}, () #) - -getAssigR :: RegM (RegMap Loc) -getAssigR = RegM $ \ s@RA_State{ra_assig = assig} -> - (# s, assig #) - -setAssigR :: RegMap Loc -> RegM () -setAssigR assig = RegM $ \ s -> - (# s{ra_assig=assig}, () #) - -getBlockAssigR :: RegM BlockAssignment -getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} -> - (# s, assig #) - -setBlockAssigR :: BlockAssignment -> RegM () -setBlockAssigR assig = RegM $ \ s -> - (# s{ra_blockassig = assig}, () #) - -setDeltaR :: Int -> RegM () -setDeltaR n = RegM $ \ s -> - (# s{ra_delta = n}, () #) - -getDeltaR :: RegM Int -getDeltaR = RegM $ \s -> (# s, ra_delta s #) - -getUniqueR :: RegM Unique -getUniqueR = RegM $ \s -> - case splitUniqSupply (ra_us s) of - (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #) - --- | Record that a spill instruction was inserted, for profiling. -recordSpill :: SpillReason -> RegM () -recordSpill spill - = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) - --- ----------------------------------------------------------------------------- - --- | Reasons why instructions might be inserted by the spiller. --- Used when generating stats for -ddrop-asm-stats. --- -data SpillReason - = SpillAlloc !Unique -- ^ vreg was spilled to a slot so we could use its - -- current hreg for another vreg - | SpillClobber !Unique -- ^ vreg was moved because its hreg was clobbered - | SpillLoad !Unique -- ^ vreg was loaded from a spill slot - - | SpillJoinRR !Unique -- ^ reg-reg move inserted during join to targets - | SpillJoinRM !Unique -- ^ reg-mem move inserted during join to targets - - --- | Used to carry interesting stats out of the register allocator. -data RegAllocStats - = RegAllocStats - { ra_spillInstrs :: UniqFM [Int] } - - --- | Make register allocator stats from its final state. -makeRAStats :: RA_State -> RegAllocStats -makeRAStats state - = RegAllocStats - { ra_spillInstrs = binSpillReasons (ra_spills state) } - - --- | Build a map of how many times each reg was alloced, clobbered, loaded etc. -binSpillReasons - :: [SpillReason] -> UniqFM [Int] - -binSpillReasons reasons - = addListToUFM_C - (zipWith (+)) - emptyUFM - (map (\reason -> case reason of - SpillAlloc r -> (r, [1, 0, 0, 0, 0]) - SpillClobber r -> (r, [0, 1, 0, 0, 0]) - SpillLoad r -> (r, [0, 0, 1, 0, 0]) - SpillJoinRR r -> (r, [0, 0, 0, 1, 0]) - SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons) - - --- | Count reg-reg moves remaining in this code. -countRegRegMovesNat :: NatCmmTop -> Int -countRegRegMovesNat cmm - = execState (mapGenBlockTopM countBlock cmm) 0 - where - countBlock b@(BasicBlock _ instrs) - = do mapM_ countInstr instrs - return b - - countInstr instr - | Just _ <- isRegRegMove instr - = do modify (+ 1) - return instr - - | otherwise - = return instr - - --- | Pretty print some RegAllocStats -pprStats :: [NatCmmTop] -> [RegAllocStats] -> SDoc -pprStats code statss - = let -- sum up all the instrs inserted by the spiller - spills = foldl' (plusUFM_C (zipWith (+))) - emptyUFM - $ map ra_spillInstrs statss - - spillTotals = foldl' (zipWith (+)) - [0, 0, 0, 0, 0] - $ eltsUFM spills - - -- count how many reg-reg-moves remain in the code - moves = sum $ map countRegRegMovesNat code - - pprSpill (reg, spills) - = parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills)) - - in ( text "-- spills-added-total" - $$ text "-- (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)" - $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves]))) - $$ text "" - $$ text "-- spills-added" - $$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)" - $$ (vcat $ map pprSpill - $ ufmToList spills) - $$ text "") - - --- ----------------------------------------------------------------------------- -- Utils my_fromJust :: String -> SDoc -> Maybe a -> a diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs new file mode 100644 index 0000000..1e31625 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs @@ -0,0 +1,54 @@ + +-- | Free regs map for PowerPC +module RegAlloc.Linear.PPC.FreeRegs +where + +import MachRegs + +import Outputable + +import Data.Word +import Data.Bits +import Data.List + +-- The PowerPC has 32 integer and 32 floating point registers. +-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much +-- better. +-- Note that when getFreeRegs scans for free registers, it starts at register +-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered +-- registers are callee-saves, while the lower regs are caller-saves, so it +-- makes sense to start at the high end. +-- Apart from that, the code does nothing PowerPC-specific, so feel free to +-- add your favourite platform to the #if (if you have 64 registers but only +-- 32-bit words). + +data FreeRegs = FreeRegs !Word32 !Word32 + deriving( Show ) -- The Show is used in an ASSERT + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 + +releaseReg :: RegNo -> FreeRegs -> FreeRegs +releaseReg r (FreeRegs g f) + | r > 31 = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32))) + | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f + +initFreeRegs :: FreeRegs +initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs + +getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly +getFreeRegs cls (FreeRegs g f) + | RcDouble <- cls = go f (0x80000000) 63 + | RcInteger <- cls = go g (0x80000000) 31 + | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls) + where + go _ 0 _ = [] + go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1) + | otherwise = go x (m `shiftR` 1) $! i-1 + +allocateReg :: RegNo -> FreeRegs -> FreeRegs +allocateReg r (FreeRegs g f) + | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32))) + | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f + + diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs new file mode 100644 index 0000000..d284a45 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs @@ -0,0 +1,168 @@ + +-- | Free regs map for SPARC +module RegAlloc.Linear.SPARC.FreeRegs +where + +import MachRegs + +import Outputable + +import Data.Word +import Data.Bits +import Data.List + +-------------------------------------------------------------------------------- +-- SPARC is like PPC, except for twinning of floating point regs. +-- When we allocate a double reg we must take an even numbered +-- float reg, as well as the one after it. + + +-- Holds bitmaps showing what registers are currently allocated. +-- The float and double reg bitmaps overlap, but we only alloc +-- float regs into the float map, and double regs into the double map. +-- +-- Free regs have a bit set in the corresponding bitmap. +-- +data FreeRegs + = FreeRegs + !Word32 -- int reg bitmap regs 0..31 + !Word32 -- float reg bitmap regs 32..63 + !Word32 -- double reg bitmap regs 32..63 + deriving( Show ) + + +-- | A reg map where no regs are free to be allocated. +noFreeRegs :: FreeRegs +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] + + +-- | Get all the free registers of this class. +getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- 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 + | 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) + + -- a general purpose reg + | r <= 31 + , mask <- 1 `shiftL` fromIntegral r + = g .&. mask /= 0 + + -- use the first 22 float regs as double precision + | r >= 32 + , r <= 53 + , mask <- 1 `shiftL` (fromIntegral r - 32) + = d .&. mask /= 0 + + -- 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) + + -- 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 + + + +-- | 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) + + -- used by STG machine, or otherwise unavailable + | r >= 0 && r <= 15 = regs +-- | r >= 3 && r <= 15 = regs + + | r >= 17 && r <= 21 = regs + | r >= 24 && r <= 31 = regs + | r >= 32 && r <= 41 = regs + | r >= 54 && r <= 59 = regs + + -- never release the high part of double 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") +-} + | otherwise + = grabReg r regs + diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs new file mode 100644 index 0000000..56382aa --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs @@ -0,0 +1,72 @@ + +-- | The assignment of virtual registers to stack slots + +-- We have lots of stack slots. Memory-to-memory moves are a pain on most +-- architectures. Therefore, we avoid having to generate memory-to-memory moves +-- by simply giving every virtual register its own stack slot. + +-- The StackMap stack map keeps track of virtual register - stack slot +-- associations and of which stack slots are still free. Once it has been +-- associated, a stack slot is never "freed" or removed from the StackMap again, +-- it remains associated until we are done with the current CmmProc. +-- +module RegAlloc.Linear.StackMap ( + StackSlot, + StackMap(..), + emptyStackMap, + getStackSlotFor +) + +where + +import RegAllocInfo (maxSpillSlots) + +import Outputable +import UniqFM +import Unique + + +-- | Identifier for a stack slot. +type StackSlot = Int + +data StackMap + = StackMap + + -- | The slots that are still available to be allocated. + { stackMapFreeSlots :: [StackSlot] + + -- | Assignment of vregs to stack slots. + , stackMapAssignment :: UniqFM StackSlot } + + +-- | An empty stack map, with all slots available. +emptyStackMap :: StackMap +emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM + + +-- | If this vreg unique already has a stack assignment then return the slot number, +-- otherwise allocate a new slot, and update the map. +-- +getStackSlotFor :: StackMap -> Unique -> (StackMap, Int) + +getStackSlotFor (StackMap [] _) _ + + -- This happens all the time when trying to compile darcs' SHA1.hs, see Track #1993 + -- SHA1.lhs has also been added to the Crypto library on Hackage, + -- so we see this all the time. + -- + -- It would be better to automatically invoke the graph allocator, or do something + -- else besides panicing, but that's a job for a different day. -- BL 2009/02 + -- + = panic $ "RegAllocLinear.getStackSlotFor: out of stack slots\n" + ++ " If you are trying to compile SHA1.hs from the crypto library then this\n" + ++ " is a known limitation in the linear allocator.\n" + ++ "\n" + ++ " Try enabling the graph colouring allocator with -fregs-graph instead." + ++ " You can still file a bug report if you like.\n" + +getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg = + case lookupUFM reserved reg of + Just slot -> (fs, slot) + Nothing -> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot) + diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs new file mode 100644 index 0000000..428b0ca --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -0,0 +1,139 @@ +-- | State monad for the linear register allocator. + +-- Here we keep all the state that the register allocator keeps track +-- of as it walks the instructions in a basic block. + +module RegAlloc.Linear.State ( + RA_State(..), + RegM, + runR, + + spillR, + loadR, + + getFreeRegsR, + setFreeRegsR, + + getAssigR, + setAssigR, + + getBlockAssigR, + setBlockAssigR, + + setDeltaR, + getDeltaR, + + getUniqueR, + + recordSpill +) +where + +import RegAlloc.Linear.Stats +import RegAlloc.Linear.StackMap +import RegAlloc.Linear.Base +import RegAlloc.Linear.FreeRegs + + +import MachInstrs +import MachRegs +import RegAllocInfo +import RegLiveness + +import Unique +import UniqSupply + + +-- | The RegM Monad +instance Monad RegM where + m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s } + return a = RegM $ \s -> (# s, a #) + + +-- | Run a computation in the RegM register allocator monad. +runR :: BlockAssignment + -> FreeRegs + -> RegMap Loc + -> StackMap + -> UniqSupply + -> RegM a + -> (BlockAssignment, StackMap, RegAllocStats, a) + +runR block_assig freeregs assig stack us thing = + case unReg thing + (RA_State + { ra_blockassig = block_assig + , ra_freeregs = freeregs + , ra_assig = assig + , ra_delta = 0{-???-} + , ra_stack = stack + , ra_us = us + , ra_spills = [] }) + of + (# state'@RA_State + { ra_blockassig = block_assig + , ra_stack = stack' } + , returned_thing #) + + -> (block_assig, stack', makeRAStats state', returned_thing) + + +-- | Make register allocator stats from its final state. +makeRAStats :: RA_State -> RegAllocStats +makeRAStats state + = RegAllocStats + { ra_spillInstrs = binSpillReasons (ra_spills state) } + + +spillR :: Reg -> Unique -> RegM (Instr, Int) +spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> + let (stack',slot) = getStackSlotFor stack temp + instr = mkSpillInstr reg delta slot + in + (# s{ra_stack=stack'}, (instr,slot) #) + +loadR :: Reg -> Int -> RegM Instr +loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> + (# s, mkLoadInstr reg delta slot #) + +getFreeRegsR :: RegM FreeRegs +getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> + (# s, freeregs #) + +setFreeRegsR :: FreeRegs -> RegM () +setFreeRegsR regs = RegM $ \ s -> + (# s{ra_freeregs = regs}, () #) + +getAssigR :: RegM (RegMap Loc) +getAssigR = RegM $ \ s@RA_State{ra_assig = assig} -> + (# s, assig #) + +setAssigR :: RegMap Loc -> RegM () +setAssigR assig = RegM $ \ s -> + (# s{ra_assig=assig}, () #) + +getBlockAssigR :: RegM BlockAssignment +getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} -> + (# s, assig #) + +setBlockAssigR :: BlockAssignment -> RegM () +setBlockAssigR assig = RegM $ \ s -> + (# s{ra_blockassig = assig}, () #) + +setDeltaR :: Int -> RegM () +setDeltaR n = RegM $ \ s -> + (# s{ra_delta = n}, () #) + +getDeltaR :: RegM Int +getDeltaR = RegM $ \s -> (# s, ra_delta s #) + +getUniqueR :: RegM Unique +getUniqueR = RegM $ \s -> + case splitUniqSupply (ra_us s) of + (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #) + + +-- | Record that a spill instruction was inserted, for profiling. +recordSpill :: SpillReason -> RegM () +recordSpill spill + = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs new file mode 100644 index 0000000..f20ad60 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -0,0 +1,82 @@ +module RegAlloc.Linear.Stats ( + binSpillReasons, + countRegRegMovesNat, + pprStats +) + +where + +import RegAlloc.Linear.Base +import RegLiveness +import RegAllocInfo +import MachInstrs +import Cmm (GenBasicBlock(..)) + +import UniqFM +import Outputable + +import Data.List +import State + +-- | Build a map of how many times each reg was alloced, clobbered, loaded etc. +binSpillReasons + :: [SpillReason] -> UniqFM [Int] + +binSpillReasons reasons + = addListToUFM_C + (zipWith (+)) + emptyUFM + (map (\reason -> case reason of + SpillAlloc r -> (r, [1, 0, 0, 0, 0]) + SpillClobber r -> (r, [0, 1, 0, 0, 0]) + SpillLoad r -> (r, [0, 0, 1, 0, 0]) + SpillJoinRR r -> (r, [0, 0, 0, 1, 0]) + SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons) + + +-- | Count reg-reg moves remaining in this code. +countRegRegMovesNat :: NatCmmTop -> Int +countRegRegMovesNat cmm + = execState (mapGenBlockTopM countBlock cmm) 0 + where + countBlock b@(BasicBlock _ instrs) + = do mapM_ countInstr instrs + return b + + countInstr instr + | Just _ <- isRegRegMove instr + = do modify (+ 1) + return instr + + | otherwise + = return instr + + +-- | Pretty print some RegAllocStats +pprStats :: [NatCmmTop] -> [RegAllocStats] -> SDoc +pprStats code statss + = let -- sum up all the instrs inserted by the spiller + spills = foldl' (plusUFM_C (zipWith (+))) + emptyUFM + $ map ra_spillInstrs statss + + spillTotals = foldl' (zipWith (+)) + [0, 0, 0, 0, 0] + $ eltsUFM spills + + -- count how many reg-reg-moves remain in the code + moves = sum $ map countRegRegMovesNat code + + pprSpill (reg, spills) + = parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills)) + + in ( text "-- spills-added-total" + $$ text "-- (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)" + $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves]))) + $$ text "" + $$ text "-- spills-added" + $$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)" + $$ (vcat $ map pprSpill + $ ufmToList spills) + $$ text "") + diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs new file mode 100644 index 0000000..5d7fc63 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs @@ -0,0 +1,40 @@ + +-- | Free regs map for i386 and x86_64 +module RegAlloc.Linear.X86.FreeRegs +where + +import MachRegs + +import Data.Word +import Data.Bits +import Data.List + +type FreeRegs + = Word32 + +noFreeRegs :: FreeRegs +noFreeRegs = 0 + +releaseReg :: RegNo -> FreeRegs -> FreeRegs +releaseReg n f = f .|. (1 `shiftL` n) + +initFreeRegs :: FreeRegs +initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs + +getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly +getFreeRegs cls f = go f 0 + + where go 0 _ = [] + go n m + | n .&. 1 /= 0 && regClass (RealReg m) == cls + = m : (go (n `shiftR` 1) $! (m+1)) + + | otherwise + = go (n `shiftR` 1) $! (m+1) + -- ToDo: there's no point looking through all the integer registers + -- in order to find a floating-point one. + +allocateReg :: RegNo -> FreeRegs -> FreeRegs +allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r) + + diff --git a/compiler/nativeGen/RegAllocInfo.hs b/compiler/nativeGen/RegAllocInfo.hs index bab6c2f..a143589 100644 --- a/compiler/nativeGen/RegAllocInfo.hs +++ b/compiler/nativeGen/RegAllocInfo.hs @@ -433,8 +433,11 @@ jumpDests insn acc #endif _other -> acc -patchJump :: Instr -> BlockId -> BlockId -> Instr +-- | Change the destination of this jump instruction +-- Used in joinToTargets in the linear allocator, when emitting fixup code +-- for join points. +patchJump :: Instr -> BlockId -> BlockId -> Instr patchJump insn old new = case insn of #if i386_TARGET_ARCH || x86_64_TARGET_ARCH @@ -444,6 +447,14 @@ patchJump insn old new BCC cc id | id == old -> BCC cc new BCCFAR cc id | id == old -> BCCFAR cc new BCTR targets -> error "Cannot patch BCTR" +#elif sparc_TARGET_ARCH + BI cc annul id + | id == old -> BI cc annul new + + BF cc annul id + | id == old -> BF cc annul new +#else +#error "RegAllocInfo.patchJump not finished" #endif _other -> insn -- 1.7.10.4