{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

-- -----------------------------------------------------------------------------
--
-- (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,
        addImportNat,
        addNodeBetweenNat,
        addImmediateSuccessorNat,
        updateCfgNat,
        getUniqueNat,
        setDeltaNat,
        getConfig,
        getPlatform,
        getDeltaNat,
        getThisModuleNat,
        getBlockIdNat,
        getNewLabelNat,
        getNewRegNat,
        getPicBaseMaybeNat,
        getPicBaseNat,
        getCfgWeights,
        getFileId,
        getDebugBlock,

        DwarfFiles,

        -- * 64-bit registers on 32-bit architectures
        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,
    -- | 'Module' is only for printing internal labels. See Note [Internal proc
    -- labels] in CLabel.
    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,
        -- see Note [pprNatCmmDeclS and pprNatCmmDeclH]
    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)]),
    -- ^ 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.
    }

{- Note [pprNatCmmDeclS and pprNatCmmDeclH]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Each NcgImpl provides two implementations of its CmmDecl printer, pprNatCmmDeclS
and pprNatCmmDeclH, which are specialized to SDoc and HDoc, respectively
(see Note [SDoc versus HDoc] in GHC.Utils.Outputable). These are both internally
implemented as a single, polymorphic function, but they need to be stored using
monomorphic types to ensure the specialized versions are used, which is
essential for performance (see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable).

One might wonder why we bother with pprNatCmmDeclS and SDoc at all, since we
have a perfectly serviceable HDoc-based implementation that is more efficient.
However, it turns out we benefit from keeping both, for two (related) reasons:

  1. Although we absolutely want to take care to use pprNatCmmDeclH for actual
     code generation (the improved performance there is why we have HDoc at
     all!), we also sometimes print assembly for debug dumps, when requested via
     -ddump-asm. In this case, it’s more convenient to produce an SDoc, which
     can be concatenated with other SDocs for consistency with the general-
     purpose dump file infrastructure.

  2. Some debug information is sometimes useful to include in -ddump-asm that is
     neither necessary nor useful in normal code generation, and it turns out to
     be tricky to format neatly using the one-line-at-a-time model of HLine/HDoc.

Therefore, we provide both pprNatCmmDeclS and pprNatCmmDeclH, and we sometimes
include additional information in the SDoc variant using dualDoc
(see Note [dualLine and dualDoc] in GHC.Utils.Outputable). However, it is
absolutely *critical* that pprNatCmmDeclS is not actually used unless -ddump-asm
is provided, as that would rather defeat the whole point. (Fortunately, the
difference in allocations between the two implementations is so vast that such a
mistake would readily show up in performance tests). -}

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
        -- ^ 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 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)

-- | Get CFG edge weights
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'})

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


-- | Two 32-bit regs used as a single virtual 64-bit register
data Reg64 = Reg64
  !Reg -- ^ Higher part
  !Reg -- ^ Lower part

-- | Two 32-bit regs used as a single virtual 64-bit register
-- and the code to set them appropriately
data RegCode64 code = RegCode64
  code -- ^ Code to initialize the registers
  !Reg -- ^ Higher part
  !Reg -- ^ Lower part

-- | Return a virtual 64-bit register
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

-- | Convert a 64-bit LocalReg into two virtual 32-bit regs.
--
-- Used to handle 64-bit "registers" on 32-bit architectures
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 }))

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

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