{-# LANGUAGE CPP #-}

-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
--
-- The native code generator's monad.
--
-- -----------------------------------------------------------------------------

module NCGMonad (
        NcgImpl(..),
        NatM_State(..), mkNatM_State,

        NatM, -- instance Monad
        initNat,
        addImportNat,
        addNodeBetweenNat,
        addImmediateSuccessorNat,
        updateCfgNat,
        getUniqueNat,
        mapAccumLNat,
        setDeltaNat,
        getDeltaNat,
        getThisModuleNat,
        getBlockIdNat,
        getNewLabelNat,
        getNewRegNat,
        getNewRegPairNat,
        getPicBaseMaybeNat,
        getPicBaseNat,
        getDynFlags,
        getModLoc,
        getFileId,
        getDebugBlock,

        DwarfFiles
)

where

#include "HsVersions.h"

import GhcPrelude

import Reg
import Format
import TargetReg

import BlockId
import Hoopl.Collections
import Hoopl.Label
import CLabel           ( CLabel )
import Debug
import FastString       ( FastString )
import UniqFM
import UniqSupply
import Unique           ( Unique )
import DynFlags
import Module

import Control.Monad    ( liftM, ap )

import Instruction
import Outputable (SDoc, pprPanic, ppr)
import Cmm (RawCmmDecl, CmmStatics)
import CFG

data NcgImpl statics instr jumpDest = NcgImpl {
    NcgImpl statics instr jumpDest
-> RawCmmDecl -> NatM [NatCmmDecl statics instr]
cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
    NcgImpl statics instr jumpDest
-> instr -> Maybe (NatCmmDecl statics instr)
generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
    NcgImpl statics instr jumpDest -> jumpDest -> Maybe BlockId
getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
    NcgImpl statics instr jumpDest -> instr -> Maybe jumpDest
canShortcut               :: instr -> Maybe jumpDest,
    NcgImpl statics instr jumpDest
-> (BlockId -> Maybe jumpDest) -> statics -> statics
shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
    NcgImpl statics instr jumpDest
-> (BlockId -> Maybe jumpDest) -> instr -> instr
shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
    NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,
    NcgImpl statics instr jumpDest -> Int
maxSpillSlots             :: Int,
    NcgImpl statics instr jumpDest -> [RealReg]
allocatableRegs           :: [RealReg],
    NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
    NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
    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)]),
    -- ^ The list of block ids records the redirected jumps to allow us to update
    -- the CFG.
    NcgImpl statics instr jumpDest
-> LabelMap CmmStatics
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
ncgMakeFarBranches        :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
    NcgImpl statics instr jumpDest -> [instr] -> [UnwindPoint]
extractUnwindPoints       :: [instr] -> [UnwindPoint],
    -- ^ given the instruction sequence of a block, produce a list of
    -- the block's 'UnwindPoint's
    -- See Note [What is this unwinding business?] in Debug
    -- and Note [Unwinding information in the NCG] in this module.
    NcgImpl statics instr jumpDest
