{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE BangPatterns #-}
module GHC.CmmToAsm.Monad (
NcgImpl(..),
NatM_State(..), mkNatM_State,
NatM,
initNat,
addImportNat,
addNodeBetweenNat,
addImmediateSuccessorNat,
updateCfgNat,
getUniqueNat,
mapAccumLNat,
setDeltaNat,
getConfig,
getPlatform,
getDeltaNat,
getThisModuleNat,
getBlockIdNat,
getNewLabelNat,
getNewRegNat,
getNewRegPairNat,
getPicBaseMaybeNat,
getPicBaseNat,
getCfgWeights,
getModLoc,
getFileId,
getDebugBlock,
DwarfFiles
)
where
#include "HsVersions.h"
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.Data.FastString ( FastString )
import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Types.Unique ( Unique )
import GHC.Unit.Module
import Control.Monad ( ap )
import GHC.Utils.Outputable (SDoc, ppr)
import GHC.Utils.Panic (pprPanic)
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
pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc,
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
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
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 -> ModLocation
natm_modloc :: ModLocation,
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 result = NatM (NatM_State -> (result, NatM_State))
deriving ((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
<$ :: forall a b. a -> NatM b -> NatM a
$c<$ :: forall a b. a -> NatM b -> NatM a
fmap :: forall a b. (a -> b) -> NatM a -> NatM b
$cfmap :: forall a b. (a -> b) -> NatM a -> NatM b
Functor)
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 -> ModLocation ->
DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
mkNatM_State :: UniqSupply
-> Int
-> NCGConfig
-> ModLocation
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
mkNatM_State UniqSupply
us Int
delta NCGConfig
config
= \ModLocation
loc 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_modloc :: ModLocation
natm_modloc = ModLocation
loc
, 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_State
init_st NatM a
m
= case NatM a -> NatM_State -> (a, NatM_State)
forall a. NatM a -> NatM_State -> (a, NatM_State)
unNat NatM a
m NatM_State
init_st of { (a
r,NatM_State
st) -> (a
r,NatM_State
st) }
instance Applicative NatM where
pure :: forall a. a -> NatM a
pure = a -> NatM a
forall a. a -> NatM a
returnNat
<*> :: forall a b. NatM (a -> b) -> NatM a -> NatM b
(<*>) = NatM (a -> b) -> NatM a -> NatM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad NatM where
>>= :: forall a b. NatM a -> (a -> NatM b) -> NatM b
(>>=) = NatM a -> (a -> NatM b) -> NatM b
forall a b. NatM a -> (a -> NatM b) -> NatM b
thenNat
instance MonadUnique NatM where
getUniqueSupplyM :: NatM UniqSupply
getUniqueSupplyM = (NatM_State -> (UniqSupply, NatM_State)) -> NatM UniqSupply
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
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 :: UniqSupply
natm_us = UniqSupply
us2})
getUniqueM :: NatM Unique
getUniqueM = (NatM_State -> (Unique, NatM_State)) -> NatM Unique
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
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 :: UniqSupply
natm_us = UniqSupply
us'})
thenNat :: NatM a -> (a -> NatM b) -> NatM b
thenNat :: forall a b. NatM a -> (a -> NatM b) -> NatM b
thenNat NatM a
expr a -> NatM b
cont
= (NatM_State -> (b, NatM_State)) -> NatM b
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
NatM ((NatM_State -> (b, NatM_State)) -> NatM b)
-> (NatM_State -> (b, NatM_State)) -> NatM b
forall a b. (a -> b) -> a -> b
$ \NatM_State
st -> case NatM a -> NatM_State -> (a, NatM_State)
forall a. NatM a -> NatM_State -> (a, NatM_State)
unNat NatM a
expr NatM_State
st of
(a
result, NatM_State
st') -> NatM b -> NatM_State -> (b, NatM_State)
forall a. NatM a -> NatM_State -> (a, NatM_State)
unNat (a -> NatM b
cont a
result) NatM_State
st'
returnNat :: a -> NatM a
returnNat :: forall a. a -> NatM a
returnNat a
result
= (NatM_State -> (a, NatM_State)) -> NatM a
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
NatM ((NatM_State -> (a, NatM_State)) -> NatM a)
-> (NatM_State -> (a, NatM_State)) -> NatM a
forall a b. (a -> b) -> a -> b
$ \NatM_State
st -> (a
result, NatM_State
st)
mapAccumLNat :: (acc -> x -> NatM (acc, y))
-> acc
-> [x]
-> NatM (acc, [y])
mapAccumLNat :: forall acc x y.
(acc -> x -> NatM (acc, y)) -> acc -> [x] -> NatM (acc, [y])
mapAccumLNat acc -> x -> NatM (acc, y)
_ acc
b []
= (acc, [y]) -> NatM (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
b, [])
mapAccumLNat acc -> x -> NatM (acc, y)
f acc
b (x
x:[x]
xs)
= do (acc
b__2, y
x__2) <- acc -> x -> NatM (acc, y)
f acc
b x
x
(acc
b__3, [y]
xs__2) <- (acc -> x -> NatM (acc, y)) -> acc -> [x] -> NatM (acc, [y])
forall acc x y.
(acc -> x -> NatM (acc, y)) -> acc -> [x] -> NatM (acc, [y])
mapAccumLNat acc -> x -> NatM (acc, y)
f acc
b__2 [x]
xs
(acc, [y]) -> NatM (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
b__3, y
x__2y -> [y] -> [y]
forall a. a -> [a] -> [a]
:[y]
xs__2)
getUniqueNat :: NatM Unique
getUniqueNat :: NatM Unique
getUniqueNat = (NatM_State -> (Unique, NatM_State)) -> NatM Unique
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
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 :: UniqSupply
natm_us = UniqSupply
us'})
getDeltaNat :: NatM Int
getDeltaNat :: NatM Int
getDeltaNat = (NatM_State -> (Int, NatM_State)) -> NatM Int
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
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 result. (NatM_State -> (result, NatM_State)) -> NatM result
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 result. (NatM_State -> (result, NatM_State)) -> NatM result
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 :: Int
natm_delta = Int
delta})
getThisModuleNat :: NatM Module
getThisModuleNat :: NatM Module
getThisModuleNat = (NatM_State -> (Module, NatM_State)) -> NatM Module
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
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 result. (NatM_State -> (result, NatM_State)) -> NatM result
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 :: [CLabel]
natm_imports = CLabel
imp CLabel -> [CLabel] -> [CLabel]
forall a. a -> [a] -> [a]
: NatM_State -> [CLabel]
natm_imports NatM_State
st})
updateCfgNat :: (CFG -> CFG) -> NatM ()
updateCfgNat :: (CFG -> CFG) -> NatM ()
updateCfgNat CFG -> CFG
f
= (NatM_State -> ((), NatM_State)) -> NatM ()
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
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
natm_cfg = 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
= do Unique
u <- NatM Unique
getUniqueNat
BlockId -> NatM BlockId
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> BlockId
mkBlockId Unique
u)
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 (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)
getNewRegPairNat :: Format -> NatM (Reg,Reg)
getNewRegPairNat :: Format -> NatM (Reg, Reg)
getNewRegPairNat Format
rep
= do 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
(Reg, Reg) -> NatM (Reg, Reg)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
lo, Reg
hi)
getPicBaseMaybeNat :: NatM (Maybe Reg)
getPicBaseMaybeNat :: NatM (Maybe Reg)
getPicBaseMaybeNat
= (NatM_State -> (Maybe Reg, NatM_State)) -> NatM (Maybe Reg)
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
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 (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 result. (NatM_State -> (result, NatM_State)) -> NatM result
NatM (\NatM_State
state -> (Reg
reg, NatM_State
state { natm_pic :: Maybe Reg
natm_pic = Reg -> Maybe Reg
forall a. a -> Maybe a
Just Reg
reg }))
getModLoc :: NatM ModLocation
getModLoc :: NatM ModLocation
getModLoc
= (NatM_State -> (ModLocation, NatM_State)) -> NatM ModLocation
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
NatM ((NatM_State -> (ModLocation, NatM_State)) -> NatM ModLocation)
-> (NatM_State -> (ModLocation, NatM_State)) -> NatM ModLocation
forall a b. (a -> b) -> a -> b
$ \ NatM_State
st -> (NatM_State -> ModLocation
natm_modloc NatM_State
st, NatM_State
st)
getConfig :: NatM NCGConfig
getConfig :: NatM NCGConfig
getConfig = (NatM_State -> (NCGConfig, NatM_State)) -> NatM NCGConfig
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
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 result. (NatM_State -> (result, NatM_State)) -> NatM result
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)
`seq` DwarfFiles
fids DwarfFiles -> (Int, NatM_State) -> (Int, NatM_State)
`seq` (Int
n, NatM_State
st { natm_fileid :: DwarfFiles
natm_fileid = DwarfFiles
fids })
getDebugBlock :: Label -> NatM (Maybe DebugBlock)
getDebugBlock :: BlockId -> NatM (Maybe DebugBlock)
getDebugBlock BlockId
l = (NatM_State -> (Maybe DebugBlock, NatM_State))
-> NatM (Maybe DebugBlock)
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
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 (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)