{-# 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.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 -- | 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 -> 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 -> Platform -> LabelMap RawCmmStatics -> [NatBasicBlock instr] -> UniqSM [NatBasicBlock instr] ncgMakeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock instr] -> UniqSM [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 -> UniqSupply natm_us :: UniqSupply, 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 :: 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 <- 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)