{-# 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.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.DSM
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

-- | A Native Code Generator implementation is parametrised over
-- * The type of static data (typically related to 'CmmStatics')
-- * The type of instructions
-- * The type of jump destinations
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),
    -- | Given a jump destination, if it refers to a block, return the block id of the destination.
    forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> jumpDest -> Maybe BlockId
getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
    -- | Does this jump always jump to a single destination and is shortcutable?
    --
    -- We use this to determine whether the given instruction is a shortcutable
    -- jump to some destination - See Note [supporting shortcutting]
    -- Note that if we return a destination here we *most* support the relevant shortcutting in
    -- shortcutStatics for jump tables and shortcutJump for the instructions itself.
    forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> instr -> Maybe jumpDest
canShortcut               :: instr -> Maybe jumpDest,
    -- | Replace references to blockIds with other destinations - used to update jump tables.
    forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> (BlockId -> Maybe jumpDest) -> statics -> statics
shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
    -- | Change the jump destination(s) of an instruction.
    --
    -- Rewrites the destination of a jump instruction to another
    -- destination, if the given function returns a new jump destination for
    -- the 'BlockId' of the original destination.
    --
    -- For instance, for a mapping @block_a -> dest_b@ and a instruction @goto block_a@ we would
    -- rewrite the instruction to @goto dest_b@
    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
-> UniqDSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr
                              -> UniqDSM (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
-> Platform
-> LabelMap RawCmmStatics
-> [NatBasicBlock instr]
-> UniqDSM [NatBasicBlock instr]
ncgMakeFarBranches        :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
                              -> UniqDSM [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 [supporting shortcutting]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For the concept of shortcutting see Note [What is shortcutting].

In order to support shortcutting across multiple backends uniformly we
use canShortcut, shortcutStatics and shortcutJump.

canShortcut tells us if the backend support shortcutting of a instruction
and if so what destination we should retarget instruction to instead.

shortcutStatics exists to allow us to update jump destinations in jump tables.

shortcutJump updates the instructions itself.

A backend can opt out of those by always returning Nothing for canShortcut
and implementing shortcutStatics/shortcutJump as \_ x -> x

-}

{- 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 -> DUniqSupply
natm_us          :: DUniqSupply,
                NatM_State -> Int
natm_delta       :: Int, -- ^ Stack offset for unwinding information
                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 :: DUniqSupply -> Int -> NCGConfig ->
                DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
mkNatM_State :: DUniqSupply
-> Int
-> NCGConfig
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
mkNatM_State DUniqSupply
us Int
delta NCGConfig
config
        = \DwarfFiles
dwf LabelMap DebugBlock
dbg CFG
cfg ->
                NatM_State
                        { natm_us :: DUniqSupply
natm_us = DUniqSupply
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 MonadGetUnique NatM where
  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 DUniqSupply -> (Unique, DUniqSupply)
takeUniqueFromDSupply (NatM_State -> DUniqSupply
natm_us NatM_State
st) of
        (Unique
uniq, DUniqSupply
us') -> (Unique
uniq, NatM_State
st {natm_us = us'})

getUniqueNat :: NatM Unique
getUniqueNat :: NatM Unique
getUniqueNat = NatM Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM

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 <- NatM Weights
getCfgWeights
        let jmpWeight = Int -> EdgeWeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Weights -> Int
uncondWeight Weights
weights)
        updateCfgNat (updateCfg jmpWeight from between 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 <- NatM Weights
getCfgWeights
   updateCfgNat (addImmediateSuccessor weights block 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 u <- NatM Unique
getUniqueNat
      platform <- getPlatform
      return (RegVirtual $ targetMkVirtualReg platform u 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
  u <- NatM Unique
getUniqueNat
  platform <- getPlatform
  let vLo = Platform -> Unique -> Format -> VirtualReg
targetMkVirtualReg Platform
platform Unique
u Format
rep
  let 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  = VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ VirtualReg -> VirtualReg
getHiVirtualRegFromLo VirtualReg
vLo
  return $ Reg64 hi 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   mbPicBase <- NatM (Maybe Reg)
getPicBaseMaybeNat
        case 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 <- Format -> NatM Reg
getNewRegNat Format
rep
                        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 {k} (key :: k) 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 -> (BlockId -> LabelMap DebugBlock -> Maybe DebugBlock
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
l (NatM_State -> LabelMap DebugBlock
natm_debug_map NatM_State
st), NatM_State
st)