-> CFG
-> LabelMap CmmStatics
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
invertCondBranches        :: CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
                              -> [NatBasicBlock instr]
    -- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`
    -- when possible.
    }

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 -> DynFlags
natm_dflags      :: DynFlags,
                NatM_State -> Module
natm_this_module :: Module,
                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
        -- ^ Having a CFG with additional information is essential for some
        -- operations. However we can't reconstruct all information once we
        -- generated instructions. So instead we update the CFG as we go.
        }

type DwarfFiles = UniqFM (FastString, Int)

newtype NatM result = NatM (NatM_State -> (result, NatM_State))

unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat (NatM a :: NatM_State -> (a, NatM_State)
a) = NatM_State -> (a, NatM_State)
a

mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
                DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
mkNatM_State :: UniqSupply
-> Int
-> DynFlags
-> Module
-> ModLocation
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
mkNatM_State us :: UniqSupply
us delta :: Int
delta dflags :: DynFlags
dflags this_mod :: Module
this_mod
        = \loc :: ModLocation
loc dwf :: DwarfFiles
dwf dbg :: LabelMap DebugBlock
dbg cfg :: CFG
cfg ->
                NatM_State :: UniqSupply
-> Int
-> [CLabel]
-> Maybe Reg
-> DynFlags
-> Module
-> ModLocation
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
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_dflags :: DynFlags
natm_dflags = DynFlags
dflags
                        , natm_this_module :: Module
natm_this_module = Module
this_mod
                        , 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 :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st :: NatM_State
init_st m :: 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 { (r :: a
r,st :: NatM_State
st) -> (a
r,NatM_State
st) }

instance Functor NatM where
      fmap :: (a -> b) -> NatM a -> NatM b
fmap = (a -> b) -> NatM a -> NatM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative NatM where
      pure :: a -> NatM a
pure = a -> NatM a
forall a. a -> NatM a
returnNat
      <*> :: 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
  >>= :: 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
$ \st :: NatM_State
st ->
      case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply (NatM_State -> UniqSupply
natm_us NatM_State
st) of
          (us1 :: UniqSupply
us1, us2 :: 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
$ \st :: NatM_State
st ->
      case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NatM_State -> UniqSupply
natm_us NatM_State
st) of
          (uniq :: Unique
uniq, us' :: UniqSupply
us') -> (Unique
uniq, NatM_State
st {natm_us :: UniqSupply
natm_us = UniqSupply
us'})

thenNat :: NatM a -> (a -> NatM b) -> NatM b
thenNat :: NatM a -> (a -> NatM b) -> NatM b
thenNat expr :: NatM a
expr cont :: 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
$ \st :: 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
                        (result :: a
result, st' :: 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 :: a -> NatM a
returnNat result :: 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
$ \st :: NatM_State
st ->  (a
result, NatM_State
st)

mapAccumLNat :: (acc -> x -> NatM (acc, y))
                -> acc
                -> [x]
                -> NatM (acc, [y])

mapAccumLNat :: (acc -> x -> NatM (acc, y)) -> acc -> [x] -> NatM (acc, [y])
mapAccumLNat _ b :: acc
b []
  = (acc, [y]) -> NatM (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
b, [])
mapAccumLNat f :: acc -> x -> NatM (acc, y)
f b :: acc
b (x :: x
x:xs :: [x]
xs)
  = do (b__2 :: acc
b__2, x__2 :: y
x__2)  <- acc -> x -> NatM (acc, y)
f acc
b x
x
       (b__3 :: acc
b__3, xs__2 :: [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
$ \ st :: 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
    (uniq :: Unique
uniq, us' :: UniqSupply
us') -> (Unique
uniq, NatM_State
st {natm_us :: UniqSupply
natm_us = UniqSupply
us'})

instance HasDynFlags NatM where
    getDynFlags :: NatM DynFlags
getDynFlags = (NatM_State -> (DynFlags, NatM_State)) -> NatM DynFlags
forall result. (NatM_State -> (result, NatM_State)) -> NatM result
NatM ((NatM_State -> (DynFlags, NatM_State)) -> NatM DynFlags)
-> (NatM_State -> (DynFlags, NatM_State)) -> NatM DynFlags
forall a b. (a -> b) -> a -> b
$ \ st :: NatM_State
st -> (NatM_State -> DynFlags
natm_dflags NatM_State
st, NatM_State
st)


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
$ \ st :: NatM_State
st -> (NatM_State -> Int
natm_delta NatM_State
st, NatM_State
st)


setDeltaNat :: Int -> NatM ()
setDeltaNat :: Int -> NatM ()
setDeltaNat delta :: 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
$ \ st :: 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
$ \ st :: NatM_State
st -> (NatM_State -> Module
natm_this_module NatM_State
st, NatM_State
st)


addImportNat :: CLabel -> NatM ()
addImportNat :: CLabel -> NatM ()
addImportNat imp :: 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
$ \ st :: 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 f :: 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
$ \ st :: NatM_State
st -> ((), NatM_State
st { natm_cfg :: CFG
natm_cfg = CFG -> CFG
f (NatM_State -> CFG
natm_cfg NatM_State
st) })

-- | Record that we added a block between `from` and `old`.
addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
addNodeBetweenNat from :: BlockId
from between :: BlockId
between to :: BlockId
to
 = do   DynFlags
df <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let jmpWeight :: EdgeWeight
jmpWeight = Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> EdgeWeight) -> (DynFlags -> Int) -> DynFlags -> EdgeWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CfgWeights -> Int
uncondWeight (CfgWeights -> Int) -> (DynFlags -> CfgWeights) -> DynFlags -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        DynFlags -> CfgWeights
cfgWeightInfo (DynFlags -> EdgeWeight) -> DynFlags -> EdgeWeight
forall a b. (a -> b) -> a -> b
$ DynFlags
df
        (CFG -> CFG) -> NatM ()
updateCfgNat (EdgeWeight -> BlockId -> BlockId -> BlockId -> CFG -> CFG
updateCfg EdgeWeight
jmpWeight BlockId
from BlockId
between BlockId
to)
  where
    -- When transforming A -> B to A -> A' -> B
    -- A -> A' keeps the old edge info while
    -- A' -> B gets the info for an unconditional
    -- jump.
    updateCfg :: EdgeWeight -> BlockId -> BlockId -> BlockId -> CFG -> CFG
updateCfg weight :: EdgeWeight
weight from :: BlockId
from between :: BlockId
between old :: BlockId
old m :: CFG
m
        | Just info :: 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 "Faild to update cfg: Untracked edge" ((BlockId, BlockId) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (BlockId
from,BlockId
to))


-- | Place `succ` after `block` and change any edges
--   block -> X to `succ` -> X
addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
addImmediateSuccessorNat block :: BlockId
block succ :: BlockId
succ
        = (CFG -> CFG) -> NatM ()
updateCfgNat (BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor 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 rep :: Format
rep
 = do Unique
u <- NatM Unique
getUniqueNat
      DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      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 (DynFlags -> Platform
targetPlatform DynFlags
dflags) Unique
u Format
rep)


getNewRegPairNat :: Format -> NatM (Reg,Reg)
getNewRegPairNat :: Format -> NatM (Reg, Reg)
getNewRegPairNat rep :: Format
rep
 = do Unique
u <- NatM Unique
getUniqueNat
      DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let vLo :: VirtualReg
vLo = Platform -> Unique -> Format -> VirtualReg
targetMkVirtualReg (DynFlags -> Platform
targetPlatform DynFlags
dflags) 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 (DynFlags -> Platform
targetPlatform DynFlags
dflags) 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 (\state :: NatM_State
state -> (NatM_State -> Maybe Reg
natm_pic NatM_State
state, NatM_State
state))


getPicBaseNat :: Format -> NatM Reg
getPicBaseNat :: Format -> NatM Reg
getPicBaseNat rep :: Format
rep
 = do   Maybe Reg
mbPicBase <- NatM (Maybe Reg)
getPicBaseMaybeNat
        case Maybe Reg
mbPicBase of
                Just picBase :: Reg
picBase -> Reg -> NatM Reg
forall (m :: * -> *) a. Monad m => a -> m a
return Reg
picBase
                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 (\state :: 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
$ \ st :: NatM_State
st -> (NatM_State -> ModLocation
natm_modloc NatM_State
st, NatM_State
st)

getFileId :: FastString -> NatM Int
getFileId :: FastString -> NatM Int
getFileId f :: 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
$ \st :: NatM_State
st ->
  case DwarfFiles -> FastString -> Maybe (FastString, Int)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM (NatM_State -> DwarfFiles
natm_fileid NatM_State
st) FastString
f of
    Just (_,n :: Int
n) -> (Int
n, NatM_State
st)
    Nothing    -> let n :: Int
n = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DwarfFiles -> Int
forall elt. UniqFM 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 elt -> key -> elt -> UniqFM 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 :: DwarfFiles
natm_fileid = DwarfFiles
fids  })

getDebugBlock :: Label -> NatM (Maybe DebugBlock)
getDebugBlock :: BlockId -> NatM (Maybe DebugBlock)
getDebugBlock l :: 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
$ \st :: 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)