{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}

-- ----------------------------------------------------------------------------
-- | 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, llvmDefLabel,

        padLiveArgs, isFPR
    ) where

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

import GhcPrelude

import Llvm
import LlvmCodeGen.Regs
import Panic

import PprCmm ()
import CLabel
import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
import DynFlags
import FastString
import Cmm              hiding ( succ )
import CmmUtils (regsOverlap)
import Outputable as Outp
import GHC.Platform
import UniqFM
import Unique
import BufWrite   ( BufHandle )
import UniqSet
import UniqSupply
import ErrUtils
import qualified Stream

import Data.Maybe (fromJust)
import Control.Monad (ap)
import Data.Char (isDigit)
import Data.List (sortBy, groupBy, intercalate)
import Data.Ord (comparing)
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 CmmType
ty | CmmType -> Bool
isVecType CmmType
ty   = Int -> LlvmType -> LlvmType
LMVector (CmmType -> Int
vecLength CmmType
ty) (CmmType -> LlvmType
cmmToLlvmType (CmmType -> CmmType
vecElemType CmmType
ty))
                 | CmmType -> Bool
isFloatType CmmType
ty = Width -> LlvmType
widthToLlvmFloat (Width -> LlvmType) -> Width -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth CmmType
ty
                 | Bool
otherwise      = Width -> LlvmType
widthToLlvmInt   (Width -> LlvmType) -> Width -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth CmmType
ty

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

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

-- | GHC Call Convention for LLVM
llvmGhcCC :: DynFlags -> LlvmCallConvention
llvmGhcCC :: DynFlags -> LlvmCallConvention
llvmGhcCC 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 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 String
"a") LlvmLinkageType
ExternallyVisible

-- | Llvm Function signature
llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig :: LiveGlobalRegs
-> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig LiveGlobalRegs
live CLabel
lbl LlvmLinkageType
link = do
  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' LiveGlobalRegs
live LMString
lbl LlvmLinkageType
link
  = do let toParams :: LlvmType -> (LlvmType, [LlvmParamAttr])
toParams LlvmType
x | LlvmType -> Bool
isPointer LlvmType
x = (LlvmType
x, [LlvmParamAttr
NoAlias, LlvmParamAttr
NoCapture])
                      | Bool
otherwise   = (LlvmType
x, [])
       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 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 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 DynFlags
dflags 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 String
".text.", LMString
lbl])
    | Bool
otherwise                     = LMSection
forall a. Maybe a
Nothing

-- | A Function's arguments
llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs DynFlags
dflags 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 LiveGlobalRegs
allRegs)
    where allRegs :: LiveGlobalRegs
allRegs = Platform -> LiveGlobalRegs
activeStgRegs (DynFlags -> Platform
targetPlatform DynFlags
dflags)
          paddingRegs :: LiveGlobalRegs
paddingRegs = DynFlags -> LiveGlobalRegs -> LiveGlobalRegs
padLiveArgs DynFlags
dflags LiveGlobalRegs
live
          isLive :: GlobalReg -> Bool
isLive GlobalReg
r = 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
                     Bool -> Bool -> Bool
|| GlobalReg
r GlobalReg -> LiveGlobalRegs -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LiveGlobalRegs
paddingRegs
          isPassed :: GlobalReg -> Bool
isPassed GlobalReg
r = Bool -> Bool
not (GlobalReg -> Bool
isFPR GlobalReg
r) Bool -> Bool -> Bool
|| GlobalReg -> Bool
isLive GlobalReg
r


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

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

    ----------------------------------
    -- handle floating-point registers (FPR)

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

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

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

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

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

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


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

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

-- | Pointer width
llvmPtrBits :: DynFlags -> Int
llvmPtrBits :: DynFlags -> Int
llvmPtrBits 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 [a]
vs 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
      | Char
'.' : 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
        (String
ver_str, 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 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] -> 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 -> Char
envMask :: !Char               -- ^ Mask for creating 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) }
    deriving (a -> LlvmM b -> LlvmM a
(a -> b) -> LlvmM a -> LlvmM b
(forall a b. (a -> b) -> LlvmM a -> LlvmM b)
-> (forall a b. a -> LlvmM b -> LlvmM a) -> Functor LlvmM
forall a b. a -> LlvmM b -> LlvmM a
forall a b. (a -> b) -> LlvmM a -> LlvmM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LlvmM b -> LlvmM a
$c<$ :: forall a b. a -> LlvmM b -> LlvmM a
fmap :: (a -> b) -> LlvmM a -> LlvmM b
$cfmap :: forall a b. (a -> b) -> LlvmM a -> LlvmM b
Functor)

instance Applicative LlvmM where
    pure :: a -> LlvmM a
