{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.CmmToAsm.Monad (
NcgImpl(..),
NatM_State(..), mkNatM_State,
NatM,
initNat,
addImportNat,
addNodeBetweenNat,
addImmediateSuccessorNat,
updateCfgNat,
getUniqueNat,
setDeltaNat,
getConfig,
getPlatform,
getDeltaNat,
getThisModuleNat,
getBlockIdNat,
getNewLabelNat,
getNewRegNat,
getPicBaseMaybeNat,
getPicBaseNat,
getCfgWeights,
getFileId,
getDebugBlock,
DwarfFiles,
Reg64(..), RegCode64(..),
getNewReg64, localReg64
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Reg
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Types
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.CLabel ( CLabel )
import GHC.Cmm.DebugBlock
import GHC.Cmm.Expr (LocalReg (..), isWord64)
import GHC.Data.FastString ( FastString )
import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Types.Unique ( Unique )
import GHC.Unit.Module
import GHC.Utils.Outputable (SDoc, HDoc, ppr)
import GHC.Utils.Panic (pprPanic)
import GHC.Utils.Monad.State.Strict (State (..), runState, state)
import GHC.Utils.Misc
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.CFG.Weight
data NcgImpl statics instr jumpDest = NcgImpl {
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NCGConfig
ncgConfig :: !NCGConfig,
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> RawCmmDecl -> NatM [NatCmmDecl statics instr]
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> instr -> Maybe (NatCmmDecl statics instr)
generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> jumpDest -> Maybe BlockId
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> instr -> Maybe jumpDest
canShortcut :: instr -> Maybe jumpDest,
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> (BlockId -> Maybe jumpDest) -> statics -> statics
shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> (BlockId -> Maybe jumpDest) -> instr -> instr
shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
pprNatCmmDeclS :: NatCmmDecl statics instr -> SDoc,
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> HDoc
pprNatCmmDeclH :: NatCmmDecl statics instr -> HDoc,
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> Int
maxSpillSlots :: Int,
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> [RealReg]
allocatableRegs :: [RealReg],
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
ncgAllocMoreStack :: Int -> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> LabelMap RawCmmStatics
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
ncgMakeFarBranches :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
:: [instr] -> [UnwindPoint],
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Maybe CFG
-> LabelMap RawCmmStatics
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
invertCondBranches :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
}
data NatM_State
= NatM_State {
NatM_State -> UniqSupply
natm_us :: UniqSupply,
NatM_State -> Int
natm_delta :: Int,
NatM_State -> [CLabel]
natm_imports :: [(CLabel)],
NatM_State -> Maybe Reg
natm_pic :: Maybe Reg,
NatM_State -> NCGConfig
natm_config :: NCGConfig,
NatM_State -> DwarfFiles
natm_fileid :: DwarfFiles,
NatM_State -> LabelMap DebugBlock
natm_debug_map :: LabelMap DebugBlock,
NatM_State -> CFG
natm_cfg :: CFG
}
type DwarfFiles = UniqFM FastString (FastString, Int)
newtype NatM a = NatM' (State NatM_State a)
deriving stock ((forall a b. (a -> b) -> NatM a -> NatM b)
-> (forall a b. a -> NatM b -> NatM a) -> Functor NatM
forall a b. a -> NatM b -> NatM a
forall a b. (a -> b) -> NatM a -> NatM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> NatM a -> NatM b
fmap :: forall a b. (a -> b) -> NatM a -> NatM b
$c<$ :: forall a b. a -> NatM b -> NatM a
<$ :: forall a b. a -> NatM b -> NatM a
Functor)
deriving (Functor NatM
Functor NatM =>
(forall a. a -> NatM a)
-> (forall a b. NatM (a -> b) -> NatM a -> NatM b)
-> (forall a b c. (a -> b -> c) -> NatM a -> NatM b -> NatM c)
-> (forall a b. NatM a -> NatM b -> NatM b)
-> (forall a b. NatM a -> NatM b -> NatM a)
-> Applicative NatM
forall a. a -> NatM a
forall a b. NatM a -> NatM b -> NatM a
forall a b. NatM a -> NatM b -> NatM b
forall a b. NatM (a -> b) -> NatM a -> NatM b
forall a b c. (a -> b -> c) -> NatM a -> NatM b -> NatM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> NatM a
pure :: forall a. a -> NatM a
$c<*> :: forall a b. NatM (a -> b) -> NatM a -> NatM b
<*> :: forall a b. NatM (a -> b) -> NatM a -> NatM b
$cliftA2 :: forall a b c. (a -> b -> c) -> NatM a -> NatM b -> NatM c
liftA2 :: forall a b c. (a -> b -> c) -> NatM a -> NatM b -> NatM c
$c*> :: forall a b. NatM a -> NatM b -> NatM b
*> :: forall a b. NatM a -> NatM b -> NatM b
$c<* :: forall a b. NatM a -> NatM b -> NatM a
<* :: forall a b. NatM a -> NatM b -> NatM a
Applicative, Applicative NatM
Applicative NatM =>
(forall a b. NatM a -> (a -> NatM b) -> NatM b)
-> (forall a b. NatM a -> NatM b -> NatM b)
-> (forall a. a -> NatM a)
-> Monad NatM
forall a. a -> NatM a
forall a b. NatM a -> NatM b -> NatM b
forall a b. NatM a -> (a -> NatM b) -> NatM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. NatM a -> (a -> NatM b) -> NatM b
>>= :: forall a b. NatM a -> (a -> NatM b) -> NatM b
$c>> :: forall a b. NatM a -> NatM b -> NatM b
>> :: forall a b. NatM a -> NatM b -> NatM b
$creturn :: forall a. a -> NatM a
return :: forall a. a -> NatM a
Monad) via State NatM_State
pattern NatM :: (NatM_State -> (a, NatM_State)) -> NatM a
pattern $mNatM :: forall {r} {a}.
NatM a
-> ((NatM_State -> (a, NatM_State)) -> r) -> ((# #) -> r) -> r
$bNatM :: forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM f <- NatM' (runState -> f)
where NatM NatM_State -> (a, NatM_State)
f = State NatM_State a -> NatM a
forall a. State NatM_State a -> NatM a
NatM' ((NatM_State -> (a, NatM_State)) -> State NatM_State a
forall s a. (s -> (a, s)) -> State s a
state NatM_State -> (a, NatM_State)
f)
{-# COMPLETE NatM #-}
unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat :: forall a. NatM a -> NatM_State -> (a, NatM_State)
unNat (NatM NatM_State -> (a, NatM_State)
a) = NatM_State -> (a, NatM_State)
a
mkNatM_State :: UniqSupply -> Int -> NCGConfig ->
DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
mkNatM_State :: UniqSupply
-> Int
-> NCGConfig
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
mkNatM_State UniqSupply
us Int
delta NCGConfig
config
= \DwarfFiles
dwf LabelMap DebugBlock
dbg CFG
cfg ->
NatM_State
{ natm_us :: UniqSupply
natm_us = UniqSupply
us
, natm_delta :: Int
natm_delta = Int
delta
, natm_imports :: [CLabel]
natm_imports = []
, natm_pic :: Maybe Reg
natm_pic = Maybe Reg
forall a. Maybe a
Nothing
, natm_config :: NCGConfig
natm_config = NCGConfig
config
, natm_fileid :: DwarfFiles
natm_fileid = DwarfFiles
dwf
, natm_debug_map :: LabelMap DebugBlock
natm_debug_map = LabelMap DebugBlock
dbg
, natm_cfg :: CFG
natm_cfg = CFG
cfg
}
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat :: forall a. NatM_State -> NatM a -> (a, NatM_State)
initNat = (NatM a -> NatM_State -> (a, NatM_State))
-> NatM_State -> NatM a -> (a, NatM_State)
forall a b c. (a -> b -> c) -> b -> a -> c
flip NatM a -> NatM_State -> (a, NatM_State)
forall a. NatM a -> NatM_State -> (a, NatM_State)
unNat
instance MonadUnique NatM where
getUniqueSupplyM :: NatM UniqSupply
getUniqueSupplyM = (NatM_State -> (UniqSupply, NatM_State)) -> NatM UniqSupply
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> (UniqSupply, NatM_State)) -> NatM UniqSupply)
-> (NatM_State -> (UniqSupply, NatM_State)) -> NatM UniqSupply
forall a b. (a -> b) -> a -> b
$ \NatM_State
st ->
case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply (NatM_State -> UniqSupply
natm_us NatM_State
st) of
(UniqSupply
us1, UniqSupply
us2) -> (UniqSupply
us1, NatM_State
st {natm_us = us2})
getUniqueM :: NatM Unique
getUniqueM = (NatM_State -> (Unique, NatM_State)) -> NatM Unique
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> (Unique, NatM_State)) -> NatM Unique)
-> (NatM_State -> (Unique, NatM_State)) -> NatM Unique
forall a b. (a -> b) -> a -> b
$ \NatM_State
st ->
case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NatM_State -> UniqSupply
natm_us NatM_State
st) of
(Unique
uniq, UniqSupply
us') -> (Unique
uniq, NatM_State
st {natm_us = us'})
getUniqueNat :: NatM Unique
getUniqueNat :: NatM Unique
getUniqueNat = (NatM_State -> (Unique, NatM_State)) -> NatM Unique
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> (Unique, NatM_State)) -> NatM Unique)
-> (NatM_State -> (Unique, NatM_State)) -> NatM Unique
forall a b. (a -> b) -> a -> b
$ \ NatM_State
st ->
case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (UniqSupply -> (Unique, UniqSupply))
-> UniqSupply -> (Unique, UniqSupply)
forall a b. (a -> b) -> a -> b
$ NatM_State -> UniqSupply
natm_us NatM_State
st of
(Unique
uniq, UniqSupply
us') -> (Unique
uniq, NatM_State
st {natm_us = us'})
getDeltaNat :: NatM Int
getDeltaNat :: NatM Int
getDeltaNat = (NatM_State -> (Int, NatM_State)) -> NatM Int
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> (Int, NatM_State)) -> NatM Int)
-> (NatM_State -> (Int, NatM_State)) -> NatM Int
forall a b. (a -> b) -> a -> b
$ \ NatM_State
st -> (NatM_State -> Int
natm_delta NatM_State
st, NatM_State
st)
getCfgWeights :: NatM Weights
getCfgWeights :: NatM Weights
getCfgWeights = (NatM_State -> (Weights, NatM_State)) -> NatM Weights
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> (Weights, NatM_State)) -> NatM Weights)
-> (NatM_State -> (Weights, NatM_State)) -> NatM Weights
forall a b. (a -> b) -> a -> b
$ \ NatM_State
st -> (NCGConfig -> Weights
ncgCfgWeights (NatM_State -> NCGConfig
natm_config NatM_State
st), NatM_State
st)
setDeltaNat :: Int -> NatM ()
setDeltaNat :: Int -> NatM ()
setDeltaNat Int
delta = (NatM_State -> ((), NatM_State)) -> NatM ()
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> ((), NatM_State)) -> NatM ())
-> (NatM_State -> ((), NatM_State)) -> NatM ()
forall a b. (a -> b) -> a -> b
$ \ NatM_State
st -> ((), NatM_State
st {natm_delta = delta})
getThisModuleNat :: NatM Module
getThisModuleNat :: NatM Module
getThisModuleNat = (NatM_State -> (Module, NatM_State)) -> NatM Module
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> (Module, NatM_State)) -> NatM Module)
-> (NatM_State -> (Module, NatM_State)) -> NatM Module
forall a b. (a -> b) -> a -> b
$ \ NatM_State
st -> (NCGConfig -> Module
ncgThisModule (NCGConfig -> Module) -> NCGConfig -> Module
forall a b. (a -> b) -> a -> b
$ NatM_State -> NCGConfig
natm_config NatM_State
st, NatM_State
st)
instance HasModule NatM where
getModule :: NatM Module
getModule = NatM Module
getThisModuleNat
addImportNat :: CLabel -> NatM ()
addImportNat :: CLabel -> NatM ()
addImportNat CLabel
imp
= (NatM_State -> ((), NatM_State)) -> NatM ()
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> ((), NatM_State)) -> NatM ())
-> (NatM_State -> ((), NatM_State)) -> NatM ()
forall a b. (a -> b) -> a -> b
$ \ NatM_State
st -> ((), NatM_State
st {natm_imports = imp : natm_imports st})
updateCfgNat :: (CFG -> CFG) -> NatM ()
updateCfgNat :: (CFG -> CFG) -> NatM ()
updateCfgNat CFG -> CFG
f
= (NatM_State -> ((), NatM_State)) -> NatM ()
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> ((), NatM_State)) -> NatM ())
-> (NatM_State -> ((), NatM_State)) -> NatM ()
forall a b. (a -> b) -> a -> b
$ \ NatM_State
st -> let !cfg' :: CFG
cfg' = CFG -> CFG
f (NatM_State -> CFG
natm_cfg NatM_State
st)
in ((), NatM_State
st { natm_cfg = cfg'})
addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
addNodeBetweenNat BlockId
from BlockId
between BlockId
to
= do Weights
weights <- NatM Weights
getCfgWeights
let jmpWeight :: EdgeWeight
jmpWeight = Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Weights -> Int
uncondWeight Weights
weights)
(CFG -> CFG) -> NatM ()
updateCfgNat (EdgeWeight -> BlockId -> BlockId -> BlockId -> CFG -> CFG
updateCfg EdgeWeight
jmpWeight BlockId
from BlockId
between BlockId
to)
where
updateCfg :: EdgeWeight -> BlockId -> BlockId -> BlockId -> CFG -> CFG
updateCfg EdgeWeight
weight BlockId
from BlockId
between BlockId
old CFG
m
| Just EdgeInfo
info <- BlockId -> BlockId -> CFG -> Maybe EdgeInfo
getEdgeInfo BlockId
from BlockId
old CFG
m
= BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
addEdge BlockId
from BlockId
between EdgeInfo
info (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
addWeightEdge BlockId
between BlockId
old EdgeWeight
weight (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
BlockId -> BlockId -> CFG -> CFG
delEdge BlockId
from BlockId
old (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ CFG
m
| Bool
otherwise
= String -> SDoc -> CFG
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Failed to update cfg: Untracked edge" ((BlockId, BlockId) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (BlockId
from,BlockId
to))
addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
addImmediateSuccessorNat BlockId
block BlockId
succ = do
Weights
weights <- NatM Weights
getCfgWeights
(CFG -> CFG) -> NatM ()
updateCfgNat (Weights -> BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor Weights
weights BlockId
block BlockId
succ)
getBlockIdNat :: NatM BlockId
getBlockIdNat :: NatM BlockId
getBlockIdNat
= Unique -> BlockId
mkBlockId (Unique -> BlockId) -> NatM Unique -> NatM BlockId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM Unique
getUniqueNat
getNewLabelNat :: NatM CLabel
getNewLabelNat :: NatM CLabel
getNewLabelNat
= BlockId -> CLabel
blockLbl (BlockId -> CLabel) -> NatM BlockId -> NatM CLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM BlockId
getBlockIdNat
getNewRegNat :: Format -> NatM Reg
getNewRegNat :: Format -> NatM Reg
getNewRegNat Format
rep
= do Unique
u <- NatM Unique
getUniqueNat
Platform
platform <- NatM Platform
getPlatform
Reg -> NatM Reg
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Platform -> Unique -> Format -> VirtualReg
targetMkVirtualReg Platform
platform Unique
u Format
rep)
data Reg64 = Reg64
!Reg
!Reg
data RegCode64 code = RegCode64
code
!Reg
!Reg
getNewReg64 :: NatM Reg64
getNewReg64 :: NatM Reg64
getNewReg64 = do
let rep :: Format
rep = Format
II32
Unique
u <- NatM Unique
getUniqueNat
Platform
platform <- NatM Platform
getPlatform
let vLo :: VirtualReg
vLo = Platform -> Unique -> Format -> VirtualReg
targetMkVirtualReg Platform
platform Unique
u Format
rep
let lo :: Reg
lo = VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Platform -> Unique -> Format -> VirtualReg
targetMkVirtualReg Platform
platform Unique
u Format
rep
let hi :: Reg
hi = VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ VirtualReg -> VirtualReg
getHiVirtualRegFromLo VirtualReg
vLo
Reg64 -> NatM Reg64
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg64 -> NatM Reg64) -> Reg64 -> NatM Reg64
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> Reg64
Reg64 Reg
hi Reg
lo
localReg64 :: HasDebugCallStack => LocalReg -> Reg64
localReg64 :: HasDebugCallStack => LocalReg -> Reg64
localReg64 (LocalReg Unique
vu CmmType
ty)
| CmmType -> Bool
isWord64 CmmType
ty = let lo :: Reg
lo = VirtualReg -> Reg
RegVirtual (Unique -> VirtualReg
VirtualRegI Unique
vu)
hi :: Reg
hi = Reg -> Reg
getHiVRegFromLo Reg
lo
in Reg -> Reg -> Reg64
Reg64 Reg
hi Reg
lo
| Bool
otherwise = String -> SDoc -> Reg64
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"localReg64" (CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
ty)
getPicBaseMaybeNat :: NatM (Maybe Reg)
getPicBaseMaybeNat :: NatM (Maybe Reg)
getPicBaseMaybeNat
= (NatM_State -> (Maybe Reg, NatM_State)) -> NatM (Maybe Reg)
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM (\NatM_State
state -> (NatM_State -> Maybe Reg
natm_pic NatM_State
state, NatM_State
state))
getPicBaseNat :: Format -> NatM Reg
getPicBaseNat :: Format -> NatM Reg
getPicBaseNat Format
rep
= do Maybe Reg
mbPicBase <- NatM (Maybe Reg)
getPicBaseMaybeNat
case Maybe Reg
mbPicBase of
Just Reg
picBase -> Reg -> NatM Reg
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return Reg
picBase
Maybe Reg
Nothing
-> do
Reg
reg <- Format -> NatM Reg
getNewRegNat Format
rep
(NatM_State -> (Reg, NatM_State)) -> NatM Reg
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM (\NatM_State
state -> (Reg
reg, NatM_State
state { natm_pic = Just reg }))
getConfig :: NatM NCGConfig
getConfig :: NatM NCGConfig
getConfig = (NatM_State -> (NCGConfig, NatM_State)) -> NatM NCGConfig
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> (NCGConfig, NatM_State)) -> NatM NCGConfig)
-> (NatM_State -> (NCGConfig, NatM_State)) -> NatM NCGConfig
forall a b. (a -> b) -> a -> b
$ \NatM_State
st -> (NatM_State -> NCGConfig
natm_config NatM_State
st, NatM_State
st)
getPlatform :: NatM Platform
getPlatform :: NatM Platform
getPlatform = NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig
getFileId :: FastString -> NatM Int
getFileId :: FastString -> NatM Int
getFileId FastString
f = (NatM_State -> (Int, NatM_State)) -> NatM Int
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> (Int, NatM_State)) -> NatM Int)
-> (NatM_State -> (Int, NatM_State)) -> NatM Int
forall a b. (a -> b) -> a -> b
$ \NatM_State
st ->
case DwarfFiles -> FastString -> Maybe (FastString, Int)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (NatM_State -> DwarfFiles
natm_fileid NatM_State
st) FastString
f of
Just (FastString
_,Int
n) -> (Int
n, NatM_State
st)
Maybe (FastString, Int)
Nothing -> let n :: Int
n = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DwarfFiles -> Int
forall key elt. UniqFM key elt -> Int
sizeUFM (NatM_State -> DwarfFiles
natm_fileid NatM_State
st)
fids :: DwarfFiles
fids = DwarfFiles -> FastString -> (FastString, Int) -> DwarfFiles
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (NatM_State -> DwarfFiles
natm_fileid NatM_State
st) FastString
f (FastString
f,Int
n)
in Int
n Int -> (Int, NatM_State) -> (Int, NatM_State)
forall a b. a -> b -> b
`seq` DwarfFiles
fids DwarfFiles -> (Int, NatM_State) -> (Int, NatM_State)
forall a b. a -> b -> b
`seq` (Int
n, NatM_State
st { natm_fileid = fids })
getDebugBlock :: Label -> NatM (Maybe DebugBlock)
getDebugBlock :: BlockId -> NatM (Maybe DebugBlock)
getDebugBlock BlockId
l = (NatM_State -> (Maybe DebugBlock, NatM_State))
-> NatM (Maybe DebugBlock)
forall a. (NatM_State -> (a, NatM_State)) -> NatM a
NatM ((NatM_State -> (Maybe DebugBlock, NatM_State))
-> NatM (Maybe DebugBlock))
-> (NatM_State -> (Maybe DebugBlock, NatM_State))
-> NatM (Maybe DebugBlock)
forall a b. (a -> b) -> a -> b
$ \NatM_State
st -> (KeyOf LabelMap -> LabelMap DebugBlock -> Maybe DebugBlock
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l (NatM_State -> LabelMap DebugBlock
natm_debug_map NatM_State
st), NatM_State
st)