From: Ian Lynagh Date: Tue, 31 May 2011 16:07:04 +0000 (+0100) Subject: Parameterise the RegM monad on the FreeRegs type X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=59244201b672b9d6f728edcf7e2e02a61fbe278f Parameterise the RegM monad on the FreeRegs type --- diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs index 087ab9c..fc8d4ed 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Base.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs @@ -101,7 +101,7 @@ data RegAllocStats -- | The register alloctor state -data RA_State +data RA_State freeRegs = RA_State { @@ -110,7 +110,7 @@ data RA_State ra_blockassig :: BlockAssignment -- | free machine registers - , ra_freeregs :: {-#UNPACK#-}!FreeRegs + , ra_freeregs :: !freeRegs -- | assignment of temps to locations , ra_assig :: RegMap Loc @@ -131,7 +131,7 @@ data RA_State -- | 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 #) } diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index ef6ae9b..6a62f07 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -42,7 +42,7 @@ joinToTargets -> 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. @@ -68,7 +68,7 @@ joinToTargets' -> [BlockId] -- ^ branch destinations still to consider. - -> RegM ( [NatBasicBlock instr] + -> RegM FreeRegs ( [NatBasicBlock instr] , instr) -- no more targets to consider. all done. @@ -262,7 +262,7 @@ expandNode vreg src dst -- 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 @@ -317,7 +317,7 @@ makeMove -> 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) diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 8a8280e..ba8cdce 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -183,7 +183,7 @@ linearRA_SCCs :: (Instruction instr, Outputable instr) -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] - -> RegM [NatBasicBlock instr] + -> RegM FreeRegs [NatBasicBlock instr] linearRA_SCCs _ _ blocksAcc [] = return $ reverse blocksAcc @@ -220,7 +220,7 @@ process :: (Instruction instr, Outputable instr) -> [GenBasicBlock (LiveInstr instr)] -> [[NatBasicBlock instr]] -> Bool - -> RegM [[NatBasicBlock instr]] + -> RegM FreeRegs [[NatBasicBlock instr]] process _ _ [] [] accum _ = return $ reverse accum @@ -260,7 +260,7 @@ processBlock :: (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 @@ -271,7 +271,7 @@ processBlock block_live (BasicBlock id instrs) -- | 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 @@ -298,7 +298,8 @@ linearRA -> 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. @@ -323,7 +324,7 @@ raInsn -> [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 @@ -388,7 +389,7 @@ genRaInsn :: (Instruction instr, Outputable instr) -> 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 -> @@ -485,7 +486,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = -- ----------------------------------------------------------------------------- -- releaseRegs -releaseRegs :: [Reg] -> RegM () +releaseRegs :: [Reg] -> RegM FreeRegs () releaseRegs regs = do assig <- getAssigR free <- getFreeRegsR @@ -523,7 +524,7 @@ saveClobberedTemps :: (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 [] _ @@ -562,7 +563,7 @@ saveClobberedTemps clobbered dying -- | Mark all these real regs as allocated, -- and kick out their vreg assignments. -- -clobberRegs :: [RealReg] -> RegM () +clobberRegs :: [RealReg] -> RegM FreeRegs () clobberRegs [] = return () @@ -618,8 +619,7 @@ allocateRegsAndSpill -> [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) @@ -666,7 +666,7 @@ allocRegsAndSpill_spill :: (Instruction instr, Outputable instr) -> [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 @@ -767,7 +767,7 @@ loadTemp -> 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 diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index 234701c..7793fee 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -42,7 +42,7 @@ import UniqSupply -- | 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 #) @@ -53,7 +53,7 @@ runR :: BlockAssignment -> RegMap Loc -> StackMap -> UniqSupply - -> RegM a + -> RegM FreeRegs a -> (BlockAssignment, StackMap, RegAllocStats, a) runR block_assig freeregs assig stack us thing = @@ -76,14 +76,14 @@ 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 @@ -93,49 +93,49 @@ spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> 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}, () #)