-- | The register alloctor state
-data RA_State
+data RA_State freeRegs
= RA_State
{
ra_blockassig :: BlockAssignment
-- | free machine registers
- , ra_freeregs :: {-#UNPACK#-}!FreeRegs
+ , ra_freeregs :: !freeRegs
-- | assignment of temps to locations
, ra_assig :: RegMap Loc
-- | The register allocator monad type.
-newtype RegM a
- = RegM { unReg :: RA_State -> (# RA_State, a #) }
+newtype RegM freeRegs a
+ = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }
-> BlockId -- ^ id of the current block
-> instr -- ^ branch instr on the end of the source block.
- -> RegM ([NatBasicBlock instr] -- fresh blocks of fixup code.
+ -> RegM FreeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.
, instr) -- the original branch instruction, but maybe patched to jump
-- to a fixup block first.
-> [BlockId] -- ^ branch destinations still to consider.
- -> RegM ( [NatBasicBlock instr]
+ -> RegM FreeRegs ( [NatBasicBlock instr]
, instr)
-- no more targets to consider. all done.
--
handleComponent
:: Instruction instr
- => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM [instr]
+ => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM FreeRegs [instr]
-- If the graph is acyclic then we won't get the swapping problem below.
-- In this case we can just do the moves directly, and avoid having to
-> Unique -- ^ unique of the vreg that we're moving.
-> Loc -- ^ source location.
-> Loc -- ^ destination location.
- -> RegM instr -- ^ move instruction.
+ -> RegM FreeRegs instr -- ^ move instruction.
makeMove _ vreg (InReg src) (InReg dst)
= do recordSpill (SpillJoinRR vreg)
-> BlockMap RegSet
-> [NatBasicBlock instr]
-> [SCC (LiveBasicBlock instr)]
- -> RegM [NatBasicBlock instr]
+ -> RegM FreeRegs [NatBasicBlock instr]
linearRA_SCCs _ _ blocksAcc []
= return $ reverse blocksAcc
-> [GenBasicBlock (LiveInstr instr)]
-> [[NatBasicBlock instr]]
-> Bool
- -> RegM [[NatBasicBlock instr]]
+ -> RegM FreeRegs [[NatBasicBlock instr]]
process _ _ [] [] accum _
= return $ reverse accum
:: (Outputable instr, Instruction instr)
=> BlockMap RegSet -- ^ live regs on entry to each basic block
-> LiveBasicBlock instr -- ^ block to do register allocation on
- -> RegM [NatBasicBlock instr] -- ^ block with registers allocated
+ -> RegM FreeRegs [NatBasicBlock instr] -- ^ block with registers allocated
processBlock block_live (BasicBlock id instrs)
= do initBlock id
-- | Load the freeregs and current reg assignment into the RegM state
-- for the basic block with this BlockId.
-initBlock :: BlockId -> RegM ()
+initBlock :: BlockId -> RegM FreeRegs ()
initBlock id
= do block_assig <- getBlockAssigR
case mapLookup id block_assig of
-> BlockId -- ^ id of the current block, for debugging.
-> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
- -> RegM ( [instr] -- instructions after register allocation
+ -> RegM FreeRegs
+ ( [instr] -- instructions after register allocation
, [NatBasicBlock instr]) -- fresh blocks of fixup code.
-> [instr] -- ^ accumulator for instructions already processed.
-> BlockId -- ^ the id of the current block, for debugging
-> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info.
- -> RegM
+ -> RegM FreeRegs
( [instr] -- new instructions
, [NatBasicBlock instr]) -- extra fixup blocks
-> instr
-> [Reg]
-> [Reg]
- -> RegM ([instr], [NatBasicBlock instr])
+ -> RegM FreeRegs ([instr], [NatBasicBlock instr])
genRaInsn block_live new_instrs block_id instr r_dying w_dying =
case regUsageOfInstr instr of { RU read written ->
-- -----------------------------------------------------------------------------
-- releaseRegs
-releaseRegs :: [Reg] -> RegM ()
+releaseRegs :: [Reg] -> RegM FreeRegs ()
releaseRegs regs = do
assig <- getAssigR
free <- getFreeRegsR
:: (Outputable instr, Instruction instr)
=> [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
+ -> RegM FreeRegs [instr] -- return: instructions to spill any temps that will
-- be clobbered.
saveClobberedTemps [] _
-- | Mark all these real regs as allocated,
-- and kick out their vreg assignments.
--
-clobberRegs :: [RealReg] -> RegM ()
+clobberRegs :: [RealReg] -> RegM FreeRegs ()
clobberRegs []
= return ()
-> [instr] -- spill insns
-> [RealReg] -- real registers allocated (accum.)
-> [VirtualReg] -- temps to allocate
- -> RegM ( [instr]
- , [RealReg])
+ -> RegM FreeRegs ( [instr] , [RealReg])
allocateRegsAndSpill _ _ spills alloc []
= return (spills, reverse alloc)
-> [VirtualReg]
-> UniqFM Loc
-> SpillLoc
- -> RegM ([instr], [RealReg])
+ -> RegM FreeRegs ([instr], [RealReg])
allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
= do
freeRegs <- getFreeRegsR
-> SpillLoc -- the current location of this temp
-> RealReg -- the hreg to load the temp into
-> [instr]
- -> RegM [instr]
+ -> RegM FreeRegs [instr]
loadTemp vreg (ReadMem slot) hreg spills
= do
-- | The RegM Monad
-instance Monad RegM where
+instance Monad (RegM freeRegs) where
m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
return a = RegM $ \s -> (# s, a #)
-> RegMap Loc
-> StackMap
-> UniqSupply
- -> RegM a
+ -> RegM FreeRegs a
-> (BlockAssignment, StackMap, RegAllocStats, a)
runR block_assig freeregs assig stack us thing =
-- | Make register allocator stats from its final state.
-makeRAStats :: RA_State -> RegAllocStats
+makeRAStats :: RA_State FreeRegs -> RegAllocStats
makeRAStats state
= RegAllocStats
{ ra_spillInstrs = binSpillReasons (ra_spills state) }
spillR :: Instruction instr
- => Reg -> Unique -> RegM (instr, Int)
+ => Reg -> Unique -> RegM FreeRegs (instr, Int)
spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
let (stack',slot) = getStackSlotFor stack temp
loadR :: Instruction instr
- => Reg -> Int -> RegM instr
+ => Reg -> Int -> RegM FreeRegs instr
loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
(# s, mkLoadInstr reg delta slot #)
-getFreeRegsR :: RegM FreeRegs
+getFreeRegsR :: RegM FreeRegs FreeRegs
getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
(# s, freeregs #)
-setFreeRegsR :: FreeRegs -> RegM ()
+setFreeRegsR :: FreeRegs -> RegM FreeRegs ()
setFreeRegsR regs = RegM $ \ s ->
(# s{ra_freeregs = regs}, () #)
-getAssigR :: RegM (RegMap Loc)
+getAssigR :: RegM FreeRegs (RegMap Loc)
getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
(# s, assig #)
-setAssigR :: RegMap Loc -> RegM ()
+setAssigR :: RegMap Loc -> RegM FreeRegs ()
setAssigR assig = RegM $ \ s ->
(# s{ra_assig=assig}, () #)
-getBlockAssigR :: RegM BlockAssignment
+getBlockAssigR :: RegM FreeRegs BlockAssignment
getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
(# s, assig #)
-setBlockAssigR :: BlockAssignment -> RegM ()
+setBlockAssigR :: BlockAssignment -> RegM FreeRegs ()
setBlockAssigR assig = RegM $ \ s ->
(# s{ra_blockassig = assig}, () #)
-setDeltaR :: Int -> RegM ()
+setDeltaR :: Int -> RegM FreeRegs ()
setDeltaR n = RegM $ \ s ->
(# s{ra_delta = n}, () #)
-getDeltaR :: RegM Int
+getDeltaR :: RegM FreeRegs Int
getDeltaR = RegM $ \s -> (# s, ra_delta s #)
-getUniqueR :: RegM Unique
+getUniqueR :: RegM FreeRegs Unique
getUniqueR = RegM $ \s ->
case takeUniqFromSupply (ra_us s) of
(uniq, us) -> (# s{ra_us = us}, uniq #)
-- | Record that a spill instruction was inserted, for profiling.
-recordSpill :: SpillReason -> RegM ()
+recordSpill :: SpillReason -> RegM FreeRegs ()
recordSpill spill
= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)