    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE DerivingVia #-}

    {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

    -- ----------------------------------------------------------------------------
    -- | Base LLVM Code Generation module
    --
    -- Contains functions useful through out the code generator.
    --

    module GHC.CmmToLlvm.Base (

            LlvmCmmDecl, LlvmBasicBlock,
            LiveGlobalRegs,
            LlvmUnresData, LlvmData, UnresLabel, UnresStatic,

            LlvmM,
            runLlvm, withClearVars, varLookup, varInsert,
            markStackReg, checkStackReg,
            funLookup, funInsert, getLlvmVer,
            dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
            ghcInternalFunctions, getPlatform, getConfig,

            getMetaUniqueId,
            setUniqMeta, getUniqMeta, liftIO,

            cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
            llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
            llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,

            strCLabel_llvm,
            getGlobalPtr, generateExternDecls,

            aliasify, llvmDefLabel
        ) where

    import GHC.Prelude
    import GHC.Utils.Panic

    import GHC.Llvm
    import GHC.CmmToLlvm.Regs
    import GHC.CmmToLlvm.Config
    import GHC.CmmToLlvm.Version

    import GHC.Cmm.CLabel
    import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
    import GHC.Driver.DynFlags
    import GHC.Data.FastString
    import GHC.Cmm              hiding ( succ )
    import GHC.Cmm.Utils (globalRegsOverlap)
    import GHC.Utils.Outputable as Outp
    import GHC.Platform
    import GHC.Types.Unique.FM
    import GHC.Types.Unique
    import GHC.Utils.BufHandle   ( BufHandle )
    import GHC.Types.Unique.Set
    import GHC.Types.Unique.Supply
    import GHC.Utils.Logger

    import Data.Maybe (fromJust)
    import Control.Monad.Trans.State (StateT (..))
    import Data.List (isPrefixOf)
    import qualified Data.List.NonEmpty as NE
    import Data.Ord (comparing)

    -- ----------------------------------------------------------------------------
    -- * Some Data Types
    --

    type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement)
    type LlvmBasicBlock = GenBasicBlock LlvmStatement

    -- | Global registers live on proc entry
    type LiveGlobalRegs = [GlobalReg]

    -- | Unresolved code.
    -- Of the form: (data label, data type, unresolved data)
    type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])

    -- | Top level LLVM Data (globals and type aliases)
    type LlvmData = ([LMGlobal], [LlvmType])

    -- | An unresolved Label.
    --
    -- Labels are unresolved when we haven't yet determined if they are defined in
    -- the module we are currently compiling, or an external one.
    type UnresLabel  = CmmLit
    type UnresStatic = Either UnresLabel LlvmStatic

    -- ----------------------------------------------------------------------------
    -- * Type translations
    --

    -- | Translate a basic CmmType to an LlvmType.
    cmmToLlvmType :: CmmType -> LlvmType
    cmmToLlvmType :: CmmType -> LlvmType
    cmmToLlvmType CmmType
    ty | CmmType -> Bool
    isVecType CmmType
    ty   = Int -> LlvmType -> LlvmType
    LMVector (CmmType -> Int
    vecLength CmmType
    ty) (CmmType -> LlvmType
    cmmToLlvmType (CmmType -> CmmType
    vecElemType CmmType
    ty))
                     | CmmType -> Bool
    isFloatType CmmType
    ty = Width -> LlvmType
    widthToLlvmFloat (Width -> LlvmType) -> Width -> LlvmType
    forall a b. (a -> b) -> a -> b
    $ CmmType -> Width
    typeWidth CmmType
    ty
                     | Bool
    otherwise      = Width -> LlvmType
    widthToLlvmInt   (Width -> LlvmType) -> Width -> LlvmType
    forall a b. (a -> b) -> a -> b
    $ CmmType -> Width
    typeWidth CmmType
    ty

    -- | Translate a Cmm Float Width to a LlvmType.
    widthToLlvmFloat :: Width -> LlvmType
    widthToLlvmFloat :: Width -> LlvmType
    widthToLlvmFloat Width
    W32  = LlvmType
    LMFloat
    widthToLlvmFloat Width
    W64  = LlvmType
    LMDouble
    widthToLlvmFloat Width
    W128 = LlvmType
    LMFloat128
    widthToLlvmFloat Width
    w    = String -> LlvmType
    forall a. HasCallStack => String -> a
    panic (String -> LlvmType) -> String -> LlvmType
    forall a b. (a -> b) -> a -> b
    $ String
    "widthToLlvmFloat: Bad float size: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Width -> String
    forall a. Show a => a -> String
    show Width
    w

    -- | Translate a Cmm Bit Width to a LlvmType.
    widthToLlvmInt :: Width -> LlvmType
    widthToLlvmInt :: Width -> LlvmType
    widthToLlvmInt Width
    w = Int -> LlvmType
    LMInt (Int -> LlvmType) -> Int -> LlvmType
    forall a b. (a -> b) -> a -> b
    $ Width -> Int
    widthInBits Width
    w

    -- | GHC Call Convention for LLVM
    llvmGhcCC :: Platform -> LlvmCallConvention
    llvmGhcCC :: Platform -> LlvmCallConvention
    llvmGhcCC Platform
    platform
     | Platform -> Bool
    platformUnregisterised Platform
    platform = LlvmCallConvention
    CC_Ccc
     | Bool
    otherwise                       = LlvmCallConvention
    CC_Ghc

    -- | Llvm Function type for Cmm function
    llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
    llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
    llvmFunTy LiveGlobalRegs
    live = LlvmType -> LlvmM LlvmType
    forall a. a -> LlvmM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LlvmType -> LlvmM LlvmType)
    -> (LlvmFunctionDecl -> LlvmType)
    -> LlvmFunctionDecl
    -> LlvmM LlvmType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LlvmFunctionDecl -> LlvmType
    LMFunction (LlvmFunctionDecl -> LlvmM LlvmType)
    -> LlvmM LlvmFunctionDecl -> LlvmM LlvmType
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< LiveGlobalRegs
    -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
    llvmFunSig' LiveGlobalRegs
    live (String -> LMString
    fsLit String
    "a") LlvmLinkageType
    ExternallyVisible

    -- | Llvm Function signature
    llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
    llvmFunSig :: LiveGlobalRegs
    -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
    llvmFunSig LiveGlobalRegs
    live CLabel
    lbl LlvmLinkageType
    link = do
      lbl' <- CLabel -> LlvmM LMString
    strCLabel_llvm CLabel
    lbl
      llvmFunSig' live lbl' link

    llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
    llvmFunSig' :: LiveGlobalRegs
    -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
    llvmFunSig' LiveGlobalRegs
    live LMString
    lbl LlvmLinkageType
    link
      = do let toParams :: LlvmType -> (LlvmType, [LlvmParamAttr])
    toParams LlvmType
    x | LlvmType -> Bool
    isPointer LlvmType
    x = (LlvmType
    x, [LlvmParamAttr
    NoAlias, LlvmParamAttr
    NoCapture])
                          | Bool
    otherwise   = (LlvmType
    x, [])
           platform <- LlvmM Platform
    getPlatform
           return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs
                                     (map (toParams . getVarType) (llvmFunArgs platform live))
                                     (llvmFunAlign platform)

    -- | Alignment to use for functions
    llvmFunAlign :: Platform -> LMAlign
    llvmFunAlign :: Platform -> LMAlign
    llvmFunAlign Platform
    platform = Int -> LMAlign
    forall a. a -> Maybe a
    Just (Platform -> Int
    platformWordSizeInBytes Platform
    platform)

    -- | Alignment to use for into tables
    llvmInfAlign :: Platform -> LMAlign
    llvmInfAlign :: Platform -> LMAlign
    llvmInfAlign Platform
    platform = Int -> LMAlign
    forall a. a -> Maybe a
    Just (Platform -> Int
    platformWordSizeInBytes Platform
    platform)

    -- | Section to use for a function
    llvmFunSection :: LlvmCgConfig -> LMString -> LMSection
    llvmFunSection :: LlvmCgConfig -> LMString -> LMSection
    llvmFunSection LlvmCgConfig
    opts LMString
    lbl
        | LlvmCgConfig -> Bool
    llvmCgSplitSection LlvmCgConfig
    opts = LMString -> LMSection
    forall a. a -> Maybe a
    Just ([LMString] -> LMString
    concatFS [String -> LMString
    fsLit String
    ".text.", LMString
    lbl])
        | Bool
    otherwise               = LMSection
    forall a. Maybe a
    Nothing

    -- | A Function's arguments
    llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
    llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
    llvmFunArgs Platform
    platform LiveGlobalRegs
    live =
        (GlobalReg -> LlvmVar) -> LiveGlobalRegs -> [LlvmVar]
    forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> GlobalReg -> LlvmVar
    lmGlobalRegArg Platform
    platform) ((GlobalReg -> Bool) -> LiveGlobalRegs -> LiveGlobalRegs
    forall a. (a -> Bool) -> [a] -> [a]
    filter GlobalReg -> Bool
    isPassed LiveGlobalRegs
    allRegs)
        where allRegs :: LiveGlobalRegs
    allRegs = Platform -> LiveGlobalRegs
    activeStgRegs Platform
    platform
              paddingRegs :: LiveGlobalRegs
    paddingRegs = Platform -> LiveGlobalRegs -> LiveGlobalRegs
    padLiveArgs Platform
    platform LiveGlobalRegs
    live
              isLive :: GlobalReg -> Bool
    isLive GlobalReg
    r = GlobalReg
    r GlobalReg -> LiveGlobalRegs -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` LiveGlobalRegs
    alwaysLive
                         Bool -> Bool -> Bool
    || GlobalReg
    r GlobalReg -> LiveGlobalRegs -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` LiveGlobalRegs
    live
                         Bool -> Bool -> Bool
    || GlobalReg
    r GlobalReg -> LiveGlobalRegs -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` LiveGlobalRegs
    paddingRegs
              isPassed :: GlobalReg -> Bool
    isPassed GlobalReg
    r = Bool -> Bool
    not (GlobalReg -> Bool
    isFPR GlobalReg
    r) Bool -> Bool -> Bool
    || GlobalReg -> Bool
    isLive GlobalReg
    r

    isFPR :: GlobalReg -> Bool
    isFPR :: GlobalReg -> Bool
    isFPR (FloatReg Int
    _)  = Bool
    True
    isFPR (DoubleReg Int
    _) = Bool
    True
    isFPR (XmmReg Int
    _)    = Bool
    True
    isFPR (YmmReg Int
    _)    = Bool
    True
    isFPR (ZmmReg Int
    _)    = Bool
    True
    isFPR GlobalReg
    _             = Bool
    False

    -- | Return a list of "padding" registers for LLVM function calls.
    --
    -- When we generate LLVM function signatures, we can't just make any register
    -- alive on function entry. Instead, we need to insert fake arguments of the
    -- same register class until we are sure that one of them is mapped to the
    -- register we want alive. E.g. to ensure that F5 is alive, we may need to
    -- insert fake arguments mapped to F1, F2, F3 and F4.
    --
    -- Invariant: Cmm FPR regs with number "n" maps to real registers with number
    -- "n" If the calling convention uses registers in a different order or if the
    -- invariant doesn't hold, this code probably won't be correct.
    padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
    padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
    padLiveArgs Platform
    platform LiveGlobalRegs
    live =
          if Platform -> Bool
    platformUnregisterised Platform
    platform
            then [] -- not using GHC's register convention for platform.
            else LiveGlobalRegs
    padded
      where
        ----------------------------------
        -- handle floating-point registers (FPR)

        fprLive :: LiveGlobalRegs
    fprLive = (GlobalReg -> Bool) -> LiveGlobalRegs -> LiveGlobalRegs
    forall a. (a -> Bool) -> [a] -> [a]
    filter GlobalReg -> Bool
    isFPR LiveGlobalRegs
    live  -- real live FPR registers

        -- we group live registers sharing the same classes, i.e. that use the same
        -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg
        -- all use the same real regs on X86-64 (XMM registers).
        --
        classes :: [NonEmpty GlobalReg]
    classes         = (GlobalReg -> GlobalReg -> Bool)
    -> LiveGlobalRegs -> [NonEmpty GlobalReg]
    forall (f :: * -> *) a.
    Foldable f =>
    (a -> a -> Bool) -> f a -> [NonEmpty a]
    NE.groupBy GlobalReg -> GlobalReg -> Bool
    sharesClass LiveGlobalRegs
    fprLive
        sharesClass :: GlobalReg -> GlobalReg -> Bool
    sharesClass GlobalReg
    a GlobalReg
    b = Platform -> GlobalReg -> GlobalReg -> Bool
    globalRegsOverlap Platform
    platform (GlobalReg -> GlobalReg
    norm GlobalReg
    a) (GlobalReg -> GlobalReg
    norm GlobalReg
    b) -- check if mapped to overlapping registers
        norm :: GlobalReg -> GlobalReg
    norm GlobalReg
    x          = GlobalReg -> Int -> GlobalReg
    fpr_ctor GlobalReg
    x Int
    1                                 -- get the first register of the family

        -- For each class, we just have to fill missing registers numbers. We use
        -- the constructor of the greatest register to build padding registers.
        --
        -- E.g. sortedRs = [   F2,   XMM4, D5]
        --      output   = [D1,   D3]
        padded :: LiveGlobalRegs
    padded      = (NonEmpty GlobalReg -> LiveGlobalRegs)
    -> [NonEmpty GlobalReg] -> LiveGlobalRegs
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap NonEmpty GlobalReg -> LiveGlobalRegs
    padClass [NonEmpty GlobalReg]
    classes
        padClass :: NonEmpty GlobalReg -> LiveGlobalRegs
    padClass NonEmpty GlobalReg
    rs = LiveGlobalRegs -> Int -> LiveGlobalRegs
    go (NonEmpty GlobalReg -> LiveGlobalRegs
    forall a. NonEmpty a -> [a]
    NE.toList NonEmpty GlobalReg
    sortedRs) Int
    1
          where
             sortedRs :: NonEmpty GlobalReg
    sortedRs = (GlobalReg -> GlobalReg -> Ordering)
    -> NonEmpty GlobalReg -> NonEmpty GlobalReg
    forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
    NE.sortBy ((GlobalReg -> Int) -> GlobalReg -> GlobalReg -> Ordering
    forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing GlobalReg -> Int
    fpr_num) NonEmpty GlobalReg
    rs
             maxr :: GlobalReg
    maxr     = NonEmpty GlobalReg -> GlobalReg
    forall a. NonEmpty a -> a
    NE.last NonEmpty GlobalReg
    sortedRs
             ctor :: Int -> GlobalReg
    ctor     = GlobalReg -> Int -> GlobalReg
    fpr_ctor GlobalReg
    maxr

             go :: LiveGlobalRegs -> Int -> LiveGlobalRegs
    go [] Int
    _ = []
             go (GlobalReg
    c1:GlobalReg
    c2:LiveGlobalRegs
    _) Int
    _   -- detect bogus case (see #17920)
                | GlobalReg -> Int
    fpr_num GlobalReg
    c1 Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == GlobalReg -> Int
    fpr_num GlobalReg
    c2
                , Just RealReg
    real <- Platform -> GlobalReg -> Maybe RealReg
    globalRegMaybe Platform
    platform GlobalReg
    c1
                = String -> SDoc -> LiveGlobalRegs
    forall a. String -> SDoc -> a
    sorryDoc String
    "LLVM code generator" (SDoc -> LiveGlobalRegs) -> SDoc -> LiveGlobalRegs
    forall a b. (a -> b) -> a -> b
    $
                   String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Found two different Cmm registers (" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> GlobalReg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr GlobalReg
    c1 SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "," SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> GlobalReg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr GlobalReg
    c2 SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
                   String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    ") both alive AND mapped to the same real register: " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> RealReg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr RealReg
    real SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
                   String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    ". This isn't currently supported by the LLVM backend."
             go (GlobalReg
    c:LiveGlobalRegs
    cs) Int
    f
                | GlobalReg -> Int
    fpr_num GlobalReg
    c Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    f = LiveGlobalRegs -> Int -> LiveGlobalRegs
    go LiveGlobalRegs
    cs Int
    f                    -- already covered by a real register
                | Bool
    otherwise      = Int -> GlobalReg
    ctor Int
    f GlobalReg -> LiveGlobalRegs -> LiveGlobalRegs
    forall a. a -> [a] -> [a]
    : LiveGlobalRegs -> Int -> LiveGlobalRegs
    go (GlobalReg
    cGlobalReg -> LiveGlobalRegs -> LiveGlobalRegs
    forall a. a -> [a] -> [a]
    :LiveGlobalRegs
    cs) (Int
    f Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) -- add padding register

        fpr_ctor :: GlobalReg -> Int -> GlobalReg
        fpr_ctor :: GlobalReg -> Int -> GlobalReg
    fpr_ctor (FloatReg Int
    _)  = Int -> GlobalReg
    FloatReg
        fpr_ctor (DoubleReg Int
    _) = Int -> GlobalReg
    DoubleReg
        fpr_ctor (XmmReg Int
    _)    = Int -> GlobalReg
    XmmReg
        fpr_ctor (YmmReg Int
    _)    = Int -> GlobalReg
    YmmReg
        fpr_ctor (ZmmReg Int
    _)    = Int -> GlobalReg
    ZmmReg
        fpr_ctor GlobalReg
    _ = String -> Int -> GlobalReg
    forall a. HasCallStack => String -> a
    error String
    "fpr_ctor expected only FPR regs"

        fpr_num :: GlobalReg -> Int
        fpr_num :: GlobalReg -> Int
    fpr_num (FloatReg Int
    i)  = Int
    i
        fpr_num (DoubleReg Int
    i) = Int
    i
        fpr_num (XmmReg Int
    i)    = Int
    i
        fpr_num (YmmReg Int
    i)    = Int
    i
        fpr_num (ZmmReg Int
    i)    = Int
    i
        fpr_num GlobalReg
    _ = String -> Int
    forall a. HasCallStack => String -> a
    error String
    "fpr_num expected only FPR regs"

    -- | Llvm standard fun attributes
    llvmStdFunAttrs :: [LlvmFuncAttr]
    llvmStdFunAttrs :: [LlvmFuncAttr]
    llvmStdFunAttrs = [LlvmFuncAttr
    NoUnwind]

    -- | Convert a list of types to a list of function parameters
    -- (each with no parameter attributes)
    tysToParams :: [LlvmType] -> [LlvmParameter]
    tysToParams :: [LlvmType] -> [(LlvmType, [LlvmParamAttr])]
    tysToParams = (LlvmType -> (LlvmType, [LlvmParamAttr]))
    -> [LlvmType] -> [(LlvmType, [LlvmParamAttr])]
    forall a b. (a -> b) -> [a] -> [b]
    map (\LlvmType
    ty -> (LlvmType
    ty, []))

    -- | Pointer width
    llvmPtrBits :: Platform -> Int
    llvmPtrBits :: Platform -> Int
    llvmPtrBits Platform
    platform = Width -> Int
    widthInBits (Width -> Int) -> Width -> Int
    forall a b. (a -> b) -> a -> b
    $ CmmType -> Width
    typeWidth (CmmType -> Width) -> CmmType -> Width
    forall a b. (a -> b) -> a -> b
    $ Platform -> CmmType
    gcWord Platform
    platform

    -- ----------------------------------------------------------------------------
    -- * Environment Handling
    --

    data LlvmEnv = LlvmEnv
      { LlvmEnv -> LlvmVersion
    envVersion   :: LlvmVersion      -- ^ LLVM version
      , LlvmEnv -> LlvmCgConfig
    envConfig    :: !LlvmCgConfig    -- ^ Configuration for LLVM code gen
      , LlvmEnv -> Logger
    envLogger    :: !Logger          -- ^ Logger
      , LlvmEnv -> BufHandle
    envOutput    :: BufHandle        -- ^ Output buffer
      , LlvmEnv -> Char
    envTag       :: !Char            -- ^ Tag for creating unique values
      , LlvmEnv -> MetaId
    envFreshMeta :: MetaId           -- ^ Supply of fresh metadata IDs
      , LlvmEnv -> UniqFM Unique MetaId
    envUniqMeta  :: UniqFM Unique MetaId   -- ^ Global metadata nodes
      , LlvmEnv -> LlvmEnvMap
    envFunMap    :: LlvmEnvMap       -- ^ Global functions so far, with type
      , LlvmEnv -> UniqSet LMString
    envAliases   :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
      , LlvmEnv -> [LlvmVar]
    envUsedVars  :: [LlvmVar]        -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)

        -- the following get cleared for every function (see @withClearVars@)
      , LlvmEnv -> LlvmEnvMap
    envVarMap    :: LlvmEnvMap       -- ^ Local variables so far, with type
      , LlvmEnv -> LiveGlobalRegs
    envStackRegs :: [GlobalReg]      -- ^ Non-constant registers (alloca'd in the function prelude)
      }

    type LlvmEnvMap = UniqFM Unique LlvmType

    -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
    newtype LlvmM a = LlvmM { forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
    runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
        deriving stock ((forall a b. (a -> b) -> LlvmM a -> LlvmM b)
    -> (forall a b. a -> LlvmM b -> LlvmM a) -> Functor LlvmM
    forall a b. a -> LlvmM b -> LlvmM a
    forall a b. (a -> b) -> LlvmM a -> LlvmM 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) -> LlvmM a -> LlvmM b
    fmap :: forall a b. (a -> b) -> LlvmM a -> LlvmM b
    $c<$ :: forall a b. a -> LlvmM b -> LlvmM a
    <$ :: forall a b. a -> LlvmM b -> LlvmM a
    Functor)
        deriving (Functor LlvmM
    Functor LlvmM =>
    (forall a. a -> LlvmM a)
    -> (forall a b. LlvmM (a -> b) -> LlvmM a -> LlvmM b)
    -> (forall a b c. (a -> b -> c) -> LlvmM a -> LlvmM b -> LlvmM c)
    -> (forall a b. LlvmM a -> LlvmM b -> LlvmM b)
    -> (forall a b. LlvmM a -> LlvmM b -> LlvmM a)
    -> Applicative LlvmM
    forall a. a -> LlvmM a
    forall a b. LlvmM a -> LlvmM b -> LlvmM a
    forall a b. LlvmM a -> LlvmM b -> LlvmM b
    forall a b. LlvmM (a -> b) -> LlvmM a -> LlvmM b
    forall a b c. (a -> b -> c) -> LlvmM a -> LlvmM b -> LlvmM 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 -> LlvmM a
    pure :: forall a. a -> LlvmM a
    $c<*> :: forall a b. LlvmM (a -> b) -> LlvmM a -> LlvmM b
    <*> :: forall a b. LlvmM (a -> b) -> LlvmM a -> LlvmM b
    $cliftA2 :: forall a b c. (a -> b -> c) -> LlvmM a -> LlvmM b -> LlvmM c
    liftA2 :: forall a b c. (a -> b -> c) -> LlvmM a -> LlvmM b -> LlvmM c
    $c*> :: forall a b. LlvmM a -> LlvmM b -> LlvmM b
    *> :: forall a b. LlvmM a -> LlvmM b -> LlvmM b
    $c<* :: forall a b. LlvmM a -> LlvmM b -> LlvmM a
    <* :: forall a b. LlvmM a -> LlvmM b -> LlvmM a
    Applicative, Applicative LlvmM
    Applicative LlvmM =>
    (forall a b. LlvmM a -> (a -> LlvmM b) -> LlvmM b)
    -> (forall a b. LlvmM a -> LlvmM b -> LlvmM b)
    -> (forall a. a -> LlvmM a)
    -> Monad LlvmM
    forall a. a -> LlvmM a
    forall a b. LlvmM a -> LlvmM b -> LlvmM b
    forall a b. LlvmM a -> (a -> LlvmM b) -> LlvmM 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. LlvmM a -> (a -> LlvmM b) -> LlvmM b
    >>= :: forall a b. LlvmM a -> (a -> LlvmM b) -> LlvmM b
    $c>> :: forall a b. LlvmM a -> LlvmM b -> LlvmM b
    >> :: forall a b. LlvmM a -> LlvmM b -> LlvmM b
    $creturn :: forall a. a -> LlvmM a
    return :: forall a. a -> LlvmM a
    Monad) via StateT LlvmEnv IO

    instance HasLogger LlvmM where
        getLogger :: LlvmM Logger
    getLogger = (LlvmEnv -> IO (Logger, LlvmEnv)) -> LlvmM Logger
    forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    LlvmM ((LlvmEnv -> IO (Logger, LlvmEnv)) -> LlvmM Logger)
    -> (LlvmEnv -> IO (Logger, LlvmEnv)) -> LlvmM Logger
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> (Logger, LlvmEnv) -> IO (Logger, LlvmEnv)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LlvmEnv -> Logger
    envLogger LlvmEnv
    env, LlvmEnv
    env)

    -- | Get target platform
    getPlatform :: LlvmM Platform
    getPlatform :: LlvmM Platform
    getPlatform = LlvmCgConfig -> Platform
    llvmCgPlatform (LlvmCgConfig -> Platform) -> LlvmM LlvmCgConfig -> LlvmM Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> LlvmM LlvmCgConfig
    getConfig

    getConfig :: LlvmM LlvmCgConfig
    getConfig :: LlvmM LlvmCgConfig
    getConfig = (LlvmEnv -> IO (LlvmCgConfig, LlvmEnv)) -> LlvmM LlvmCgConfig
    forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    LlvmM ((LlvmEnv -> IO (LlvmCgConfig, LlvmEnv)) -> LlvmM LlvmCgConfig)
    -> (LlvmEnv -> IO (LlvmCgConfig, LlvmEnv)) -> LlvmM LlvmCgConfig
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> (LlvmCgConfig, LlvmEnv) -> IO (LlvmCgConfig, LlvmEnv)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LlvmEnv -> LlvmCgConfig
    envConfig LlvmEnv
    env, LlvmEnv
    env)

    instance MonadUnique LlvmM where
        getUniqueSupplyM :: LlvmM UniqSupply
    getUniqueSupplyM = do
            tag <- (LlvmEnv -> Char) -> LlvmM Char
    forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv LlvmEnv -> Char
    envTag
            liftIO $! mkSplitUniqSupply tag

        getUniqueM :: LlvmM Unique
    getUniqueM = do
            tag <- (LlvmEnv -> Char) -> LlvmM Char
    forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv LlvmEnv -> Char
    envTag
            liftIO $! uniqFromTag tag

    -- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
    liftIO :: IO a -> LlvmM a
    liftIO :: forall a. IO a -> LlvmM a
    liftIO IO a
    m = (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    LlvmM ((LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a)
    -> (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> do x <- IO a
    m
                                  return (x, env)

    -- | Get initial Llvm environment.
    runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
    runLlvm :: forall a.
    Logger
    -> LlvmCgConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
    runLlvm Logger
    logger LlvmCgConfig
    cfg LlvmVersion
    ver BufHandle
    out LlvmM a
    m = do
        (a, _) <- LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
    forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
    runLlvmM LlvmM a
    m LlvmEnv
    env
        return a
      where env :: LlvmEnv
    env = LlvmEnv { envFunMap :: LlvmEnvMap
    envFunMap    = LlvmEnvMap
    forall {k} (key :: k) elt. UniqFM key elt
    emptyUFM
                          , envVarMap :: LlvmEnvMap
    envVarMap    = LlvmEnvMap
    forall {k} (key :: k) elt. UniqFM key elt
    emptyUFM
                          , envStackRegs :: LiveGlobalRegs
    envStackRegs = []
                          , envUsedVars :: [LlvmVar]
    envUsedVars  = []
                          , envAliases :: UniqSet LMString
    envAliases   = UniqSet LMString
    forall a. UniqSet a
    emptyUniqSet
                          , envVersion :: LlvmVersion
    envVersion   = LlvmVersion
    ver
                          , envConfig :: LlvmCgConfig
    envConfig    = LlvmCgConfig
    cfg
                          , envLogger :: Logger
    envLogger    = Logger
    logger
                          , envOutput :: BufHandle
    envOutput    = BufHandle
    out
                          , envTag :: Char
    envTag       = Char
    'n'
                          , envFreshMeta :: MetaId
    envFreshMeta = Int -> MetaId
    MetaId Int
    0
                          , envUniqMeta :: UniqFM Unique MetaId
    envUniqMeta  = UniqFM Unique MetaId
    forall {k} (key :: k) elt. UniqFM key elt
    emptyUFM
                          }

    -- | Get environment (internal)
    getEnv :: (LlvmEnv -> a) -> LlvmM a
    getEnv :: forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv LlvmEnv -> a
    f = (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    LlvmM (\LlvmEnv
    env -> (a, LlvmEnv) -> IO (a, LlvmEnv)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LlvmEnv -> a
    f LlvmEnv
    env, LlvmEnv
    env))

    -- | Modify environment (internal)
    modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
    modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
    modifyEnv LlvmEnv -> LlvmEnv
    f = (LlvmEnv -> IO ((), LlvmEnv)) -> LlvmM ()
    forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    LlvmM (\LlvmEnv
    env -> ((), LlvmEnv) -> IO ((), LlvmEnv)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((), LlvmEnv -> LlvmEnv
    f LlvmEnv
    env))

    -- | Clear variables from the environment for a subcomputation
    withClearVars :: LlvmM a -> LlvmM a
    withClearVars :: forall a. LlvmM a -> LlvmM a
    withClearVars LlvmM a
    m = (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    LlvmM ((LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a)
    -> (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> do
        (x, env') <- LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
    forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
    runLlvmM LlvmM a
    m LlvmEnv
    env { envVarMap = emptyUFM, envStackRegs = [] }
        return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })

    -- | Insert variables or functions into the environment.
    varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
    varInsert :: forall key. Uniquable key => key -> LlvmType -> LlvmM ()
    varInsert key
    s LlvmType
    t = (LlvmEnv -> LlvmEnv) -> LlvmM ()
    modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
    -> (LlvmEnv -> LlvmEnv) -> LlvmM ()
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> LlvmEnv
    env { envVarMap = addToUFM (envVarMap env) (getUnique s) t }
    funInsert :: forall key. Uniquable key => key -> LlvmType -> LlvmM ()
    funInsert key
    s LlvmType
    t = (LlvmEnv -> LlvmEnv) -> LlvmM ()
    modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
    -> (LlvmEnv -> LlvmEnv) -> LlvmM ()
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> LlvmEnv
    env { envFunMap = addToUFM (envFunMap env) (getUnique s) t }

    -- | Lookup variables or functions in the environment.
    varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
    varLookup :: forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
    varLookup key
    s = (LlvmEnv -> Maybe LlvmType) -> LlvmM (Maybe LlvmType)
    forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv ((LlvmEnvMap -> Unique -> Maybe LlvmType)
    -> Unique -> LlvmEnvMap -> Maybe LlvmType
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip LlvmEnvMap -> Unique -> Maybe LlvmType
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM (key -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique key
    s) (LlvmEnvMap -> Maybe LlvmType)
    -> (LlvmEnv -> LlvmEnvMap) -> LlvmEnv -> Maybe LlvmType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LlvmEnv -> LlvmEnvMap
    envVarMap)
    funLookup :: forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
    funLookup key
    s = (LlvmEnv -> Maybe LlvmType) -> LlvmM (Maybe LlvmType)
    forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv ((LlvmEnvMap -> Unique -> Maybe LlvmType)
    -> Unique -> LlvmEnvMap -> Maybe LlvmType
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip LlvmEnvMap -> Unique -> Maybe LlvmType
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM (key -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique key
    s) (LlvmEnvMap -> Maybe LlvmType)
    -> (LlvmEnv -> LlvmEnvMap) -> LlvmEnv -> Maybe LlvmType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LlvmEnv -> LlvmEnvMap
    envFunMap)

    -- | Set a register as allocated on the stack
    markStackReg :: GlobalReg -> LlvmM ()
    markStackReg :: GlobalReg -> LlvmM ()
    markStackReg GlobalReg
    r = (LlvmEnv -> LlvmEnv) -> LlvmM ()
    modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
    -> (LlvmEnv -> LlvmEnv) -> LlvmM ()
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> LlvmEnv
    env { envStackRegs = r : envStackRegs env }

    -- | Check whether a register is allocated on the stack
    checkStackReg :: GlobalReg -> LlvmM Bool
    checkStackReg :: GlobalReg -> LlvmM Bool
    checkStackReg GlobalReg
    r = (LlvmEnv -> Bool) -> LlvmM Bool
    forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv ((GlobalReg -> LiveGlobalRegs -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    elem GlobalReg
    r) (LiveGlobalRegs -> Bool)
    -> (LlvmEnv -> LiveGlobalRegs) -> LlvmEnv -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LlvmEnv -> LiveGlobalRegs
    envStackRegs)

    -- | Allocate a new global unnamed metadata identifier
    getMetaUniqueId :: LlvmM MetaId
    getMetaUniqueId :: LlvmM MetaId
    getMetaUniqueId = (LlvmEnv -> IO (MetaId, LlvmEnv)) -> LlvmM MetaId
    forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
    LlvmM ((LlvmEnv -> IO (MetaId, LlvmEnv)) -> LlvmM MetaId)
    -> (LlvmEnv -> IO (MetaId, LlvmEnv)) -> LlvmM MetaId
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env ->
        (MetaId, LlvmEnv) -> IO (MetaId, LlvmEnv)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LlvmEnv -> MetaId
    envFreshMeta LlvmEnv
    env, LlvmEnv
    env { envFreshMeta = succ $ envFreshMeta env })

    -- | Get the LLVM version we are generating code for
    getLlvmVer :: LlvmM LlvmVersion
    getLlvmVer :: LlvmM LlvmVersion
    getLlvmVer = (LlvmEnv -> LlvmVersion) -> LlvmM LlvmVersion
    forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv LlvmEnv -> LlvmVersion
    envVersion

    -- | Dumps the document if the corresponding flag has been set by the user
    dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
    dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> SDoc -> LlvmM ()
    dumpIfSetLlvm DumpFlag
    flag String
    hdr DumpFormat
    fmt SDoc
    doc = do
      logger <- LlvmM Logger
    forall (m :: * -> *). HasLogger m => m Logger
    getLogger
      liftIO $ putDumpFileMaybe logger flag hdr fmt doc

    -- | Prints the given contents to the output handle
    renderLlvm :: Outp.HDoc -> Outp.SDoc -> LlvmM ()
    renderLlvm :: HDoc -> SDoc -> LlvmM ()
    renderLlvm HDoc
    hdoc SDoc
    sdoc = do

        -- Write to output
        ctx <- LlvmCgConfig -> SDocContext
    llvmCgContext (LlvmCgConfig -> SDocContext)
    -> LlvmM LlvmCgConfig -> LlvmM SDocContext
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> LlvmM LlvmCgConfig
    getConfig
        out <- getEnv envOutput
        liftIO $ Outp.bPutHDoc out ctx hdoc

        -- Dump, if requested
        dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc
        return ()

    -- | Marks a variable as "used"
    markUsedVar :: LlvmVar -> LlvmM ()
    markUsedVar :: LlvmVar -> LlvmM ()
    markUsedVar LlvmVar
    v = (LlvmEnv -> LlvmEnv) -> LlvmM ()
    modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
    -> (LlvmEnv -> LlvmEnv) -> LlvmM ()
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> LlvmEnv
    env { envUsedVars = v : envUsedVars env }

    -- | Return all variables marked as "used" so far
    getUsedVars :: LlvmM [LlvmVar]
    getUsedVars :: LlvmM [LlvmVar]
    getUsedVars = (LlvmEnv -> [LlvmVar]) -> LlvmM [LlvmVar]
    forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv LlvmEnv -> [LlvmVar]
    envUsedVars

    -- | Saves that at some point we didn't know the type of the label and
    -- generated a reference to a type variable instead
    saveAlias :: LMString -> LlvmM ()
    saveAlias :: LMString -> LlvmM ()
    saveAlias LMString
    lbl = (LlvmEnv -> LlvmEnv) -> LlvmM ()
    modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
    -> (LlvmEnv -> LlvmEnv) -> LlvmM ()
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> LlvmEnv
    env { envAliases = addOneToUniqSet (envAliases env) lbl }

    -- | Sets metadata node for a given unique
    setUniqMeta :: Unique -> MetaId -> LlvmM ()
    setUniqMeta :: Unique -> MetaId -> LlvmM ()
    setUniqMeta Unique
    f MetaId
    m = (LlvmEnv -> LlvmEnv) -> LlvmM ()
    modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
    -> (LlvmEnv -> LlvmEnv) -> LlvmM ()
    forall a b. (a -> b) -> a -> b
    $ \LlvmEnv
    env -> LlvmEnv
    env { envUniqMeta = addToUFM (envUniqMeta env) f m }

    -- | Gets metadata node for given unique
    getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
    getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
    getUniqMeta Unique
    s = (LlvmEnv -> Maybe MetaId) -> LlvmM (Maybe MetaId)
    forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv ((UniqFM Unique MetaId -> Unique -> Maybe MetaId)
    -> Unique -> UniqFM Unique MetaId -> Maybe MetaId
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip UniqFM Unique MetaId -> Unique -> Maybe MetaId
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM Unique
    s (UniqFM Unique MetaId -> Maybe MetaId)
    -> (LlvmEnv -> UniqFM Unique MetaId) -> LlvmEnv -> Maybe MetaId
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LlvmEnv -> UniqFM Unique MetaId
    envUniqMeta)

    -- ----------------------------------------------------------------------------
    -- * Internal functions
    --

    -- | Here we pre-initialise some functions that are used internally by GHC
    -- so as to make sure they have the most general type in the case that
    -- user code also uses these functions but with a different type than GHC
    -- internally. (Main offender is treating return type as 'void' instead of
    -- 'void *'). Fixes #5486.
    ghcInternalFunctions :: LlvmM ()
    ghcInternalFunctions :: LlvmM ()
    ghcInternalFunctions = do
        platform <- LlvmM Platform
    getPlatform
        let w = Platform -> LlvmType
    llvmWord Platform
    platform
            cint = Int -> LlvmType
    LMInt (Int -> LlvmType) -> Int -> LlvmType
    forall a b. (a -> b) -> a -> b
    $ Width -> Int
    widthInBits (Width -> Int) -> Width -> Int
    forall a b. (a -> b) -> a -> b
    $ Platform -> Width
    cIntWidth Platform
    platform
        mk "memcmp" cint [i8Ptr, i8Ptr, w]
        mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]
        mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]
        mk "memset" i8Ptr [i8Ptr, w, w]
        mk "newSpark" w [i8Ptr, i8Ptr]
      where
        mk :: String -> LlvmType -> [LlvmType] -> LlvmM ()
    mk String
    n LlvmType
    ret [LlvmType]
    args = do
          let n' :: LMString
    n' = String -> LMString
    fsLit String
    n
              decl :: LlvmFunctionDecl
    decl = LMString
    -> LlvmLinkageType
    -> LlvmCallConvention
    -> LlvmType
    -> LlvmParameterListType
    -> [(LlvmType, [LlvmParamAttr])]
    -> LMAlign
    -> LlvmFunctionDecl
    LlvmFunctionDecl LMString
    n' LlvmLinkageType
    ExternallyVisible LlvmCallConvention
    CC_Ccc LlvmType
    ret
                                     LlvmParameterListType
    FixedArgs ([LlvmType] -> [(LlvmType, [LlvmParamAttr])]
    tysToParams [LlvmType]
    args) LMAlign
    forall a. Maybe a
    Nothing
          HDoc -> SDoc -> LlvmM ()
    renderLlvm (LlvmFunctionDecl -> HDoc
    forall doc. IsDoc doc => LlvmFunctionDecl -> doc
    ppLlvmFunctionDecl LlvmFunctionDecl
    decl) (LlvmFunctionDecl -> SDoc
    forall doc. IsDoc doc => LlvmFunctionDecl -> doc
    ppLlvmFunctionDecl LlvmFunctionDecl
    decl)
          LMString -> LlvmType -> LlvmM ()
    forall key. Uniquable key => key -> LlvmType -> LlvmM ()
    funInsert LMString
    n' (LlvmFunctionDecl -> LlvmType
    LMFunction LlvmFunctionDecl
    decl)

    -- ----------------------------------------------------------------------------
    -- * Label handling
    --

    -- | Pretty print a 'CLabel'.
    strCLabel_llvm :: CLabel -> LlvmM LMString
    strCLabel_llvm :: CLabel -> LlvmM LMString
    strCLabel_llvm CLabel
    lbl = do
        ctx <- LlvmCgConfig -> SDocContext
    llvmCgContext (LlvmCgConfig -> SDocContext)
    -> LlvmM LlvmCgConfig -> LlvmM SDocContext
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> LlvmM LlvmCgConfig
    getConfig
        platform <- getPlatform
        let sdoc = Platform -> CLabel -> SDoc
    forall doc. IsLine doc => Platform -> CLabel -> doc
    pprCLabel Platform
    platform CLabel
    lbl
            str = SDocContext -> SDoc -> String
    Outp.showSDocOneLine SDocContext
    ctx SDoc
    sdoc
        return (fsLit str)

    -- ----------------------------------------------------------------------------
    -- * Global variables / forward references
    --

    -- | Create/get a pointer to a global value. Might return an alias if
    -- the value in question hasn't been defined yet. We especially make
    -- no guarantees on the type of the returned pointer.
    getGlobalPtr :: LMString -> LlvmM LlvmVar
    getGlobalPtr :: LMString -> LlvmM LlvmVar
    getGlobalPtr LMString
    llvmLbl = do
      m_ty <- LMString -> LlvmM (Maybe LlvmType)
    forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
    funLookup LMString
    llvmLbl
      let mkGlbVar LMString
    lbl LlvmType
    ty = LMString
    -> LlvmType
    -> LlvmLinkageType
    -> LMSection
    -> LMAlign
    -> LMConst
    -> LlvmVar
    LMGlobalVar LMString
    lbl (LlvmType -> LlvmType
    LMPointer LlvmType
    ty) LlvmLinkageType
    Private LMSection
    forall a. Maybe a
    Nothing LMAlign
    forall a. Maybe a
    Nothing
      case m_ty of
        -- Directly reference if we have seen it already
        Just LlvmType
    ty -> do
          if LMString
    llvmLbl LMString -> [LMString] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` ((String -> LMString) -> [String] -> [LMString]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> LMString
    fsLit [String
    "newSpark", String
    "memmove", String
    "memcpy", String
    "memcmp", String
    "memset"])
            then LlvmVar -> LlvmM LlvmVar
    forall a. a -> LlvmM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LlvmVar -> LlvmM LlvmVar) -> LlvmVar -> LlvmM LlvmVar
    forall a b. (a -> b) -> a -> b
    $ LMString -> LlvmType -> LMConst -> LlvmVar
    mkGlbVar (LMString
    llvmLbl) LlvmType
    ty LMConst
    Global
            else LlvmVar -> LlvmM LlvmVar
    forall a. a -> LlvmM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LlvmVar -> LlvmM LlvmVar) -> LlvmVar -> LlvmM LlvmVar
    forall a b. (a -> b) -> a -> b
    $ LMString -> LlvmType -> LMConst -> LlvmVar
    mkGlbVar (LMString -> LMString
    llvmDefLabel LMString
    llvmLbl) LlvmType
    ty LMConst
    Global
        -- Otherwise use a forward alias of it
        Maybe LlvmType
    Nothing -> do
          LMString -> LlvmM ()
    saveAlias LMString
    llvmLbl
          LlvmVar -> LlvmM LlvmVar
    forall a. a -> LlvmM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (LlvmVar -> LlvmM LlvmVar) -> LlvmVar -> LlvmM LlvmVar
    forall a b. (a -> b) -> a -> b
    $ LMString -> LlvmType -> LMConst -> LlvmVar
    mkGlbVar LMString
    llvmLbl LlvmType
    i8 LMConst
    Alias

    -- | Derive the definition label. It has an identified
    -- structure type.
    llvmDefLabel :: LMString -> LMString
    llvmDefLabel :: LMString -> LMString
    llvmDefLabel = (LMString -> LMString -> LMString
    `appendFS` String -> LMString
    fsLit String
    "$def")

    -- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
    --
    -- Must be called at a point where we are sure that no new global definitions
    -- will be generated anymore!
    generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
    generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
    generateExternDecls = do
      delayed <- (UniqSet LMString -> [LMString])
    -> LlvmM (UniqSet LMString) -> LlvmM [LMString]
    forall a b. (a -> b) -> LlvmM a -> LlvmM b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap UniqSet LMString -> [LMString]
    forall elt. UniqSet elt -> [elt]
    nonDetEltsUniqSet (LlvmM (UniqSet LMString) -> LlvmM [LMString])
    -> LlvmM (UniqSet LMString) -> LlvmM [LMString]
    forall a b. (a -> b) -> a -> b
    $ (LlvmEnv -> UniqSet LMString) -> LlvmM (UniqSet LMString)
    forall a. (LlvmEnv -> a) -> LlvmM a
    getEnv LlvmEnv -> UniqSet LMString
    envAliases
      -- This is non-deterministic but we do not
      -- currently support deterministic code-generation.
      -- See Note [Unique Determinism and code generation]
      defss <- flip mapM delayed $ \LMString
    lbl -> do
        m_ty <- LMString -> LlvmM (Maybe LlvmType)
    forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
    funLookup LMString
    lbl
        case m_ty of
          -- If we have a definition we've already emitted the proper aliases
          -- when the symbol itself was emitted by @aliasify@
          Just LlvmType
    _ -> [LMGlobal] -> LlvmM [LMGlobal]
    forall a. a -> LlvmM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

          -- If we don't have a definition this is an external symbol and we
          -- need to emit a declaration
          Maybe LlvmType
    Nothing ->
            let var :: LlvmVar
    var = LMString
    -> LlvmType
    -> LlvmLinkageType
    -> LMSection
    -> LMAlign
    -> LMConst
    -> LlvmVar
    LMGlobalVar LMString
    lbl LlvmType
    i8Ptr LlvmLinkageType
    External LMSection
    forall a. Maybe a
    Nothing LMAlign
    forall a. Maybe a
    Nothing LMConst
    Global
            in [LMGlobal] -> LlvmM [LMGlobal]
    forall a. a -> LlvmM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [LlvmVar -> Maybe LlvmStatic -> LMGlobal
    LMGlobal LlvmVar
    var Maybe LlvmStatic
    forall a. Maybe a
    Nothing]

      -- Reset forward list
      modifyEnv $ \LlvmEnv
    env -> LlvmEnv
    env { envAliases = emptyUniqSet }
      return (concat defss, [])

    -- | Is a variable one of the special @$llvm@ globals?
    isBuiltinLlvmVar :: LlvmVar -> Bool
    isBuiltinLlvmVar :: LlvmVar -> Bool
    isBuiltinLlvmVar (LMGlobalVar LMString
    lbl LlvmType
    _ LlvmLinkageType
    _ LMSection
    _ LMAlign
    _ LMConst
    _) =
        String
    "$llvm" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` LMString -> String
    unpackFS LMString
    lbl
    isBuiltinLlvmVar LlvmVar
    _ = Bool
    False

    -- | Here we take a global variable definition, rename it with a
    -- @$def@ suffix, and generate the appropriate alias.
    aliasify :: LMGlobal -> LlvmM [LMGlobal]
    -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
    -- Here we obtain the indirectee's precise type and introduce
    -- fresh aliases to both the precise typed label (lbl$def) and the i8*
    -- typed (regular) label of it with the matching new names.
    aliasify :: LMGlobal -> LlvmM [LMGlobal]
    aliasify (LMGlobal var :: LlvmVar
    var@(LMGlobalVar LMString
    lbl ty :: LlvmType
    ty@LMAlias{} LlvmLinkageType
    link LMSection
    sect LMAlign
    align LMConst
    Alias)
                       (Just LlvmStatic
    orig))
      | Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ LlvmVar -> Bool
    isBuiltinLlvmVar LlvmVar
    var = do
        let defLbl :: LMString
    defLbl = LMString -> LMString
    llvmDefLabel LMString
    lbl
            LMStaticPointer (LMGlobalVar LMString
    origLbl LlvmType
    _ LlvmLinkageType
    oLnk LMSection
    Nothing LMAlign
    Nothing LMConst
    Alias) = LlvmStatic
    orig
            defOrigLbl :: LMString
    defOrigLbl = LMString -> LMString
    llvmDefLabel LMString
    origLbl
            orig' :: LlvmStatic
    orig' = LlvmVar -> LlvmStatic
    LMStaticPointer (LMString
    -> LlvmType
    -> LlvmLinkageType
    -> LMSection
    -> LMAlign
    -> LMConst
    -> LlvmVar
    LMGlobalVar LMString
    origLbl LlvmType
    i8Ptr LlvmLinkageType
    oLnk LMSection
    forall a. Maybe a
    Nothing LMAlign
    forall a. Maybe a
    Nothing LMConst
    Alias)
        origType <- LMString -> LlvmM (Maybe LlvmType)
    forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
    funLookup LMString
    origLbl
        let defOrig = LlvmStatic -> LlvmType -> LlvmStatic
    LMBitc (LlvmVar -> LlvmStatic
    LMStaticPointer (LMString
    -> LlvmType
    -> LlvmLinkageType
    -> LMSection
    -> LMAlign
    -> LMConst
    -> LlvmVar
    LMGlobalVar LMString
    defOrigLbl
                                               (LlvmType -> LlvmType
    pLift (LlvmType -> LlvmType) -> LlvmType -> LlvmType
    forall a b. (a -> b) -> a -> b
    $ Maybe LlvmType -> LlvmType
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe LlvmType
    origType) LlvmLinkageType
    oLnk
                                               LMSection
    forall a. Maybe a
    Nothing LMAlign
    forall a. Maybe a
    Nothing LMConst
    Alias))
                             (LlvmType -> LlvmType
    pLift LlvmType
    ty)
        pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
             , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
             ]
    aliasify (LMGlobal LlvmVar
    var Maybe LlvmStatic
    val)
      | Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ LlvmVar -> Bool
    isBuiltinLlvmVar LlvmVar
    var = do
        let LMGlobalVar LMString
    lbl LlvmType
    ty LlvmLinkageType
    link LMSection
    sect LMAlign
    align LMConst
    const = LlvmVar
    var

            defLbl :: LMString
    defLbl = LMString -> LMString
    llvmDefLabel LMString
    lbl
            defVar :: LlvmVar
    defVar = LMString
    -> LlvmType
    -> LlvmLinkageType
    -> LMSection
    -> LMAlign
    -> LMConst
    -> LlvmVar
    LMGlobalVar LMString
    defLbl LlvmType
    ty LlvmLinkageType
    Internal LMSection
    sect LMAlign
    align LMConst
    const

            defPtrVar :: LlvmVar
    defPtrVar = LMString
    -> LlvmType
    -> LlvmLinkageType
    -> LMSection
    -> LMAlign
    -> LMConst
    -> LlvmVar
    LMGlobalVar LMString
    defLbl (LlvmType -> LlvmType
    LMPointer LlvmType
    ty) LlvmLinkageType
    link LMSection
    forall a. Maybe a
    Nothing LMAlign
    forall a. Maybe a
    Nothing LMConst
    const
            aliasVar :: LlvmVar
    aliasVar = LMString
    -> LlvmType
    -> LlvmLinkageType
    -> LMSection
    -> LMAlign
    -> LMConst
    -> LlvmVar
    LMGlobalVar LMString
    lbl LlvmType
    i8Ptr LlvmLinkageType
    link LMSection
    forall a. Maybe a
    Nothing LMAlign
    forall a. Maybe a
    Nothing LMConst
    Alias
            aliasVal :: LlvmStatic
    aliasVal = LlvmStatic -> LlvmType -> LlvmStatic
    LMBitc (LlvmVar -> LlvmStatic
    LMStaticPointer LlvmVar
    defPtrVar) LlvmType
    i8Ptr

        -- we need to mark the $def symbols as used so LLVM doesn't forget which
        -- section they need to go in. This will vanish once we switch away from
        -- mangling sections for TNTC.
        LlvmVar -> LlvmM ()
    markUsedVar LlvmVar
    defVar

        [LMGlobal] -> LlvmM [LMGlobal]
    forall a. a -> LlvmM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ LlvmVar -> Maybe LlvmStatic -> LMGlobal
    LMGlobal LlvmVar
    defVar Maybe LlvmStatic
    val
               , LlvmVar -> Maybe LlvmStatic -> LMGlobal
    LMGlobal LlvmVar
    aliasVar (LlvmStatic -> Maybe LlvmStatic
    forall a. a -> Maybe a
    Just LlvmStatic
    aliasVal)
               ]
    aliasify LMGlobal
    global = [LMGlobal] -> LlvmM [LMGlobal]
    forall a. a -> LlvmM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure [LMGlobal
    global]

    -- Note [Llvm Forward References]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- The issue here is that LLVM insists on being strongly typed at
    -- every corner, so the first time we mention something, we have to
    -- settle what type we assign to it. That makes things awkward, as Cmm
    -- will often reference things before their definition, and we have no
    -- idea what (LLVM) type it is going to be before that point.
    --
    -- Our work-around is to define "aliases" of a standard type (i8 *) in
    -- these kind of situations, which we later tell LLVM to be either
    -- references to their actual local definitions (involving a cast) or
    -- an external reference. This obviously only works for pointers.
    --
    -- In particular when we encounter a reference to a symbol in a chunk of
    -- C-- there are three possible scenarios,
    --
    --   1. We have already seen a definition for the referenced symbol. This
    --      means we already know its type.
    --
    --   2. We have not yet seen a definition but we will find one later in this
    --      compilation unit. Since we want to be a good consumer of the
    --      C-- streamed to us from upstream, we don't know the type of the
    --      symbol at the time when we must emit the reference.
    --
    --   3. We have not yet seen a definition nor will we find one in this
    --      compilation unit. In this case the reference refers to an
    --      external symbol for which we do not know the type.
    --
    -- Let's consider case (2) for a moment: say we see a reference to
    -- the symbol @fooBar@ for which we have not seen a definition. As we
    -- do not know the symbol's type, we assume it is of type @i8*@ and emit
    -- the appropriate casts in @getSymbolPtr@. Later on, when we
    -- encounter the definition of @fooBar@ we emit it but with a modified
    -- name, @fooBar$def@ (which we'll call the definition symbol), to
    -- since we have already had to assume that the symbol @fooBar@
    -- is of type @i8*@. We then emit @fooBar@ itself as an alias
    -- of @fooBar$def@ with appropriate casts. This all happens in
    -- @aliasify@.
    --
    -- Case (3) is quite similar to (2): References are emitted assuming
    -- the referenced symbol is of type @i8*@. When we arrive at the end of
    -- the compilation unit and realize that the symbol is external, we emit
    -- an LLVM @external global@ declaration for the symbol @fooBar@
    -- (handled in @generateExternDecls@). This takes advantage of the
    -- fact that the aliases produced by @aliasify@ for exported symbols
    -- have external linkage and can therefore be used as normal symbols.
    --
    -- Historical note: As of release 3.5 LLVM does not allow aliases to
    -- refer to declarations. This the reason why aliases are produced at the
    -- point of definition instead of the point of usage, as was previously
    -- done. See #9142 for details.
    --
    -- Finally, case (1) is trivial. As we already have a definition for
    -- and therefore know the type of the referenced symbol, we can do
    -- away with casting the alias to the desired type in @getSymbolPtr@
    -- and instead just emit a reference to the definition symbol directly.
    -- This is the @Just@ case in @getSymbolPtr@.
    --
    -- Note that we must take care not to turn LLVM's builtin variables into
    -- aliases (e.g. $llvm.global_ctors) since this confuses LLVM.