#if !defined(GHC_LOADED_INTO_GHCI)
#endif
module RegAlloc.Linear.State (
RA_State(..),
RegM,
runR,
spillR,
loadR,
getFreeRegsR,
setFreeRegsR,
getAssigR,
setAssigR,
getBlockAssigR,
setBlockAssigR,
setDeltaR,
getDeltaR,
getUniqueR,
recordSpill,
recordFixupBlock
)
where
import GhcPrelude
import RegAlloc.Linear.Stats
import RegAlloc.Linear.StackMap
import RegAlloc.Linear.Base
import RegAlloc.Liveness
import Instruction
import Reg
import BlockId
import DynFlags
import Unique
import UniqSupply
import Control.Monad (liftM, ap)
#if !defined(GHC_LOADED_INTO_GHCI)
type RA_Result freeRegs a = (# RA_State freeRegs, a #)
pattern RA_Result :: a -> b -> (# a, b #)
pattern RA_Result a b = (# a, b #)
#else
data RA_Result freeRegs a = RA_Result !(RA_State freeRegs) !a
#endif
newtype RegM freeRegs a
= RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
instance Functor (RegM freeRegs) where
fmap = liftM
instance Applicative (RegM freeRegs) where
pure a = RegM $ \s -> RA_Result s a
(<*>) = ap
instance Monad (RegM freeRegs) where
m >>= k = RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
instance HasDynFlags (RegM a) where
getDynFlags = RegM $ \s -> RA_Result s (ra_DynFlags s)
runR :: DynFlags
-> BlockAssignment freeRegs
-> freeRegs
-> RegMap Loc
-> StackMap
-> UniqSupply
-> RegM freeRegs a
-> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
runR dflags 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_DynFlags = dflags
, 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 = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack0} ->
let dflags = ra_DynFlags s
(stack1,slot) = getStackSlotFor stack0 temp
instr = mkSpillInstr dflags reg delta slot
in
RA_Result s{ra_stack=stack1} (instr,slot)
loadR :: Instruction instr
=> Reg -> Int -> RegM freeRegs instr
loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
let dflags = ra_DynFlags s
in RA_Result s (mkLoadInstr dflags reg delta slot)
getFreeRegsR :: RegM freeRegs freeRegs
getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
RA_Result s freeregs
setFreeRegsR :: freeRegs -> RegM freeRegs ()
setFreeRegsR regs = RegM $ \ s ->
RA_Result s{ra_freeregs = regs} ()
getAssigR :: RegM freeRegs (RegMap Loc)
getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
RA_Result s assig
setAssigR :: RegMap Loc -> RegM freeRegs ()
setAssigR assig = RegM $ \ s ->
RA_Result s{ra_assig=assig} ()
getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
RA_Result s assig
setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR assig = RegM $ \ s ->
RA_Result s{ra_blockassig = assig} ()
setDeltaR :: Int -> RegM freeRegs ()
setDeltaR n = RegM $ \ s ->
RA_Result s{ra_delta = n} ()
getDeltaR :: RegM freeRegs Int
getDeltaR = RegM $ \s -> RA_Result s (ra_delta s)
getUniqueR :: RegM freeRegs Unique
getUniqueR = RegM $ \s ->
case takeUniqFromSupply (ra_us s) of
(uniq, us) -> RA_Result s{ra_us = us} uniq
recordSpill :: SpillReason -> RegM freeRegs ()
recordSpill spill
= RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()
recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
recordFixupBlock from between to
= RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()