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

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

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

module GHC.CmmToLlvm.Base (

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

        LlvmVersion, llvmVersionSupported, parseLlvmVersion,
        supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound,
        llvmVersionStr, llvmVersionList,

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

        getMetaUniqueId,
        setUniqMeta, getUniqMeta,

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

        strCLabel_llvm,
        getGlobalPtr, generateExternDecls,

        aliasify, llvmDefLabel
    ) where

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

import GHC.Prelude
import GHC.Utils.Panic

import GHC.Llvm
import GHC.CmmToLlvm.Regs

import GHC.Cmm.CLabel
import GHC.Cmm.Ppr.Expr ()
import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Cmm              hiding ( succ )
import GHC.Cmm.Utils (regsOverlap)
import GHC.Utils.Outputable as Outp
import GHC.Platform
import GHC.Types.Unique.FM
import GHC.Types.Unique
import GHC.Utils.BufHandle   ( BufHandle )
import GHC.Types.Unique.Set
import GHC.Types.Unique.Supply
import GHC.Utils.Error
import qualified GHC.Data.Stream as 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 RawCmmStatics) (ListGraph LlvmStatement)
type LlvmBasicBlock = GenBasicBlock LlvmStatement

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

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

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

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

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

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

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

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

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

-- | Llvm Function type for Cmm function
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
llvmFunTy LiveGlobalRegs
live = LlvmType -> LlvmM LlvmType
forall (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, [])
       Platform
platform <- LlvmM Platform
getPlatform
       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 (Platform -> LlvmCallConvention
llvmGhcCC Platform
platform) 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) (Platform -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs Platform
platform LiveGlobalRegs
live))
                                 (Platform -> LMAlign
llvmFunAlign Platform
platform)

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

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

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

-- | A Function's arguments
llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs Platform
platform LiveGlobalRegs
live =
    (GlobalReg -> LlvmVar) -> LiveGlobalRegs -> [LlvmVar]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> GlobalReg -> LlvmVar
lmGlobalRegArg Platform
platform) ((GlobalReg -> Bool) -> LiveGlobalRegs -> LiveGlobalRegs
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalReg -> Bool
isPassed LiveGlobalRegs
allRegs)
    where allRegs :: LiveGlobalRegs
allRegs = Platform -> LiveGlobalRegs
activeStgRegs Platform
platform
          paddingRegs :: LiveGlobalRegs
paddingRegs = Platform -> LiveGlobalRegs -> LiveGlobalRegs
padLiveArgs Platform
platform LiveGlobalRegs
live
          isLive :: GlobalReg -> Bool
