{-# LANGUAGE CPP #-}

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

module LlvmCodeGen.Base (

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

        LlvmVersion (..), supportedLlvmVersion, llvmVersionStr,

        LlvmM,
        runLlvm, liftStream, withClearVars, varLookup, varInsert,
        markStackReg, checkStackReg,
        funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
        dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
        ghcInternalFunctions,

        getMetaUniqueId,
        setUniqMeta, getUniqMeta,

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

        strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
        getGlobalPtr, generateExternDecls,

        aliasify,
    ) where

#include "HsVersions.h"
#include "ghcautoconf.h"

import GhcPrelude

import Llvm
import LlvmCodeGen.Regs

import CLabel
import CodeGen.Platform ( activeStgRegs )
import DynFlags
import FastString
import Cmm              hiding ( succ )
import Outputable as Outp
import Platform
import UniqFM
import Unique
import BufWrite   ( BufHandle )
import UniqSet
import UniqSupply
import ErrUtils
import qualified Stream

import Control.Monad (ap)

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

type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (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 ty :: 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 W32  = LlvmType
LMFloat
widthToLlvmFloat W64  = LlvmType
LMDouble
widthToLlvmFloat W80  = LlvmType
LMFloat80
widthToLlvmFloat W128 = LlvmType
LMFloat128
widthToLlvmFloat w :: Width
w    = String -> LlvmType
forall a. String -> a
panic (String -> LlvmType) -> String -> LlvmType
forall a b. (a -> b) -> a -> b
$ "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 w :: 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 :: DynFlags -> LlvmCallConvention
llvmGhcCC :: DynFlags -> LlvmCallConvention
llvmGhcCC dflags :: DynFlags
dflags
 | Platform -> Bool
platformUnregisterised (DynFlags -> Platform
targetPlatform DynFlags
dflags) = LlvmCallConvention
CC_Ccc
 | Bool
otherwise                                      = LlvmCallConvention
CC_Ghc

-- | Llvm Function type for Cmm function
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
llvmFunTy live :: LiveGlobalRegs
live = LlvmType -> LlvmM LlvmType
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 "a") LlvmLinkageType
ExternallyVisible

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

llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig' :: LiveGlobalRegs
-> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig' live :: LiveGlobalRegs
live lbl :: LMString
lbl link :: LlvmLinkageType
link
  = do let toParams :: LlvmType -> (LlvmType, [LlvmParamAttr])
toParams x :: LlvmType
x | LlvmType -> Bool
isPointer LlvmType
x = (LlvmType
x, [LlvmParamAttr
NoAlias, LlvmParamAttr
NoCapture])
                      | Bool
otherwise   = (LlvmType
x, [])
       DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       LlvmFunctionDecl -> LlvmM LlvmFunctionDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmFunctionDecl -> LlvmM LlvmFunctionDecl)
-> LlvmFunctionDecl -> LlvmM LlvmFunctionDecl
forall a b. (a -> b) -> a -> b
$ LMString
-> LlvmLinkageType
-> LlvmCallConvention
-> LlvmType
-> LlvmParameterListType
-> [(LlvmType, [LlvmParamAttr])]
-> LMAlign
-> LlvmFunctionDecl
LlvmFunctionDecl LMString
lbl LlvmLinkageType
link (DynFlags -> LlvmCallConvention
llvmGhcCC DynFlags
dflags) LlvmType
LMVoid LlvmParameterListType
FixedArgs
                                 ((LlvmVar -> (LlvmType, [LlvmParamAttr]))
-> [LlvmVar] -> [(LlvmType, [LlvmParamAttr])]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmType -> (LlvmType, [LlvmParamAttr])
toParams (LlvmType -> (LlvmType, [LlvmParamAttr]))
-> (LlvmVar -> LlvmType) -> LlvmVar -> (LlvmType, [LlvmParamAttr])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVar -> LlvmType
getVarType) (DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs DynFlags
dflags LiveGlobalRegs
live))
                                 (DynFlags -> LMAlign
llvmFunAlign DynFlags
dflags)

