{-# 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, llvmVersionSupported, parseLlvmVersion,
        llvmVersionStr, llvmVersionList,

        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)
import Data.Char (isDigit)
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NE

-- ----------------------------------------------------------------------------
-- * 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
--

-- Newtype to avoid using the Eq instance!
newtype LlvmVersion = LlvmVersion { LlvmVersion -> NonEmpty Int
llvmVersionNE :: NE.NonEmpty Int }

parseLlvmVersion :: String -> Maybe LlvmVersion
parseLlvmVersion :: String -> Maybe LlvmVersion
parseLlvmVersion =
    (NonEmpty Int -> LlvmVersion)
-> Maybe (NonEmpty Int) -> Maybe LlvmVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Int -> LlvmVersion
LlvmVersion (Maybe (NonEmpty Int) -> Maybe LlvmVersion)
-> (String -> Maybe (NonEmpty Int)) -> String -> Maybe LlvmVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Int] -> Maybe (NonEmpty Int))
-> (String -> [Int]) -> String -> Maybe (NonEmpty Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> String -> [Int]
forall a. Read a => [a] -> String -> [a]
go [] (String -> [Int]) -> (String -> String) -> String -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit)
  where
    go :: [a] -> String -> [a]
go vs :: [a]
vs s :: String
s
      | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ver_str
      = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
vs
      | '.' : rest' :: String
rest' <- String
rest
      = [a] -> String -> [a]
go (String -> a
forall a. Read a => String -> a
read String
ver_str a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
vs) String
rest'
      | Bool
otherwise
      = [a] -> [a]
forall a. [a] -> [a]
reverse (String -> a
forall a. Read a => String -> a
read String
ver_str a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
vs)
      where
        (ver_str :: String
ver_str, rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s

-- | The LLVM Version that is currently supported.
supportedLlvmVersion :: LlvmVersion
supportedLlvmVersion :: LlvmVersion
supportedLlvmVersion = NonEmpty Int -> LlvmVersion
LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| [])

llvmVersionSupported :: LlvmVersion -> Bool
llvmVersionSupported :: LlvmVersion -> Bool
llvmVersionSupported (LlvmVersion v :: NonEmpty Int
v) = NonEmpty Int -> Int
forall a. NonEmpty a -> a
NE.head NonEmpty Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== sUPPORTED_LLVM_VERSION

llvmVersionStr :: LlvmVersion -> String
llvmVersionStr :: LlvmVersion -> String
llvmVersionStr = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "." ([String] -> String)
-> (LlvmVersion -> [String]) -> LlvmVersion -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show ([Int] -> [String])
-> (LlvmVersion -> [Int]) -> LlvmVersion -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVersion -> [Int]
llvmVersionList

llvmVersionList :: LlvmVersion -> [Int]
llvmVersionList :: LlvmVersion -> [Int]
llvmVersionList = NonEmpty Int -> [Int]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Int -> [Int])
-> (LlvmVersion -> NonEmpty Int) -> LlvmVersion -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVersion -> NonEmpty Int
llvmVersionNE

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