{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE BangPatterns #-}

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

module GHC.CmmToAsm.Monad (
        NcgImpl(..),
        NatM_State(..), mkNatM_State,

        NatM, -- instance Monad
        initNat,
        initConfig,
        addImportNat,
        addNodeBetweenNat,
        addImmediateSuccessorNat,
        updateCfgNat,
        getUniqueNat,
        mapAccumLNat,
        setDeltaNat,
        getConfig,
        getPlatform,
        getDeltaNat,
        getThisModuleNat,
        getBlockIdNat,
        getNewLabelNat,
        getNewRegNat,
        getNewRegPairNat,
        getPicBaseMaybeNat,
        getPicBaseNat,
        getDynFlags,
        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.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.Driver.Session
import GHC.Unit.Module

import Control.Monad    ( ap )

import GHC.CmmToAsm.Instr
import GHC.Utils.Outputable (SDoc, pprPanic, ppr)
import GHC.Cmm (RawCmmDecl, RawCmmStatics)
import GHC.CmmToAsm.CFG

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)]),
    -- ^ The list of block ids records the redirected jumps to allow us to update
    -- the CFG.
    forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> LabelMap RawCmmStatics
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
ncgMakeFarBranches        :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
    forall statics instr jumpDest.
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 "GHC.Cmm.DebugBlock"
    -- and Note [Unwinding information in the NCG] in this module.
    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]
    -- ^ 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 -> NCGConfig
natm_config      :: NCGConfig,
                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 (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 -> DynFlags -> Module -> ModLocation ->
                DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
mkNatM_State :: UniqSupply
-> Int
-> DynFlags
-> Module
-> ModLocation
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
mkNatM_State UniqSupply
us Int
delta DynFlags
dflags Module
this_mod
        = \ModLocation
loc DwarfFiles
dwf LabelMap DebugBlock
dbg CFG
cfg ->
                NatM_State :: UniqSupply
-> Int
-> [CLabel]
-> Maybe Reg
-> DynFlags
-> NCGConfig
-> 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_config :: NCGConfig
natm_config = DynFlags -> NCGConfig
initConfig 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
                        }

-- | Initialize the native code generator configuration from the DynFlags
initConfig :: DynFlags -> NCGConfig
initConfig :: DynFlags -> NCGConfig
initConfig DynFlags
dflags = NCGConfig :: Platform
-> Maybe Int
-> Int
-> Bool
-> Bool
-> Word
-> Word
-> Bool
-> Int
-> Bool
-> Bool
-> Bool
-> Maybe SseVersion
-> Maybe BmiVersion
-> Bool
-> Bool
-> Bool
-> NCGConfig
NCGConfig
   { ncgPlatform :: Platform
ncgPlatform              = DynFlags -> Platform
targetPlatform DynFlags
dflags
   , ncgProcAlignment :: Maybe Int
ncgProcAlignment         = DynFlags -> Maybe Int
cmmProcAlignment DynFlags
dflags
   , ncgDebugLevel :: Int
ncgDebugLevel            = DynFlags -> Int
debugLevel DynFlags
dflags
   , ncgExternalDynamicRefs :: Bool
ncgExternalDynamicRefs   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalDynamicRefs DynFlags
dflags
   , ncgPIC :: Bool
ncgPIC                   = DynFlags -> Bool
positionIndependent DynFlags
dflags
   , ncgInlineThresholdMemcpy :: Word
ncgInlineThresholdMemcpy = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int
maxInlineMemcpyInsns DynFlags
dflags
   , ncgInlineThresholdMemset :: Word
ncgInlineThresholdMemset = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int
maxInlineMemsetInsns DynFlags
dflags
   , ncgSplitSections :: Bool
ncgSplitSections         = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitSections DynFlags
dflags
   , ncgSpillPreallocSize :: Int
ncgSpillPreallocSize     = DynFlags -> Int
rESERVED_C_STACK_BYTES DynFlags
dflags
   , ncgRegsIterative :: Bool
ncgRegsIterative         = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RegsIterative DynFlags
dflags
   , ncgAsmLinting :: Bool
ncgAsmLinting            = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoAsmLinting DynFlags
dflags

     -- With -O1 and greater, the cmmSink pass does constant-folding, so
     -- we don't need to do it again in the native code generator.
   , ncgDoConstantFolding :: Bool
ncgDoConstantFolding     = DynFlags -> Int
optLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1

   , ncgDumpRegAllocStages :: Bool
ncgDumpRegAllocStages    = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_asm_regalloc_stages DynFlags
dflags
   , ncgDumpAsmStats :: Bool
ncgDumpAsmStats          = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_asm_stats DynFlags
dflags
   , ncgDumpAsmConflicts :: Bool
ncgDumpAsmConflicts      = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_asm_conflicts DynFlags
dflags
   , ncgBmiVersion :: Maybe BmiVersion
ncgBmiVersion            = case Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
                                 Arch
ArchX86_64 -> DynFlags -> Maybe BmiVersion
bmiVersion DynFlags
dflags
                                 Arch
ArchX86    -> DynFlags -> Maybe BmiVersion
bmiVersion DynFlags
dflags
                                 Arch
_          -> Maybe BmiVersion
forall a. Maybe a
Nothing

     -- We Assume  SSE1 and SSE2 operations are available on both
     -- x86 and x86_64. Historically we didn't default to SSE2 and
     -- SSE1 on x86, which results in defacto nondeterminism for how
     -- rounding behaves in the associated x87 floating point instructions
     -- because variations in the spill/fpu stack placement of arguments for
     -- operations would change the precision and final result of what
     -- would otherwise be the same expressions with respect to single or
     -- double precision IEEE floating point computations.
   , ncgSseVersion :: Maybe SseVersion
ncgSseVersion =
      let v :: Maybe SseVersion
v | DynFlags -> Maybe SseVersion
sseVersion DynFlags
dflags Maybe SseVersion -> Maybe SseVersion -> Bool
forall a. Ord a => a -> a -> Bool
< SseVersion -> Maybe SseVersion
forall a. a -> Maybe a
Just SseVersion
SSE2 = SseVersion -> Maybe SseVersion
forall a. a -> Maybe a
Just SseVersion
SSE2
            | Bool
otherwise                     = DynFlags -> Maybe SseVersion
sseVersion DynFlags
dflags
      in case Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
            Arch
ArchX86_64 -> Maybe SseVersion
v
            Arch
ArchX86    -> Maybe SseVersion
v
            Arch
_          -> Maybe SseVersion
forall a. Maybe a
Nothing
   }


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'})

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


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'})

-- | Record that we added a block between `from` and `old`.
addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
addNodeBetweenNat BlockId
from BlockId
between 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 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))


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

-- | Get native code generator configuration
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)

-- | Get target platform from native code generator configuration
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)