-- | Alignment to use for functions
llvmFunAlign :: DynFlags -> LMAlign
llvmFunAlign :: DynFlags -> LMAlign
llvmFunAlign dflags :: DynFlags
dflags = Int -> LMAlign
forall a. a -> Maybe a
Just (DynFlags -> Int
wORD_SIZE DynFlags
dflags)

-- | Alignment to use for into tables
llvmInfAlign :: DynFlags -> LMAlign
llvmInfAlign :: DynFlags -> LMAlign
llvmInfAlign dflags :: DynFlags
dflags = Int -> LMAlign
forall a. a -> Maybe a
Just (DynFlags -> Int
wORD_SIZE DynFlags
dflags)

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

-- | A Function's arguments
llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs dflags :: DynFlags
dflags live :: LiveGlobalRegs
live =
    (GlobalReg -> LlvmVar) -> LiveGlobalRegs -> [LlvmVar]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> GlobalReg -> LlvmVar
lmGlobalRegArg DynFlags
dflags) ((GlobalReg -> Bool) -> LiveGlobalRegs -> LiveGlobalRegs
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalReg -> Bool
isPassed (Platform -> LiveGlobalRegs
activeStgRegs Platform
platform))
    where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
          isLive :: GlobalReg -> Bool
isLive r :: GlobalReg
r = Bool -> Bool
not (GlobalReg -> Bool
isSSE GlobalReg
r) Bool -> Bool -> Bool
|| GlobalReg
r GlobalReg -> LiveGlobalRegs -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LiveGlobalRegs
alwaysLive Bool -> Bool -> Bool
|| GlobalReg
r GlobalReg -> LiveGlobalRegs -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LiveGlobalRegs
live
          isPassed :: GlobalReg -> Bool
isPassed r :: GlobalReg
r = Bool -> Bool
not (GlobalReg -> Bool
isSSE GlobalReg
r) Bool -> Bool -> Bool
|| GlobalReg -> Bool
isLive GlobalReg
r
          isSSE :: GlobalReg -> Bool
isSSE (FloatReg _)  = Bool
True
          isSSE (DoubleReg _) = Bool
True
          isSSE (XmmReg _)    = Bool
True
          isSSE (YmmReg _)    = Bool
True
          isSSE (ZmmReg _)    = Bool
True
          isSSE _             = Bool
False

-- | 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 (\ty :: LlvmType
ty -> (LlvmType
ty, []))

-- | Pointer width
llvmPtrBits :: DynFlags -> Int
llvmPtrBits :: DynFlags -> Int
llvmPtrBits dflags :: DynFlags
dflags = 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
$ DynFlags -> CmmType
gcWord DynFlags
dflags

-- ----------------------------------------------------------------------------
-- * Llvm Version
--

-- | LLVM Version Number
data LlvmVersion
    = LlvmVersion Int
    | LlvmVersionOld Int Int
    deriving LlvmVersion -> LlvmVersion -> Bool
(LlvmVersion -> LlvmVersion -> Bool)
-> (LlvmVersion -> LlvmVersion -> Bool) -> Eq LlvmVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmVersion -> LlvmVersion -> Bool
$c/= :: LlvmVersion -> LlvmVersion -> Bool
== :: LlvmVersion -> LlvmVersion -> Bool
$c== :: LlvmVersion -> LlvmVersion -> Bool
Eq

-- Custom show instance for backwards compatibility.
instance Show LlvmVersion where
  show :: LlvmVersion -> String
show (LlvmVersion maj :: Int
maj) = Int -> String
forall a. Show a => a -> String
show Int
maj
  show (LlvmVersionOld maj :: Int
maj min :: Int
min) = Int -> String
forall a. Show a => a -> String
show Int
maj String -> String -> String
forall a. [a] -> [a] -> [a]
++ "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
min