isLive GlobalReg
r = GlobalReg
r GlobalReg -> LiveGlobalRegs -> Bool
forall (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 :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
padLiveArgs Platform
platform LiveGlobalRegs
live =
      if Platform -> Bool
platformUnregisterised Platform
platform
        then [] -- not using GHC's register convention for platform.
        else LiveGlobalRegs
padded
  where
    ----------------------------------
    -- handle floating-point registers (FPR)

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

    -- we group live registers sharing the same classes, i.e. that use the same
    -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg
    -- all use the same real regs on X86-64 (XMM registers).
    --
    classes :: [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 = Platform -> CmmReg -> CmmReg -> Bool
regsOverlap Platform
platform (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 :: Platform -> Int
llvmPtrBits :: Platform -> Int
llvmPtrBits Platform
platform = Width -> Int
widthInBits (Width -> Int) -> Width -> Int
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth (CmmType -> Width) -> CmmType -> Width
forall a b. (a -> b) -> a -> b
$ Platform -> CmmType
gcWord Platform
platform

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

newtype LlvmVersion = LlvmVersion { LlvmVersion -> NonEmpty Int
llvmVersionNE :: NE.NonEmpty Int }
  deriving (LlvmVersion -> LlvmVersion -> Bool
(LlvmVersion -> LlvmVersion -> Bool)
-> (LlvmVersion -> LlvmVersion -> Bool) -> Eq LlvmVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmVersion -> LlvmVersion -> Bool
$c/= :: LlvmVersion -> LlvmVersion -> Bool
== :: LlvmVersion -> LlvmVersion -> Bool
$c== :: LlvmVersion -> LlvmVersion -> Bool
Eq, Eq LlvmVersion
Eq LlvmVersion
-> (LlvmVersion -> LlvmVersion -> Ordering)
-> (LlvmVersion -> LlvmVersion -> Bool)
-> (LlvmVersion -> LlvmVersion -> Bool)
-> (LlvmVersion -> LlvmVersion -> Bool)
-> (LlvmVersion -> LlvmVersion -> Bool)
-> (LlvmVersion -> LlvmVersion -> LlvmVersion)
-> (LlvmVersion -> LlvmVersion -> LlvmVersion)
-> Ord LlvmVersion
LlvmVersion -> LlvmVersion -> Bool
LlvmVersion -> LlvmVersion -> Ordering
LlvmVersion -> LlvmVersion -> LlvmVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LlvmVersion -> LlvmVersion -> LlvmVersion
$cmin :: LlvmVersion -> LlvmVersion -> LlvmVersion
max :: LlvmVersion -> LlvmVersion -> LlvmVersion
$cmax :: LlvmVersion -> LlvmVersion -> LlvmVersion
>= :: LlvmVersion -> LlvmVersion -> Bool
$c>= :: LlvmVersion -> LlvmVersion -> Bool
> :: LlvmVersion -> LlvmVersion -> Bool
$c> :: LlvmVersion -> LlvmVersion -> Bool
<= :: LlvmVersion -> LlvmVersion -> Bool
$c<= :: LlvmVersion -> LlvmVersion -> Bool
< :: LlvmVersion -> LlvmVersion -> Bool
$c< :: LlvmVersion -> LlvmVersion -> Bool
compare :: LlvmVersion -> LlvmVersion -> Ordering
$ccompare :: LlvmVersion -> LlvmVersion -> Ordering
Ord)

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 (inclusive) lower bound on the LLVM Version that is currently supported.
supportedLlvmVersionLowerBound :: LlvmVersion
supportedLlvmVersionLowerBound :: LlvmVersion
supportedLlvmVersionLowerBound = NonEmpty Int -> LlvmVersion
LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])

-- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.
supportedLlvmVersionUpperBound :: LlvmVersion
supportedLlvmVersionUpperBound :: LlvmVersion
supportedLlvmVersionUpperBound = NonEmpty Int -> LlvmVersion
LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])

llvmVersionSupported :: LlvmVersion -> Bool
llvmVersionSupported :: LlvmVersion -> Bool
llvmVersionSupported LlvmVersion
v =
  LlvmVersion
v LlvmVersion -> LlvmVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= LlvmVersion
supportedLlvmVersionLowerBound Bool -> Bool -> Bool
&& LlvmVersion
v LlvmVersion -> LlvmVersion -> Bool
forall a. Ord a => a -> a -> Bool
< LlvmVersion
supportedLlvmVersionUpperBound

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 -> LlvmOpts
envOpts    :: LlvmOpts         -- ^ LLVM backend options
  , 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 Unique MetaId
envUniqMeta :: UniqFM Unique MetaId   -- ^ Global metadata nodes
  , LlvmEnv -> LlvmEnvMap
envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type
  , LlvmEnv -> UniqSet LMString
envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
  , LlvmEnv -> [LlvmVar]
envUsedVars :: [LlvmVar]       -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)

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

type LlvmEnvMap = UniqFM Unique LlvmType

-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
newtype LlvmM a = LlvmM { forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
    deriving ((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
<$ :: forall a b. a -> LlvmM b -> LlvmM a
$c<$ :: forall a b. a -> LlvmM b -> LlvmM a
fmap :: forall a b. (a -> b) -> LlvmM a -> LlvmM b
$cfmap :: forall a b. (a -> b) -> LlvmM a -> LlvmM b
Functor)

instance Applicative LlvmM where
    pure :: forall a. 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)
    <*> :: forall a b. 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 >>= :: forall a b. 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)

