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