-- | The LLVM Version that is currently supported.
supportedLlvmVersion :: LlvmVersion
supportedLlvmVersion :: LlvmVersion
supportedLlvmVersion = Int -> LlvmVersion
LlvmVersion sUPPORTED_LLVM_VERSION

llvmVersionStr :: LlvmVersion -> String
llvmVersionStr :: LlvmVersion -> String
llvmVersionStr v :: LlvmVersion
v =
  case LlvmVersion
v of
    LlvmVersion maj :: Int
maj -> Int -> String
forall a. Show a => a -> String
show Int
maj
    LlvmVersionOld maj :: Int
maj min :: Int
min -> Int -> String
forall a. Show a => a -> String
show Int
maj String -> String -> String
forall a. [a] -> [a] -> [a]
++ "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
min

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

data LlvmEnv = LlvmEnv
  { LlvmEnv -> LlvmVersion
envVersion :: LlvmVersion      -- ^ LLVM version
  , LlvmEnv -> DynFlags
envDynFlags :: DynFlags        -- ^ Dynamic flags
  , LlvmEnv -> BufHandle
envOutput :: BufHandle         -- ^ Output buffer
  , LlvmEnv -> UniqSupply
envUniq :: UniqSupply          -- ^ Supply of unique values
  , LlvmEnv -> MetaId
envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs
  , LlvmEnv -> UniqFM MetaId
envUniqMeta :: UniqFM 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 LlvmType

-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
newtype LlvmM a = LlvmM { LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }

instance Functor LlvmM where
    fmap :: (a -> b) -> LlvmM a -> LlvmM b
fmap f :: a -> b
f m :: LlvmM a
m = (LlvmEnv -> IO (b, LlvmEnv)) -> LlvmM b
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> IO (b, LlvmEnv)) -> LlvmM b)
-> (LlvmEnv -> IO (b, LlvmEnv)) -> LlvmM b
forall a b. (a -> b) -> a -> b
$ \env :: LlvmEnv
env -> do (x :: a
x, env' :: LlvmEnv
env') <- LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM LlvmM a
m LlvmEnv
env
                                  (b, LlvmEnv) -> IO (b, LlvmEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
x, LlvmEnv
env')

instance Applicative LlvmM where
    pure :: a -> LlvmM a
pure x :: a
x = (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
$ \env :: LlvmEnv
env -> (a, LlvmEnv) -> IO (a, LlvmEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, LlvmEnv
env)
    <*> :: LlvmM (a -> b) -> LlvmM a -> LlvmM b
(<*>) = LlvmM (a -> b) -> LlvmM a -> LlvmM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad LlvmM where
    m :: LlvmM a
m >>= :: LlvmM a -> (a -> LlvmM b) -> LlvmM b
>>= f :: a -> LlvmM b
f  = (LlvmEnv -> IO (b, LlvmEnv)) -> LlvmM b
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> IO (b, LlvmEnv)) -> LlvmM b)
-> (LlvmEnv -> IO (b, LlvmEnv)) -> LlvmM b
forall a b. (a -> b) -> a -> b
$ \env :: LlvmEnv
env -> do (x :: a
x, env' :: LlvmEnv
env') <- LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM LlvmM a
m LlvmEnv
env
                                  LlvmM b -> LlvmEnv -> IO (b, LlvmEnv)
forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM (a -> LlvmM b
f a
x) LlvmEnv
env'

instance HasDynFlags LlvmM where
    getDynFlags :: LlvmM DynFlags
getDynFlags = (LlvmEnv -> IO (DynFlags, LlvmEnv)) -> LlvmM DynFlags
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> IO (DynFlags, LlvmEnv)) -> LlvmM DynFlags)
-> (LlvmEnv -> IO (DynFlags, LlvmEnv)) -> LlvmM DynFlags
forall a b. (a -> b) -> a -> b
$ \env :: LlvmEnv
env -> (DynFlags, LlvmEnv) -> IO (DynFlags, LlvmEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> DynFlags
envDynFlags LlvmEnv
env, LlvmEnv
env)

