{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
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 Control.Monad (ap)
type RA_Result freeRegs a = (# RA_State freeRegs, a #)
pattern RA_Result :: a -> b -> (# a, b #)
pattern $mRA_Result :: forall {r} {a} {b}.
(# a, b #) -> (a -> b -> r) -> ((# #) -> r) -> r
$bRA_Result :: forall a b. a -> b -> (# a, b #)
RA_Result a b = (# a, b #)
{-# COMPLETE RA_Result #-}
newtype RegM freeRegs a
= RegM { forall freeRegs a.
RegM freeRegs a -> RA_State freeRegs -> RA_Result freeRegs a
unReg :: RA_State freeRegs -> RA_Result freeRegs a }
deriving (forall a b. a -> RegM freeRegs b -> RegM freeRegs a
forall a b. (a -> b) -> RegM freeRegs a -> RegM freeRegs b
forall freeRegs a b. a -> RegM freeRegs b -> RegM freeRegs a
forall freeRegs a b. (a -> b) -> RegM freeRegs a -> RegM freeRegs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RegM freeRegs b -> RegM freeRegs a
$c<$ :: forall freeRegs a b. a -> RegM freeRegs b -> RegM freeRegs a
fmap :: forall a b. (a -> b) -> RegM freeRegs a -> RegM freeRegs b
$cfmap :: forall freeRegs a b. (a -> b) -> RegM freeRegs a -> RegM freeRegs b
Functor)
instance Applicative (RegM freeRegs) where
pure :: forall a. a -> RegM freeRegs a
pure a
a = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \RA_State freeRegs
s -> forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s a
a
<*> :: forall a b.
RegM freeRegs (a -> b) -> RegM freeRegs a -> RegM freeRegs b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad (RegM freeRegs) where
RegM freeRegs a
m >>= :: forall a b.
RegM freeRegs a -> (a -> RegM freeRegs b) -> RegM freeRegs b
>>= a -> RegM freeRegs b
k = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \RA_State freeRegs
s -> case forall freeRegs a.
RegM freeRegs a -> RA_State freeRegs -> RA_Result freeRegs a
unReg RegM freeRegs a
m RA_State freeRegs
s of { RA_Result RA_State freeRegs
s a
a -> forall freeRegs a.
RegM freeRegs a -> RA_State freeRegs -> RA_Result freeRegs a
unReg (a -> RegM freeRegs b
k a
a) RA_State freeRegs
s }
getConfig :: RegM a NCGConfig
getConfig :: forall a. RegM a NCGConfig
getConfig = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \RA_State a
s -> forall a b. a -> b -> (# a, b #)
RA_Result RA_State a
s (forall freeRegs. RA_State freeRegs -> NCGConfig
ra_config RA_State a
s)
getPlatform :: RegM a Platform
getPlatform :: forall a. RegM a Platform
getPlatform = NCGConfig -> Platform
ncgPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. RegM a NCGConfig
getConfig
runR :: NCGConfig
-> BlockAssignment freeRegs
-> freeRegs
-> RegMap Loc
-> StackMap
-> UniqSupply
-> RegM freeRegs a
-> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
runR :: forall freeRegs a.
NCGConfig
-> BlockAssignment freeRegs
-> freeRegs
-> RegMap Loc
-> StackMap
-> UniqSupply
-> RegM freeRegs a
-> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
runR NCGConfig
config BlockAssignment freeRegs
block_assig freeRegs
freeregs RegMap Loc
assig StackMap
stack UniqSupply
us RegM freeRegs a
thing =
case forall freeRegs a.
RegM freeRegs a -> RA_State freeRegs -> RA_Result freeRegs a
unReg RegM freeRegs a
thing
(RA_State
{ ra_blockassig :: BlockAssignment freeRegs
ra_blockassig = BlockAssignment freeRegs
block_assig
, ra_freeregs :: freeRegs
ra_freeregs = freeRegs
freeregs
, ra_assig :: RegMap Loc
ra_assig = RegMap Loc
assig
, ra_delta :: Int
ra_delta = Int
0
, ra_stack :: StackMap
ra_stack = StackMap
stack
, ra_us :: UniqSupply
ra_us = UniqSupply
us
, ra_spills :: [SpillReason]
ra_spills = []
, ra_config :: NCGConfig
ra_config = NCGConfig
config
, ra_fixups :: [(BlockId, BlockId, BlockId)]
ra_fixups = [] })
of
RA_Result RA_State freeRegs
state a
returned_thing
-> (forall freeRegs. RA_State freeRegs -> BlockAssignment freeRegs
ra_blockassig RA_State freeRegs
state, forall freeRegs. RA_State freeRegs -> StackMap
ra_stack RA_State freeRegs
state, forall freeRegs. RA_State freeRegs -> RegAllocStats
makeRAStats RA_State freeRegs
state, a
returned_thing)
makeRAStats :: RA_State freeRegs -> RegAllocStats
makeRAStats :: forall freeRegs. RA_State freeRegs -> RegAllocStats
makeRAStats RA_State freeRegs
state
= RegAllocStats
{ ra_spillInstrs :: UniqFM Unique [Int]
ra_spillInstrs = [SpillReason] -> UniqFM Unique [Int]
binSpillReasons (forall freeRegs. RA_State freeRegs -> [SpillReason]
ra_spills RA_State freeRegs
state)
, ra_fixupList :: [(BlockId, BlockId, BlockId)]
ra_fixupList = forall freeRegs. RA_State freeRegs -> [(BlockId, BlockId, BlockId)]
ra_fixups RA_State freeRegs
state }
spillR :: Instruction instr
=> Reg -> Unique -> RegM freeRegs ([instr], Int)
spillR :: forall instr freeRegs.
Instruction instr =>
Reg -> Unique -> RegM freeRegs ([instr], Int)
spillR Reg
reg Unique
temp = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \RA_State freeRegs
s ->
let (StackMap
stack1,Int
slot) = StackMap -> Unique -> (StackMap, Int)
getStackSlotFor (forall freeRegs. RA_State freeRegs -> StackMap
ra_stack RA_State freeRegs
s) Unique
temp
instr :: [instr]
instr = forall instr.
Instruction instr =>
NCGConfig -> Reg -> Int -> Int -> [instr]
mkSpillInstr (forall freeRegs. RA_State freeRegs -> NCGConfig
ra_config RA_State freeRegs
s) Reg
reg (forall freeRegs. RA_State freeRegs -> Int
ra_delta RA_State freeRegs
s) Int
slot
in
forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s{ra_stack :: StackMap
ra_stack=StackMap
stack1} ([instr]
instr,Int
slot)
loadR :: Instruction instr
=> Reg -> Int -> RegM freeRegs [instr]
loadR :: forall instr freeRegs.
Instruction instr =>
Reg -> Int -> RegM freeRegs [instr]
loadR Reg
reg Int
slot = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \RA_State freeRegs
s ->
forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s (forall instr.
Instruction instr =>
NCGConfig -> Reg -> Int -> Int -> [instr]
mkLoadInstr (forall freeRegs. RA_State freeRegs -> NCGConfig
ra_config RA_State freeRegs
s) Reg
reg (forall freeRegs. RA_State freeRegs -> Int
ra_delta RA_State freeRegs
s) Int
slot)
getFreeRegsR :: RegM freeRegs freeRegs
getFreeRegsR :: forall freeRegs. RegM freeRegs freeRegs
getFreeRegsR = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \ s :: RA_State freeRegs
s@RA_State{ra_freeregs :: forall freeRegs. RA_State freeRegs -> freeRegs
ra_freeregs = freeRegs
freeregs} ->
forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s freeRegs
freeregs
setFreeRegsR :: freeRegs -> RegM freeRegs ()
setFreeRegsR :: forall freeRegs. freeRegs -> RegM freeRegs ()
setFreeRegsR freeRegs
regs = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \ RA_State freeRegs
s ->
forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s{ra_freeregs :: freeRegs
ra_freeregs = freeRegs
regs} ()
getAssigR :: RegM freeRegs (RegMap Loc)
getAssigR :: forall freeRegs. RegM freeRegs (RegMap Loc)
getAssigR = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \ s :: RA_State freeRegs
s@RA_State{ra_assig :: forall freeRegs. RA_State freeRegs -> RegMap Loc
ra_assig = RegMap Loc
assig} ->
forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s RegMap Loc
assig
setAssigR :: RegMap Loc -> RegM freeRegs ()
setAssigR :: forall freeRegs. RegMap Loc -> RegM freeRegs ()
setAssigR RegMap Loc
assig = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \ RA_State freeRegs
s ->
forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s{ra_assig :: RegMap Loc
ra_assig=RegMap Loc
assig} ()
getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR :: forall freeRegs. RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \ s :: RA_State freeRegs
s@RA_State{ra_blockassig :: forall freeRegs. RA_State freeRegs -> BlockAssignment freeRegs
ra_blockassig = BlockAssignment freeRegs
assig} ->
forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s BlockAssignment freeRegs
assig
setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR :: forall freeRegs. BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR BlockAssignment freeRegs
assig = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \ RA_State freeRegs
s ->
forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s{ra_blockassig :: BlockAssignment freeRegs
ra_blockassig = BlockAssignment freeRegs
assig} ()
setDeltaR :: Int -> RegM freeRegs ()
setDeltaR :: forall freeRegs. Int -> RegM freeRegs ()
setDeltaR Int
n = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \ RA_State freeRegs
s ->
forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s{ra_delta :: Int
ra_delta = Int
n} ()
getDeltaR :: RegM freeRegs Int
getDeltaR :: forall freeRegs. RegM freeRegs Int
getDeltaR = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \RA_State freeRegs
s -> forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s (forall freeRegs. RA_State freeRegs -> Int
ra_delta RA_State freeRegs
s)
getUniqueR :: RegM freeRegs Unique
getUniqueR :: forall freeRegs. RegM freeRegs Unique
getUniqueR = forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \RA_State freeRegs
s ->
case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (forall freeRegs. RA_State freeRegs -> UniqSupply
ra_us RA_State freeRegs
s) of
(Unique
uniq, UniqSupply
us) -> forall a b. a -> b -> (# a, b #)
RA_Result RA_State freeRegs
s{ra_us :: UniqSupply
ra_us = UniqSupply
us} Unique
uniq
recordSpill :: SpillReason -> RegM freeRegs ()
recordSpill :: forall freeRegs. SpillReason -> RegM freeRegs ()
recordSpill SpillReason
spill
= forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \RA_State freeRegs
s -> forall a b. a -> b -> (# a, b #)
RA_Result (RA_State freeRegs
s { ra_spills :: [SpillReason]
ra_spills = SpillReason
spill forall a. a -> [a] -> [a]
: forall freeRegs. RA_State freeRegs -> [SpillReason]
ra_spills RA_State freeRegs
s }) ()
recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
recordFixupBlock :: forall freeRegs. BlockId -> BlockId -> BlockId -> RegM freeRegs ()
recordFixupBlock BlockId
from BlockId
between BlockId
to
= forall freeRegs a.
(RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
RegM forall a b. (a -> b) -> a -> b
$ \RA_State freeRegs
s -> forall a b. a -> b -> (# a, b #)
RA_Result (RA_State freeRegs
s { ra_fixups :: [(BlockId, BlockId, BlockId)]
ra_fixups = (BlockId
from,BlockId
between,BlockId
to) forall a. a -> [a] -> [a]
: forall freeRegs. RA_State freeRegs -> [(BlockId, BlockId, BlockId)]
ra_fixups RA_State freeRegs
s }) ()