module GHC.CmmToAsm.Reg.Linear.State (
RA_State(..),
RegM,
runR,
spillR,
loadR,
getFreeRegsR,
setFreeRegsR,
getAssigR,
setAssigR,
getBlockAssigR,
setBlockAssigR,
setDeltaR,
getDeltaR,
getUniqueR,
getConfig,
getPlatform,
recordSpill,
recordFixupBlock
)
where
import GHC.Prelude
import GHC.CmmToAsm.Reg.Linear.Stats
import GHC.CmmToAsm.Reg.Linear.StackMap
import GHC.CmmToAsm.Reg.Linear.Base
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Config
import GHC.Platform.Reg
import GHC.Cmm.BlockId
import GHC.Platform
import GHC.Types.Unique
import GHC.Types.Unique.Supply
import GHC.Exts (oneShot)
import Control.Monad (ap)
type RA_Result freeRegs a = (# RA_State freeRegs, a #)
pattern RA_Result :: a -> b -> (# a, b #)
pattern RA_Result a b = (# a, b #)
newtype RegM freeRegs a
= RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
deriving (Functor)
mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
mkRegM f = RegM (oneShot f)
instance Applicative (RegM freeRegs) where
pure a = mkRegM $ \s -> RA_Result s a
(<*>) = ap
instance Monad (RegM freeRegs) where
m >>= k = mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
getConfig :: RegM a NCGConfig
getConfig = mkRegM $ \s -> RA_Result s (ra_config s)
getPlatform :: RegM a Platform
getPlatform = ncgPlatform <$> getConfig
runR :: NCGConfig
-> BlockAssignment freeRegs
-> freeRegs
-> RegMap Loc
-> StackMap
-> UniqSupply
-> RegM freeRegs a
-> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
runR config 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 = []
, ra_config = config
, ra_fixups = [] })
of
RA_Result state returned_thing
-> (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing)
makeRAStats :: RA_State freeRegs -> RegAllocStats
makeRAStats state
= RegAllocStats
{ ra_spillInstrs = binSpillReasons (ra_spills state)
, ra_fixupList = ra_fixups state }
spillR :: Instruction instr
=> Reg -> Unique -> RegM freeRegs ([instr], Int)
spillR reg temp = mkRegM $ \s ->
let (stack1,slot) = getStackSlotFor (ra_stack s) temp
instr = mkSpillInstr (ra_config s) reg (ra_delta s) slot
in
RA_Result s{ra_stack=stack1} (instr,slot)
loadR :: Instruction instr
=> Reg -> Int -> RegM freeRegs [instr]
loadR reg slot = mkRegM $ \s ->
RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)
getFreeRegsR :: RegM freeRegs freeRegs
getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} ->
RA_Result s freeregs
setFreeRegsR :: freeRegs -> RegM freeRegs ()
setFreeRegsR regs = mkRegM $ \ s ->
RA_Result s{ra_freeregs = regs} ()
getAssigR :: RegM freeRegs (RegMap Loc)
getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} ->
RA_Result s assig
setAssigR :: RegMap Loc -> RegM freeRegs ()
setAssigR assig = mkRegM $ \ s ->
RA_Result s{ra_assig=assig} ()
getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} ->
RA_Result s assig
setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR assig = mkRegM $ \ s ->
RA_Result s{ra_blockassig = assig} ()
setDeltaR :: Int -> RegM freeRegs ()
setDeltaR n = mkRegM $ \ s ->
RA_Result s{ra_delta = n} ()
getDeltaR :: RegM freeRegs Int
getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s)
getUniqueR :: RegM freeRegs Unique
getUniqueR = mkRegM $ \s ->
case takeUniqFromSupply (ra_us s) of
(uniq, us) -> RA_Result s{ra_us = us} uniq
recordSpill :: SpillReason -> RegM freeRegs ()
recordSpill spill
= mkRegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()
recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
recordFixupBlock from between to
= mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()