NCG: Split linear allocator into separate modules.

parent d7d09c18
......@@ -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
......
-- | 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 #) }
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
-- | 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
-- | 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
-- | 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)
-- | 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}, () #)
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 "")