instance MonadUnique LlvmM where
    getUniqueSupplyM :: LlvmM UniqSupply
getUniqueSupplyM = do
        UniqSupply
us <- (LlvmEnv -> UniqSupply) -> LlvmM UniqSupply
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> UniqSupply
envUniq
        let (us1 :: UniqSupply
us1, us2 :: UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us
        (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv (\s :: LlvmEnv
s -> LlvmEnv
s { envUniq :: UniqSupply
envUniq = UniqSupply
us2 })
        UniqSupply -> LlvmM UniqSupply
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us1

    getUniqueM :: LlvmM Unique
getUniqueM = do
        UniqSupply
us <- (LlvmEnv -> UniqSupply) -> LlvmM UniqSupply
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> UniqSupply
envUniq
        let (u :: Unique
u,us' :: UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us
        (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv (\s :: LlvmEnv
s -> LlvmEnv
s { envUniq :: UniqSupply
envUniq = UniqSupply
us' })
        Unique -> LlvmM Unique
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
u

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

-- | Get initial Llvm environment.
runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
runLlvm :: DynFlags
-> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
runLlvm dflags :: DynFlags
dflags ver :: LlvmVersion
ver out :: BufHandle
out us :: UniqSupply
us m :: LlvmM ()
m = do
    ((), LlvmEnv)
_ <- LlvmM () -> LlvmEnv -> IO ((), LlvmEnv)
forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM LlvmM ()
m LlvmEnv
env
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where env :: LlvmEnv
env = LlvmEnv :: LlvmVersion
-> DynFlags
-> BufHandle
-> UniqSupply
-> MetaId
-> UniqFM MetaId
-> LlvmEnvMap
-> UniqSet LMString
-> [LlvmVar]
-> LlvmEnvMap
-> LiveGlobalRegs
-> LlvmEnv
LlvmEnv { envFunMap :: LlvmEnvMap
envFunMap = LlvmEnvMap
forall elt. UniqFM elt
emptyUFM
                      , envVarMap :: LlvmEnvMap
envVarMap = LlvmEnvMap
forall elt. UniqFM elt
emptyUFM
                      , envStackRegs :: LiveGlobalRegs
envStackRegs = []
                      , envUsedVars :: [LlvmVar]
envUsedVars = []
                      , envAliases :: UniqSet LMString
envAliases = UniqSet LMString
forall a. UniqSet a
emptyUniqSet
                      , envVersion :: LlvmVersion
envVersion = LlvmVersion
ver
                      , envDynFlags :: DynFlags
envDynFlags = DynFlags
dflags
                      , envOutput :: BufHandle
envOutput = BufHandle
out
                      , envUniq :: UniqSupply
envUniq = UniqSupply
us
                      , envFreshMeta :: MetaId
envFreshMeta = Int -> MetaId
MetaId 0
                      , envUniqMeta :: UniqFM MetaId
envUniqMeta = UniqFM MetaId
forall elt. UniqFM elt
emptyUFM
                      }

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

-- | Lift a stream into the LlvmM monad
liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x
liftStream :: Stream IO a x -> Stream LlvmM a x
liftStream s :: Stream IO a x
s = LlvmM (Either x (a, Stream LlvmM a x)) -> Stream LlvmM a x
forall (m :: * -> *) a b.
m (Either b (a, Stream m a b)) -> Stream m a b
Stream.Stream (LlvmM (Either x (a, Stream LlvmM a x)) -> Stream LlvmM a x)
-> LlvmM (Either x (a, Stream LlvmM a x)) -> Stream LlvmM a x
forall a b. (a -> b) -> a -> b
$ do
  Either x (a, Stream IO a x)
r <- IO (Either x (a, Stream IO a x))
-> LlvmM (Either x (a, Stream IO a x))
forall a. IO a -> LlvmM a
liftIO (IO (Either x (a, Stream IO a x))
 -> LlvmM (Either x (a, Stream IO a x)))
-> IO (Either x (a, Stream IO a x))
-> LlvmM (Either x (a, Stream IO a x))
forall a b. (a -> b) -> a -> b
$ Stream IO a x -> IO (Either x (a, Stream IO a x))
forall (m :: * -> *) a b.
Stream m a b -> m (Either b (a, Stream m a b))
Stream.runStream Stream IO a x
s
  case Either x (a, Stream IO a x)
r of
    Left b :: x
b        -> Either x (a, Stream LlvmM a x)
-> LlvmM (Either x (a, Stream LlvmM a x))
forall (m :: * -> *) a. Monad m => a -> m a
return (x -> Either x (a, Stream LlvmM a x)
forall a b. a -> Either a b
Left x
b)
    Right (a :: a
a, r2 :: Stream IO a x
r2) -> Either x (a, Stream LlvmM a x)
-> LlvmM (Either x (a, Stream LlvmM a x))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Stream LlvmM a x) -> Either x (a, Stream LlvmM a x)
forall a b. b -> Either a b
Right (a
a, Stream IO a x -> Stream LlvmM a x
forall a x. Stream IO a x -> Stream LlvmM a x
liftStream Stream IO a x
r2))

-- | Clear variables from the environment for a subcomputation
withClearVars :: LlvmM a -> LlvmM a
withClearVars :: LlvmM a -> LlvmM a
withClearVars m :: 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
$ \env :: LlvmEnv
env -> do
    (x :: a
x, env' :: LlvmEnv
env') <- LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM LlvmM a
m LlvmEnv
env { envVarMap :: LlvmEnvMap
envVarMap = LlvmEnvMap
forall elt. UniqFM elt
emptyUFM, envStackRegs :: LiveGlobalRegs
envStackRegs = [] }
    (a, LlvmEnv) -> IO (a, LlvmEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, LlvmEnv
env' { envVarMap :: LlvmEnvMap
envVarMap = LlvmEnvMap
forall elt. UniqFM elt
emptyUFM, envStackRegs :: LiveGlobalRegs
envStackRegs = [] })

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

-- | Lookup variables or functions in the environment.
varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
varLookup :: key -> LlvmM (Maybe LlvmType)
varLookup s :: key
s = (LlvmEnv -> Maybe LlvmType) -> LlvmM (Maybe LlvmType)
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv ((LlvmEnvMap -> key -> Maybe LlvmType)
-> key -> LlvmEnvMap -> Maybe LlvmType
forall a b c. (a -> b -> c) -> b -> a -> c
flip LlvmEnvMap -> key -> Maybe LlvmType
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM key
s (LlvmEnvMap -> Maybe LlvmType)
-> (LlvmEnv -> LlvmEnvMap) -> LlvmEnv -> Maybe LlvmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmEnv -> LlvmEnvMap
envVarMap)
funLookup :: key -> LlvmM (Maybe LlvmType)
funLookup s :: key
s = (LlvmEnv -> Maybe LlvmType) -> LlvmM (Maybe LlvmType)
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv ((LlvmEnvMap -> key -> Maybe LlvmType)
-> key -> LlvmEnvMap -> Maybe LlvmType
forall a b c. (a -> b -> c) -> b -> a -> c
flip LlvmEnvMap -> key -> Maybe LlvmType
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM 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 r :: GlobalReg
r = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \env :: LlvmEnv
env -> LlvmEnv
env { envStackRegs :: LiveGlobalRegs
envStackRegs = GlobalReg
r GlobalReg -> LiveGlobalRegs -> LiveGlobalRegs
forall a. a -> [a] -> [a]
: LlvmEnv -> LiveGlobalRegs
envStackRegs LlvmEnv
env }

-- | Check whether a register is allocated on the stack
checkStackReg :: GlobalReg -> LlvmM Bool
checkStackReg :: GlobalReg -> LlvmM Bool
checkStackReg r :: GlobalReg
r = (LlvmEnv -> Bool) -> LlvmM Bool
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv ((GlobalReg -> LiveGlobalRegs -> 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
$ \env :: LlvmEnv
env ->
    (MetaId, LlvmEnv) -> IO (MetaId, LlvmEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> MetaId
envFreshMeta LlvmEnv
env, LlvmEnv
env { envFreshMeta :: MetaId
envFreshMeta = MetaId -> MetaId
forall a. Enum a => a -> a
succ (MetaId -> MetaId) -> MetaId -> MetaId
forall a b. (a -> b) -> a -> b
$ LlvmEnv -> MetaId
envFreshMeta LlvmEnv
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

-- | Get the platform we are generating code for
getDynFlag :: (DynFlags -> a) -> LlvmM a
getDynFlag :: (DynFlags -> a) -> LlvmM a
getDynFlag f :: DynFlags -> a
f = (LlvmEnv -> a) -> LlvmM a
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv (DynFlags -> a
f (DynFlags -> a) -> (LlvmEnv -> DynFlags) -> LlvmEnv -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmEnv -> DynFlags
envDynFlags)

-- | Get the platform we are generating code for
getLlvmPlatform :: LlvmM Platform
getLlvmPlatform :: LlvmM Platform
getLlvmPlatform = (DynFlags -> Platform) -> LlvmM Platform
forall a. (DynFlags -> a) -> LlvmM a
getDynFlag DynFlags -> Platform
targetPlatform

-- | Dumps the document if the corresponding flag has been set by the user
dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
dumpIfSetLlvm :: DumpFlag -> String -> SDoc -> LlvmM ()
dumpIfSetLlvm flag :: DumpFlag
flag hdr :: String
hdr doc :: SDoc
doc = do
  DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  IO () -> LlvmM ()
forall a. IO a -> LlvmM a
liftIO (IO () -> LlvmM ()) -> IO () -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
flag String
hdr SDoc
doc

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

    -- Write to output
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    BufHandle
out <- (LlvmEnv -> BufHandle) -> LlvmM BufHandle
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> BufHandle
envOutput
    IO () -> LlvmM ()
forall a. IO a -> LlvmM a
liftIO (IO () -> LlvmM ()) -> IO () -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> BufHandle -> PprStyle -> SDoc -> IO ()
Outp.bufLeftRenderSDoc DynFlags
dflags BufHandle
out
               (CodeStyle -> PprStyle
Outp.mkCodeStyle CodeStyle
Outp.CStyle) SDoc
sdoc

    -- Dump, if requested
    DumpFlag -> String -> SDoc -> LlvmM ()
dumpIfSetLlvm DumpFlag
Opt_D_dump_llvm "LLVM Code" SDoc
sdoc
    () -> LlvmM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Marks a variable as "used"
markUsedVar :: LlvmVar -> LlvmM ()
markUsedVar :: LlvmVar -> LlvmM ()
markUsedVar v :: LlvmVar
v = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \env :: LlvmEnv
env -> LlvmEnv
env { envUsedVars :: [LlvmVar]
envUsedVars = LlvmVar
v LlvmVar -> [LlvmVar] -> [LlvmVar]
forall a. a -> [a] -> [a]
: LlvmEnv -> [LlvmVar]
envUsedVars LlvmEnv
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 lbl :: LMString
lbl = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \env :: LlvmEnv
env -> LlvmEnv
env { envAliases :: UniqSet LMString
envAliases = UniqSet LMString -> LMString -> UniqSet LMString
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet (LlvmEnv -> UniqSet LMString
envAliases LlvmEnv
env) LMString
lbl }

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

-- | Gets metadata node for given unique
getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
getUniqMeta s :: Unique
s = (LlvmEnv -> Maybe MetaId) -> LlvmM (Maybe MetaId)
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv ((UniqFM MetaId -> Unique -> Maybe MetaId)
-> Unique -> UniqFM MetaId -> Maybe MetaId
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqFM MetaId -> Unique -> Maybe MetaId
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM Unique
s (UniqFM MetaId -> Maybe MetaId)
-> (LlvmEnv -> UniqFM MetaId) -> LlvmEnv -> Maybe MetaId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmEnv -> UniqFM 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 trac #5486.
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions = do
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk "memcpy" LlvmType
i8Ptr [LlvmType
i8Ptr, LlvmType
i8Ptr, DynFlags -> LlvmType
llvmWord DynFlags
dflags]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk "memmove" LlvmType
i8Ptr [LlvmType
i8Ptr, LlvmType
i8Ptr, DynFlags -> LlvmType
llvmWord DynFlags
dflags]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk "memset" LlvmType
i8Ptr [LlvmType
i8Ptr, DynFlags -> LlvmType
llvmWord DynFlags
dflags, DynFlags -> LlvmType
llvmWord DynFlags
dflags]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk "newSpark" (DynFlags -> LlvmType
llvmWord DynFlags
dflags) [LlvmType
i8Ptr, LlvmType
i8Ptr]
  where
    mk :: String -> LlvmType -> [LlvmType] -> LlvmM ()
mk n :: String
n ret :: LlvmType
ret args :: [LlvmType]
args = do
      let n' :: LMString
n' = String -> LMString
fsLit String
n LMString -> LMString -> LMString
`appendFS` String -> LMString
fsLit "$def"
          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
      SDoc -> LlvmM ()
renderLlvm (SDoc -> LlvmM ()) -> SDoc -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmFunctionDecl -> SDoc
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 lbl :: CLabel
lbl = do
    Platform
platform <- LlvmM Platform
getLlvmPlatform
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let sdoc :: SDoc
sdoc = Platform -> CLabel -> SDoc
pprCLabel Platform
platform CLabel
lbl
        str :: String
str = DynFlags -> SDoc -> PprStyle -> String
Outp.renderWithStyle DynFlags
dflags SDoc
sdoc (CodeStyle -> PprStyle
Outp.mkCodeStyle CodeStyle
Outp.CStyle)
    LMString -> LlvmM LMString
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> LMString
fsLit String
str)

strDisplayName_llvm :: CLabel -> LlvmM LMString
strDisplayName_llvm :: CLabel -> LlvmM LMString
strDisplayName_llvm lbl :: CLabel
lbl = do
    Platform
platform <- LlvmM Platform
getLlvmPlatform
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let sdoc :: SDoc
sdoc = Platform -> CLabel -> SDoc
pprCLabel Platform
platform CLabel
lbl
        depth :: Depth
depth = Int -> Depth
Outp.PartWay 1
        style :: PprStyle
style = DynFlags -> PrintUnqualified -> Depth -> PprStyle
Outp.mkUserStyle DynFlags
dflags PrintUnqualified
Outp.reallyAlwaysQualify Depth
depth
        str :: String
str = DynFlags -> SDoc -> PprStyle -> String
Outp.renderWithStyle DynFlags
dflags SDoc
sdoc PprStyle
style
    LMString -> LlvmM LMString
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> LMString
fsLit (String -> String
dropInfoSuffix String
str))

dropInfoSuffix :: String -> String
dropInfoSuffix :: String -> String
dropInfoSuffix = String -> String
go
  where go :: String -> String
go "_info"        = []
        go "_static_info" = []
        go "_con_info"    = []
        go (x :: Char
x:xs :: String
xs)         = Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String -> String
go String
xs
        go []             = []

strProcedureName_llvm :: CLabel -> LlvmM LMString
strProcedureName_llvm :: CLabel -> LlvmM LMString
strProcedureName_llvm lbl :: CLabel
lbl = do
    Platform
platform <- LlvmM Platform
getLlvmPlatform
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let sdoc :: SDoc
sdoc = Platform -> CLabel -> SDoc
pprCLabel Platform
platform CLabel
lbl
        depth :: Depth
depth = Int -> Depth
Outp.PartWay 1
        style :: PprStyle
style = DynFlags -> PrintUnqualified -> Depth -> PprStyle
Outp.mkUserStyle DynFlags
dflags PrintUnqualified
Outp.neverQualify Depth
depth
        str :: String
str = DynFlags -> SDoc -> PprStyle -> String
Outp.renderWithStyle DynFlags
dflags SDoc
sdoc PprStyle
style
    LMString -> LlvmM LMString
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> LMString
fsLit String
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 llvmLbl :: LMString
llvmLbl = do
  Maybe LlvmType
m_ty <- LMString -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
funLookup LMString
llvmLbl
  let mkGlbVar :: LMString -> LlvmType -> LMConst -> LlvmVar
mkGlbVar lbl :: LMString
lbl ty :: 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 Maybe LlvmType
m_ty of
    -- Directly reference if we have seen it already
    Just ty :: LlvmType
ty -> LlvmVar -> LlvmM LlvmVar
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 LMString -> LMString -> LMString
`appendFS` String -> LMString
fsLit "$def") LlvmType
ty LMConst
Global
    -- Otherwise use a forward alias of it
    Nothing -> do
      LMString -> LlvmM ()
saveAlias LMString
llvmLbl
      LlvmVar -> LlvmM LlvmVar
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

-- | 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
  [LMString]
delayed <- (UniqSet LMString -> [LMString])
-> LlvmM (UniqSet LMString) -> LlvmM [LMString]
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]
  [[LMGlobal]]
defss <- ((LMString -> LlvmM [LMGlobal])
 -> [LMString] -> LlvmM [[LMGlobal]])
-> [LMString]
-> (LMString -> LlvmM [LMGlobal])
-> LlvmM [[LMGlobal]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (LMString -> LlvmM [LMGlobal]) -> [LMString] -> LlvmM [[LMGlobal]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [LMString]
delayed ((LMString -> LlvmM [LMGlobal]) -> LlvmM [[LMGlobal]])
-> (LMString -> LlvmM [LMGlobal]) -> LlvmM [[LMGlobal]]
forall a b. (a -> b) -> a -> b
$ \lbl :: LMString
lbl -> do
    Maybe LlvmType
m_ty <- LMString -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
funLookup LMString
lbl
    case Maybe LlvmType
m_ty of
      -- If we have a definition we've already emitted the proper aliases
      -- when the symbol itself was emitted by @aliasify@
      Just _ -> [LMGlobal] -> LlvmM [LMGlobal]
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
      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 (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
  (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \env :: LlvmEnv
env -> LlvmEnv
env { envAliases :: UniqSet LMString
envAliases = UniqSet LMString
forall a. UniqSet a
emptyUniqSet }
  ([LMGlobal], [LlvmType]) -> LlvmM ([LMGlobal], [LlvmType])
forall (m :: * -> *) a. Monad m => a -> m a
return ([[LMGlobal]] -> [LMGlobal]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LMGlobal]]
defss, [])

-- | Here we take a global variable definition, rename it with a
-- @$def@ suffix, and generate the appropriate alias.
aliasify :: LMGlobal -> LlvmM [LMGlobal]
aliasify :: LMGlobal -> LlvmM [LMGlobal]
aliasify (LMGlobal var :: LlvmVar
var val :: Maybe LlvmStatic
val) = do
    let LMGlobalVar lbl :: LMString
lbl ty :: LlvmType
ty link :: LlvmLinkageType
link sect :: LMSection
sect align :: LMAlign
align const :: LMConst
const = LlvmVar
var

        defLbl :: LMString
defLbl = LMString
lbl LMString -> LMString -> LMString
`appendFS` String -> LMString
fsLit "$def"
        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 (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)
           ]

-- 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 trival. 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@.