-- | Get target platform
getPlatform :: LlvmM Platform
getPlatform :: LlvmM Platform
getPlatform = LlvmOpts -> Platform
llvmOptsPlatform (LlvmOpts -> Platform) -> LlvmM LlvmOpts -> LlvmM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LlvmM LlvmOpts
getLlvmOpts

-- | Get LLVM options
getLlvmOpts :: LlvmM LlvmOpts
getLlvmOpts :: LlvmM LlvmOpts
getLlvmOpts = (LlvmEnv -> IO (LlvmOpts, LlvmEnv)) -> LlvmM LlvmOpts
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> IO (LlvmOpts, LlvmEnv)) -> LlvmM LlvmOpts)
-> (LlvmEnv -> IO (LlvmOpts, LlvmEnv)) -> LlvmM LlvmOpts
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> (LlvmOpts, LlvmEnv) -> IO (LlvmOpts, LlvmEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> LlvmOpts
envOpts 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 :: forall a. IO a -> LlvmM a
liftIO IO a
m = (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a)
-> (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do 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 :: forall a. 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
-> LlvmOpts
-> DynFlags
-> BufHandle
-> Char
-> MetaId
-> UniqFM Unique MetaId
-> LlvmEnvMap
-> UniqSet LMString
-> [LlvmVar]
-> LlvmEnvMap
-> LiveGlobalRegs
-> LlvmEnv
LlvmEnv { envFunMap :: LlvmEnvMap
envFunMap = LlvmEnvMap
forall key elt. UniqFM key elt
emptyUFM
                      , envVarMap :: LlvmEnvMap
envVarMap = LlvmEnvMap
forall key elt. UniqFM key elt
emptyUFM
                      , envStackRegs :: LiveGlobalRegs
envStackRegs = []
                      , envUsedVars :: [LlvmVar]
envUsedVars = []
                      , envAliases :: UniqSet LMString
envAliases = UniqSet LMString
forall a. UniqSet a
emptyUniqSet
                      , envVersion :: LlvmVersion
envVersion = LlvmVersion
ver
                      , envOpts :: LlvmOpts
envOpts = DynFlags -> LlvmOpts
initLlvmOpts DynFlags
dflags
                      , 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 Unique MetaId
envUniqMeta = UniqFM Unique MetaId
forall key elt. UniqFM key elt
emptyUFM
                      }

-- | Get environment (internal)
getEnv :: (LlvmEnv -> a) -> LlvmM a
getEnv :: forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> a
f = (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM (\LlvmEnv
env -> (a, LlvmEnv) -> IO (a, LlvmEnv)
forall (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 :: forall a x. 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 :: forall a. LlvmM a -> LlvmM a
withClearVars LlvmM a
m = (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a)
-> (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do
    (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 key elt. UniqFM key 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 key elt. UniqFM key elt
emptyUFM, envStackRegs :: LiveGlobalRegs
envStackRegs = [] })

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

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

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

-- | Dumps the document if the corresponding flag has been set by the user
dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> SDoc -> LlvmM ()
dumpIfSetLlvm DumpFlag
flag String
hdr DumpFormat
fmt SDoc
doc = do
  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 -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
flag String
hdr DumpFormat
fmt 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
    let ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (CodeStyle -> PprStyle
Outp.mkCodeStyle CodeStyle
Outp.CStyle)
    IO () -> LlvmM ()
forall a. IO a -> LlvmM a
liftIO (IO () -> LlvmM ()) -> IO () -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ SDocContext -> BufHandle -> SDoc -> IO ()
Outp.bufLeftRenderSDoc SDocContext
ctx BufHandle
out SDoc
sdoc

    -- Dump, if requested
    DumpFlag -> String -> DumpFormat -> SDoc -> LlvmM ()
dumpIfSetLlvm DumpFlag
Opt_D_dump_llvm String
"LLVM Code" DumpFormat
FormatLLVM 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 Unique MetaId
envUniqMeta = UniqFM Unique MetaId -> Unique -> MetaId -> UniqFM Unique MetaId
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (LlvmEnv -> UniqFM Unique 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 Unique MetaId -> Unique -> Maybe MetaId)
-> Unique -> UniqFM Unique MetaId -> Maybe MetaId
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqFM Unique MetaId -> Unique -> Maybe MetaId
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM Unique
s (UniqFM Unique MetaId -> Maybe MetaId)
-> (LlvmEnv -> UniqFM Unique MetaId) -> LlvmEnv -> Maybe MetaId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmEnv -> UniqFM Unique MetaId
envUniqMeta)

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

-- | Here we pre-initialise some functions that are used internally by GHC
-- so as to make sure they have the most general type in the case that
-- user code also uses these functions but with a different type than GHC
-- internally. (Main offender is treating return type as 'void' instead of
-- 'void *'). Fixes trac #5486.
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions = do
    Platform
platform <- LlvmM Platform
getPlatform
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let w :: LlvmType
w = Platform -> LlvmType
llvmWord Platform
platform
        cint :: LlvmType
cint = Int -> LlvmType
LMInt (Int -> LlvmType) -> Int -> LlvmType
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits (Width -> Int) -> Width -> Int
forall a b. (a -> b) -> a -> b
$ DynFlags -> Width
cIntWidth DynFlags
dflags
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
"memcmp" LlvmType
cint [LlvmType
i8Ptr, LlvmType
i8Ptr, LlvmType
w]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
"memcpy" LlvmType
i8Ptr [LlvmType
i8Ptr, LlvmType
i8Ptr, LlvmType
w]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
"memmove" LlvmType
i8Ptr [LlvmType
i8Ptr, LlvmType
i8Ptr, LlvmType
w]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
"memset" LlvmType
i8Ptr [LlvmType
i8Ptr, LlvmType
w, LlvmType
w]
    String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
"newSpark" LlvmType
w [LlvmType
i8Ptr, LlvmType
i8Ptr]
  where
    mk :: String -> LlvmType -> [LlvmType] -> LlvmM ()
mk String
n LlvmType
ret [LlvmType]
args = do
      let n' :: LMString
n' = String -> LMString
fsLit String
n
          decl :: LlvmFunctionDecl
decl = LMString
-> LlvmLinkageType
-> LlvmCallConvention
-> LlvmType
-> LlvmParameterListType
-> [(LlvmType, [LlvmParamAttr])]
-> LMAlign
-> LlvmFunctionDecl
LlvmFunctionDecl LMString
n' LlvmLinkageType
ExternallyVisible LlvmCallConvention
CC_Ccc LlvmType
ret
                                 LlvmParameterListType
FixedArgs ([LlvmType] -> [(LlvmType, [LlvmParamAttr])]
tysToParams [LlvmType]
args) LMAlign
forall a. Maybe a
Nothing
      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 = SDocContext -> SDoc -> String
Outp.renderWithStyle
                  (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (CodeStyle -> PprStyle
Outp.mkCodeStyle CodeStyle
Outp.CStyle))
                  SDoc
sdoc
    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 -> do
      if LMString
llvmLbl LMString -> [LMString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((String -> LMString) -> [String] -> [LMString]
forall a b. (a -> b) -> [a] -> [b]
map String -> LMString
fsLit [String
"newSpark", String
"memmove", String
"memcpy", String
"memcmp", String
"memset"])
        then LlvmVar -> LlvmM LlvmVar
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar -> LlvmM LlvmVar) -> LlvmVar -> LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LMString -> LlvmType -> LMConst -> LlvmVar
mkGlbVar (LMString
llvmLbl) LlvmType
ty LMConst
Global
        else LlvmVar -> LlvmM LlvmVar
forall (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 "GHC.Cmm.CLabel".
-- Here we obtain the indirectee's precise type and introduce
-- fresh aliases to both the precise typed label (lbl$def) and the i8*
-- typed (regular) label of it with the matching new names.
aliasify :: LMGlobal -> LlvmM [LMGlobal]
aliasify (LMGlobal (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 trivial. As we already have a definition for
-- and therefore know the type of the referenced symbol, we can do
-- away with casting the alias to the desired type in @getSymbolPtr@
-- and instead just emit a reference to the definition symbol directly.
-- This is the @Just@ case in @getSymbolPtr@.