pure 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
$ \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
    LlvmM a
m >>= :: LlvmM a -> (a -> LlvmM b) -> LlvmM b
>>= 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
$ \LlvmEnv
env -> do (a
x, 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
$ \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
        Char
mask <- (LlvmEnv -> Char) -> LlvmM Char
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> Char
envMask
        IO UniqSupply -> LlvmM UniqSupply
forall a. IO a -> LlvmM a
liftIO (IO UniqSupply -> LlvmM UniqSupply)
-> IO UniqSupply -> LlvmM UniqSupply
forall a b. (a -> b) -> a -> b
$! Char -> IO UniqSupply
mkSplitUniqSupply Char
mask

    getUniqueM :: LlvmM Unique
getUniqueM = do
        Char
mask <- (LlvmEnv -> Char) -> LlvmM Char
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> Char
envMask
        IO Unique -> LlvmM Unique
forall a. IO a -> LlvmM a
liftIO (IO Unique -> LlvmM Unique) -> IO Unique -> LlvmM Unique
forall a b. (a -> b) -> a -> b
$! Char -> IO Unique
uniqFromMask Char
mask

-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
liftIO :: IO a -> LlvmM a
liftIO :: IO a -> LlvmM a
liftIO IO a
m = (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a)
-> (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do 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 -> LlvmM a -> IO a
runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
runLlvm DynFlags
dflags LlvmVersion
ver BufHandle
out LlvmM a
m = do
    (a
a, LlvmEnv
_) <- LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM LlvmM a
m LlvmEnv
env
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  where env :: LlvmEnv
env = LlvmEnv :: LlvmVersion
-> DynFlags
-> BufHandle
-> Char
-> 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
                      , envMask :: Char
envMask = Char
'n'
                      , envFreshMeta :: MetaId
envFreshMeta = Int -> MetaId
MetaId Int
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 LlvmEnv -> a
f = (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM (\LlvmEnv
env -> (a, LlvmEnv) -> IO (a, LlvmEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> a
f LlvmEnv
env, LlvmEnv
env))

-- | Modify environment (internal)
modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv LlvmEnv -> LlvmEnv
f = (LlvmEnv -> IO ((), LlvmEnv)) -> LlvmM ()
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM (\LlvmEnv
env -> ((), LlvmEnv) -> IO ((), LlvmEnv)
forall (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 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 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, 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 LlvmM a
m = (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a)
-> (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do
    (a
x, 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 key
s LlvmType
t = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envVarMap :: 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 key
s LlvmType
t = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envFunMap :: 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 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 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 GlobalReg
r = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \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 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
$ \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 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 DumpFlag
flag String
hdr 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 = 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 String
"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 LlvmVar
v = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \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 LMString
lbl = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \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 Unique
f MetaId
m = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envUniqMeta :: 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 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 String
"memcpy" LlvmType
i8Ptr [LlvmType
i8Ptr, LlvmType
i8Ptr, DynFlags -> LlvmType
llvmWord DynFlags
dflags]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
"memmove" LlvmType
i8Ptr [LlvmType
i8Ptr, LlvmType
i8Ptr, DynFlags -> LlvmType
llvmWord DynFlags
dflags]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
"memset" LlvmType
i8Ptr [LlvmType
i8Ptr, DynFlags -> LlvmType
llvmWord DynFlags
dflags, DynFlags -> LlvmType
llvmWord DynFlags
dflags]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
"newSpark" (DynFlags -> LlvmType
llvmWord DynFlags
dflags) [LlvmType
i8Ptr, LlvmType
i8Ptr]
  where
    mk :: String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
n LlvmType
ret [LlvmType]
args = do
      let n' :: LMString
n' = LMString -> LMString
llvmDefLabel (LMString -> LMString) -> LMString -> LMString
forall a b. (a -> b) -> a -> b
$ String -> LMString
fsLit String
n
          decl :: LlvmFunctionDecl
decl = LMString
-> LlvmLinkageType
-> LlvmCallConvention
-> LlvmType
-> LlvmParameterListType
-> [(LlvmType, [LlvmParamAttr])]
-> LMAlign
-> LlvmFunctionDecl
LlvmFunctionDecl LMString
n' LlvmLinkageType
ExternallyVisible LlvmCallConvention
CC_Ccc LlvmType
ret
                                 LlvmParameterListType
FixedArgs ([LlvmType] -> [(LlvmType, [LlvmParamAttr])]
tysToParams [LlvmType]
args) LMAlign
forall a. Maybe a
Nothing
      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 CLabel
lbl = do
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let sdoc :: SDoc
sdoc = DynFlags -> CLabel -> SDoc
pprCLabel DynFlags
dflags 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 CLabel
lbl = do
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let sdoc :: SDoc
sdoc = DynFlags -> CLabel -> SDoc
pprCLabel DynFlags
dflags CLabel
lbl
        depth :: Depth
depth = Int -> Depth
Outp.PartWay Int
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 String
"_info"        = []
        go String
"_static_info" = []
        go String
"_con_info"    = []
        go (Char
x: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 CLabel
lbl = do
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let sdoc :: SDoc
sdoc = DynFlags -> CLabel -> SDoc
pprCLabel DynFlags
dflags CLabel
lbl
        depth :: Depth
depth = Int -> Depth
Outp.PartWay Int
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 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 LMString
lbl LlvmType
ty = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
lbl (LlvmType -> LlvmType
LMPointer LlvmType
ty) LlvmLinkageType
Private LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing
  case Maybe LlvmType
m_ty of
    -- Directly reference if we have seen it already
    Just 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 -> LMString
llvmDefLabel LMString
llvmLbl) LlvmType
ty LMConst
Global
    -- Otherwise use a forward alias of it
    Maybe LlvmType
Nothing -> do
      LMString -> LlvmM ()
saveAlias LMString
llvmLbl
      LlvmVar -> LlvmM LlvmVar
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar -> LlvmM LlvmVar) -> LlvmVar -> LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LMString -> LlvmType -> LMConst -> LlvmVar
mkGlbVar LMString
llvmLbl LlvmType
i8 LMConst
Alias

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

-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
--
-- Must be called at a point where we are sure that no new global definitions
-- will be generated anymore!
generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
generateExternDecls = do
  [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
$ \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 LlvmType
_ -> [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
      Maybe LlvmType
Nothing ->
        let var :: LlvmVar
var = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
lbl LlvmType
i8Ptr LlvmLinkageType
External LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Global
        in [LMGlobal] -> LlvmM [LMGlobal]
forall (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
$ \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]
-- See note [emit-time elimination of static indirections] in CLabel.
-- Here we obtain the indirectee's precise type and introduce
-- fresh aliases to both the precise typed label (lbl$def) and the i8*
-- typed (regular) label of it with the matching new names.
aliasify :: LMGlobal -> LlvmM [LMGlobal]
aliasify (LMGlobal (LMGlobalVar LMString
lbl ty :: LlvmType
ty@LMAlias{} LlvmLinkageType
link LMSection
sect LMAlign
align LMConst
Alias)
                   (Just LlvmStatic
orig)) = do
    let defLbl :: LMString
defLbl = LMString -> LMString
llvmDefLabel LMString
lbl
        LMStaticPointer (LMGlobalVar LMString
origLbl LlvmType
_ LlvmLinkageType
oLnk LMSection
Nothing LMAlign
Nothing LMConst
Alias) = LlvmStatic
orig
        defOrigLbl :: LMString
defOrigLbl = LMString -> LMString
llvmDefLabel LMString
origLbl
        orig' :: LlvmStatic
orig' = LlvmVar -> LlvmStatic
LMStaticPointer (LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
origLbl LlvmType
i8Ptr LlvmLinkageType
oLnk LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Alias)
    Maybe LlvmType
origType <- LMString -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
funLookup LMString
origLbl
    let defOrig :: LlvmStatic
defOrig = LlvmStatic -> LlvmType -> LlvmStatic
LMBitc (LlvmVar -> LlvmStatic
LMStaticPointer (LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
defOrigLbl
                                           (LlvmType -> LlvmType
pLift (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ Maybe LlvmType -> LlvmType
forall a. HasCallStack => Maybe a -> a
fromJust Maybe LlvmType
origType) LlvmLinkageType
oLnk
                                           LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Alias))
                         (LlvmType -> LlvmType
pLift LlvmType
ty)
    [LMGlobal] -> LlvmM [LMGlobal]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal (LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
defLbl LlvmType
ty LlvmLinkageType
link LMSection
sect LMAlign
align LMConst
Alias) (LlvmStatic -> Maybe LlvmStatic
forall a. a -> Maybe a
Just LlvmStatic
defOrig)
         , LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal (LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
lbl LlvmType
i8Ptr LlvmLinkageType
link LMSection
sect LMAlign
align LMConst
Alias) (LlvmStatic -> Maybe LlvmStatic
forall a. a -> Maybe a
Just LlvmStatic
orig')
         ]
aliasify (LMGlobal LlvmVar
var Maybe LlvmStatic
val) = do
    let LMGlobalVar LMString
lbl LlvmType
ty LlvmLinkageType
link LMSection
sect LMAlign
align LMConst
const = LlvmVar
var

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

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

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

    [LMGlobal] -> LlvmM [LMGlobal]
forall (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@.