{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CmmToLlvm.Base (
LlvmCmmDecl, LlvmBasicBlock,
LiveGlobalRegs,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
LlvmVersion, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound,
llvmVersionSupported, parseLlvmVersion,
llvmVersionStr, llvmVersionList,
LlvmM,
runLlvm, withClearVars, varLookup, varInsert,
markStackReg, checkStackReg,
funLookup, funInsert, getLlvmVer,
dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
ghcInternalFunctions, getPlatform, getConfig,
getMetaUniqueId,
setUniqMeta, getUniqMeta, liftIO,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,
strCLabel_llvm,
getGlobalPtr, generateExternDecls,
aliasify, llvmDefLabel
) where
#include "ghc-llvm-version.h"
import GHC.Prelude
import GHC.Utils.Panic
import GHC.Llvm
import GHC.CmmToLlvm.Regs
import GHC.CmmToLlvm.Config
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.Logger
import Data.Maybe (fromJust)
import Control.Monad (ap)
import Data.Char (isDigit)
import Data.List (sortBy, groupBy, intercalate, isPrefixOf)
import Data.Ord (comparing)
import qualified Data.List.NonEmpty as NE
type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement)
type LlvmBasicBlock = GenBasicBlock LlvmStatement
type LiveGlobalRegs = [GlobalReg]
type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
type LlvmData = ([LMGlobal], [LlvmType])
type UnresLabel = CmmLit
type UnresStatic = Either UnresLabel LlvmStatic
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 forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth CmmType
ty
| Bool
otherwise = Width -> LlvmType
widthToLlvmInt forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth CmmType
ty
widthToLlvmFloat :: Width -> LlvmType
widthToLlvmFloat :: Width -> LlvmType
widthToLlvmFloat Width
W32 = LlvmType
LMFloat
widthToLlvmFloat Width
W64 = LlvmType
LMDouble
widthToLlvmFloat Width
W128 = LlvmType
LMFloat128
widthToLlvmFloat Width
w = forall a. String -> a
panic forall a b. (a -> b) -> a -> b
$ String
"widthToLlvmFloat: Bad float size: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Width
w
widthToLlvmInt :: Width -> LlvmType
widthToLlvmInt :: Width -> LlvmType
widthToLlvmInt Width
w = Int -> LlvmType
LMInt forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits Width
w
llvmGhcCC :: Platform -> LlvmCallConvention
llvmGhcCC :: Platform -> LlvmCallConvention
llvmGhcCC Platform
platform
| Platform -> Bool
platformUnregisterised Platform
platform = LlvmCallConvention
CC_Ccc
| Bool
otherwise = LlvmCallConvention
CC_Ghc
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
llvmFunTy LiveGlobalRegs
live = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmFunctionDecl -> LlvmType
LMFunction 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
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
forall (m :: * -> *) a. Monad m => a -> m a
return 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
(forall a b. (a -> b) -> [a] -> [b]
map (LlvmType -> (LlvmType, [LlvmParamAttr])
toParams 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)
llvmFunAlign :: Platform -> LMAlign
llvmFunAlign :: Platform -> LMAlign
llvmFunAlign Platform
platform = forall a. a -> Maybe a
Just (Platform -> Int
platformWordSizeInBytes Platform
platform)
llvmInfAlign :: Platform -> LMAlign
llvmInfAlign :: Platform -> LMAlign
llvmInfAlign Platform
platform = forall a. a -> Maybe a
Just (Platform -> Int
platformWordSizeInBytes Platform
platform)
llvmFunSection :: LlvmCgConfig -> LMString -> LMSection
llvmFunSection :: LlvmCgConfig -> LMString -> LMSection
llvmFunSection LlvmCgConfig
opts LMString
lbl
| LlvmCgConfig -> Bool
llvmCgSplitSection LlvmCgConfig
opts = forall a. a -> Maybe a
Just ([LMString] -> LMString
concatFS [String -> LMString
fsLit String
".text.", LMString
lbl])
| Bool
otherwise = forall a. Maybe a
Nothing
llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs Platform
platform LiveGlobalRegs
live =
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> GlobalReg -> LlvmVar
lmGlobalRegArg Platform
platform) (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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LiveGlobalRegs
alwaysLive
Bool -> Bool -> Bool
|| GlobalReg
r forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LiveGlobalRegs
live
Bool -> Bool -> Bool
|| GlobalReg
r 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
padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
padLiveArgs Platform
platform LiveGlobalRegs
live =
if Platform -> Bool
platformUnregisterised Platform
platform
then []
else LiveGlobalRegs
padded
where
fprLive :: LiveGlobalRegs
fprLive = forall a. (a -> Bool) -> [a] -> [a]
filter GlobalReg -> Bool
isFPR LiveGlobalRegs
live
classes :: [LiveGlobalRegs]
classes = 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)
norm :: GlobalReg -> CmmReg
norm GlobalReg
x = GlobalReg -> CmmReg
CmmGlobal ((GlobalReg -> Int -> GlobalReg
fpr_ctor GlobalReg
x) Int
1)
padded :: LiveGlobalRegs
padded = 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 = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing GlobalReg -> Int
fpr_num) LiveGlobalRegs
rs
maxr :: GlobalReg
maxr = 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]
_
| GlobalReg -> Int
fpr_num GlobalReg
c1 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
= forall a. String -> SDoc -> a
sorryDoc String
"LLVM code generator" forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Found two different Cmm registers (" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr GlobalReg
c1 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"," SDoc -> SDoc -> 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
<> 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 forall a. Eq a => a -> a -> Bool
== Int
f = LiveGlobalRegs -> [Int] -> LiveGlobalRegs
go LiveGlobalRegs
cs [Int]
fs
| Bool
otherwise = Int -> GlobalReg
ctor Int
f forall a. a -> [a] -> [a]
: LiveGlobalRegs -> [Int] -> LiveGlobalRegs
go (GlobalReg
cforall a. a -> [a] -> [a]
:LiveGlobalRegs
cs) [Int]
fs
go LiveGlobalRegs
_ [Int]
_ = forall a. HasCallStack => a
undefined
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
_ = 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
_ = forall a. HasCallStack => String -> a
error String
"fpr_num expected only FPR regs"
llvmStdFunAttrs :: [LlvmFuncAttr]
llvmStdFunAttrs :: [LlvmFuncAttr]
llvmStdFunAttrs = [LlvmFuncAttr
NoUnwind]
tysToParams :: [LlvmType] -> [LlvmParameter]
tysToParams :: [LlvmType] -> [(LlvmType, [LlvmParamAttr])]
tysToParams = forall a b. (a -> b) -> [a] -> [b]
map (\LlvmType
ty -> (LlvmType
ty, []))
llvmPtrBits :: Platform -> Int
llvmPtrBits :: Platform -> Int
llvmPtrBits Platform
platform = Width -> Int
widthInBits forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth forall a b. (a -> b) -> a -> b
$ Platform -> CmmType
gcWord Platform
platform
parseLlvmVersion :: String -> Maybe LlvmVersion
parseLlvmVersion :: String -> Maybe LlvmVersion
parseLlvmVersion =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Int -> LlvmVersion
LlvmVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Read a => [a] -> String -> [a]
go [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit)
where
go :: [a] -> String -> [a]
go [a]
vs String
s
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ver_str
= forall a. [a] -> [a]
reverse [a]
vs
| Char
'.' : String
rest' <- String
rest
= [a] -> String -> [a]
go (forall a. Read a => String -> a
read String
ver_str forall a. a -> [a] -> [a]
: [a]
vs) String
rest'
| Bool
otherwise
= forall a. [a] -> [a]
reverse (forall a. Read a => String -> a
read String
ver_str forall a. a -> [a] -> [a]
: [a]
vs)
where
(String
ver_str, String
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s
supportedLlvmVersionLowerBound :: LlvmVersion
supportedLlvmVersionLowerBound :: LlvmVersion
supportedLlvmVersionLowerBound = NonEmpty Int -> LlvmVersion
LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])
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 forall a. Ord a => a -> a -> Bool
>= LlvmVersion
supportedLlvmVersionLowerBound Bool -> Bool -> Bool
&& LlvmVersion
v forall a. Ord a => a -> a -> Bool
< LlvmVersion
supportedLlvmVersionUpperBound
llvmVersionStr :: LlvmVersion -> String
llvmVersionStr :: LlvmVersion -> String
llvmVersionStr = forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVersion -> [Int]
llvmVersionList
llvmVersionList :: LlvmVersion -> [Int]
llvmVersionList :: LlvmVersion -> [Int]
llvmVersionList = forall a. NonEmpty a -> [a]
NE.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVersion -> NonEmpty Int
llvmVersionNE
data LlvmEnv = LlvmEnv
{ LlvmEnv -> LlvmVersion
envVersion :: LlvmVersion
, LlvmEnv -> LlvmCgConfig
envConfig :: !LlvmCgConfig
, LlvmEnv -> Logger
envLogger :: !Logger
, LlvmEnv -> BufHandle
envOutput :: BufHandle
, LlvmEnv -> Char
envMask :: !Char
, LlvmEnv -> MetaId
envFreshMeta :: MetaId
, LlvmEnv -> UniqFM Unique MetaId
envUniqMeta :: UniqFM Unique MetaId
, LlvmEnv -> LlvmEnvMap
envFunMap :: LlvmEnvMap
, LlvmEnv -> UniqSet LMString
envAliases :: UniqSet LMString
, LlvmEnv -> [LlvmVar]
envUsedVars :: [LlvmVar]
, LlvmEnv -> LlvmEnvMap
envVarMap :: LlvmEnvMap
, LlvmEnv -> LiveGlobalRegs
envStackRegs :: [GlobalReg]
}
type LlvmEnvMap = UniqFM Unique LlvmType
newtype LlvmM a = LlvmM { forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
deriving (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 = forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, LlvmEnv
env)
<*> :: forall a 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 = forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do (a
x, LlvmEnv
env') <- forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM LlvmM a
m LlvmEnv
env
forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM (a -> LlvmM b
f a
x) LlvmEnv
env'
instance HasLogger LlvmM where
getLogger :: LlvmM Logger
getLogger = forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> Logger
envLogger LlvmEnv
env, LlvmEnv
env)
getPlatform :: LlvmM Platform
getPlatform :: LlvmM Platform
getPlatform = LlvmCgConfig -> Platform
llvmCgPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LlvmM LlvmCgConfig
getConfig
getConfig :: LlvmM LlvmCgConfig
getConfig :: LlvmM LlvmCgConfig
getConfig = forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> LlvmCgConfig
envConfig LlvmEnv
env, LlvmEnv
env)
instance MonadUnique LlvmM where
getUniqueSupplyM :: LlvmM UniqSupply
getUniqueSupplyM = do
Char
mask <- forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> Char
envMask
forall a. IO a -> LlvmM a
liftIO forall a b. (a -> b) -> a -> b
$! Char -> IO UniqSupply
mkSplitUniqSupply Char
mask
getUniqueM :: LlvmM Unique
getUniqueM = do
Char
mask <- forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> Char
envMask
forall a. IO a -> LlvmM a
liftIO forall a b. (a -> b) -> a -> b
$! Char -> IO Unique
uniqFromMask Char
mask
liftIO :: IO a -> LlvmM a
liftIO :: forall a. IO a -> LlvmM a
liftIO IO a
m = forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do a
x <- IO a
m
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, LlvmEnv
env)
runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
runLlvm :: forall a.
Logger
-> LlvmCgConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
runLlvm Logger
logger LlvmCgConfig
cfg LlvmVersion
ver BufHandle
out LlvmM a
m = do
(a
a, LlvmEnv
_) <- forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM LlvmM a
m LlvmEnv
env
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
where env :: LlvmEnv
env = LlvmEnv { envFunMap :: LlvmEnvMap
envFunMap = forall key elt. UniqFM key elt
emptyUFM
, envVarMap :: LlvmEnvMap
envVarMap = forall key elt. UniqFM key elt
emptyUFM
, envStackRegs :: LiveGlobalRegs
envStackRegs = []
, envUsedVars :: [LlvmVar]
envUsedVars = []
, envAliases :: UniqSet LMString
envAliases = forall a. UniqSet a
emptyUniqSet
, envVersion :: LlvmVersion
envVersion = LlvmVersion
ver
, envConfig :: LlvmCgConfig
envConfig = LlvmCgConfig
cfg
, envLogger :: Logger
envLogger = Logger
logger
, envOutput :: BufHandle
envOutput = BufHandle
out
, envMask :: Char
envMask = Char
'n'
, envFreshMeta :: MetaId
envFreshMeta = Int -> MetaId
MetaId Int
0
, envUniqMeta :: UniqFM Unique MetaId
envUniqMeta = forall key elt. UniqFM key elt
emptyUFM
}
getEnv :: (LlvmEnv -> a) -> LlvmM a
getEnv :: forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> a
f = forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM (\LlvmEnv
env -> forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> a
f LlvmEnv
env, LlvmEnv
env))
modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv LlvmEnv -> LlvmEnv
f = forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM (\LlvmEnv
env -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), LlvmEnv -> LlvmEnv
f LlvmEnv
env))
withClearVars :: LlvmM a -> LlvmM a
withClearVars :: forall a. LlvmM a -> LlvmM a
withClearVars LlvmM a
m = forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do
(a
x, LlvmEnv
env') <- forall a. LlvmM a -> LlvmEnv -> IO (a, LlvmEnv)
runLlvmM LlvmM a
m LlvmEnv
env { envVarMap :: LlvmEnvMap
envVarMap = forall key elt. UniqFM key elt
emptyUFM, envStackRegs :: LiveGlobalRegs
envStackRegs = [] }
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, LlvmEnv
env' { envVarMap :: LlvmEnvMap
envVarMap = forall key elt. UniqFM key elt
emptyUFM, envStackRegs :: LiveGlobalRegs
envStackRegs = [] })
varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
varInsert :: forall key. Uniquable key => key -> LlvmType -> LlvmM ()
varInsert key
s LlvmType
t = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envVarMap :: LlvmEnvMap
envVarMap = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (LlvmEnv -> LlvmEnvMap
envVarMap LlvmEnv
env) (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 forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envFunMap :: LlvmEnvMap
envFunMap = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (LlvmEnv -> LlvmEnvMap
envFunMap LlvmEnv
env) (forall a. Uniquable a => a -> Unique
getUnique key
s) LlvmType
t }
varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
varLookup :: forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
varLookup key
s = forall a. (LlvmEnv -> a) -> LlvmM a
getEnv (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (forall a. Uniquable a => a -> Unique
getUnique key
s) 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 = forall a. (LlvmEnv -> a) -> LlvmM a
getEnv (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (forall a. Uniquable a => a -> Unique
getUnique key
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmEnv -> LlvmEnvMap
envFunMap)
markStackReg :: GlobalReg -> LlvmM ()
markStackReg :: GlobalReg -> LlvmM ()
markStackReg GlobalReg
r = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envStackRegs :: LiveGlobalRegs
envStackRegs = GlobalReg
r forall a. a -> [a] -> [a]
: LlvmEnv -> LiveGlobalRegs
envStackRegs LlvmEnv
env }
checkStackReg :: GlobalReg -> LlvmM Bool
checkStackReg :: GlobalReg -> LlvmM Bool
checkStackReg GlobalReg
r = forall a. (LlvmEnv -> a) -> LlvmM a
getEnv ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem GlobalReg
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmEnv -> LiveGlobalRegs
envStackRegs)
getMetaUniqueId :: LlvmM MetaId
getMetaUniqueId :: LlvmM MetaId
getMetaUniqueId = forall a. (LlvmEnv -> IO (a, LlvmEnv)) -> LlvmM a
LlvmM forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env ->
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> MetaId
envFreshMeta LlvmEnv
env, LlvmEnv
env { envFreshMeta :: MetaId
envFreshMeta = forall a. Enum a => a -> a
succ forall a b. (a -> b) -> a -> b
$ LlvmEnv -> MetaId
envFreshMeta LlvmEnv
env })
getLlvmVer :: LlvmM LlvmVersion
getLlvmVer :: LlvmM LlvmVersion
getLlvmVer = forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> LlvmVersion
envVersion
dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> SDoc -> LlvmM ()
dumpIfSetLlvm DumpFlag
flag String
hdr DumpFormat
fmt SDoc
doc = do
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall a. IO a -> LlvmM a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
flag String
hdr DumpFormat
fmt SDoc
doc
renderLlvm :: Outp.SDoc -> LlvmM ()
renderLlvm :: SDoc -> LlvmM ()
renderLlvm SDoc
sdoc = do
SDocContext
ctx <- LlvmCgConfig -> SDocContext
llvmCgContext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LlvmM LlvmCgConfig
getConfig
BufHandle
out <- forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> BufHandle
envOutput
forall a. IO a -> LlvmM a
liftIO forall a b. (a -> b) -> a -> b
$ SDocContext -> BufHandle -> SDoc -> IO ()
Outp.bufLeftRenderSDoc SDocContext
ctx BufHandle
out SDoc
sdoc
DumpFlag -> String -> DumpFormat -> SDoc -> LlvmM ()
dumpIfSetLlvm DumpFlag
Opt_D_dump_llvm String
"LLVM Code" DumpFormat
FormatLLVM SDoc
sdoc
forall (m :: * -> *) a. Monad m => a -> m a
return ()
markUsedVar :: LlvmVar -> LlvmM ()
markUsedVar :: LlvmVar -> LlvmM ()
markUsedVar LlvmVar
v = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envUsedVars :: [LlvmVar]
envUsedVars = LlvmVar
v forall a. a -> [a] -> [a]
: LlvmEnv -> [LlvmVar]
envUsedVars LlvmEnv
env }
getUsedVars :: LlvmM [LlvmVar]
getUsedVars :: LlvmM [LlvmVar]
getUsedVars = forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> [LlvmVar]
envUsedVars
saveAlias :: LMString -> LlvmM ()
saveAlias :: LMString -> LlvmM ()
saveAlias LMString
lbl = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envAliases :: UniqSet LMString
envAliases = forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet (LlvmEnv -> UniqSet LMString
envAliases LlvmEnv
env) LMString
lbl }
setUniqMeta :: Unique -> MetaId -> LlvmM ()
setUniqMeta :: Unique -> MetaId -> LlvmM ()
setUniqMeta Unique
f MetaId
m = (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envUniqMeta :: UniqFM Unique MetaId
envUniqMeta = 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 }
getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
getUniqMeta Unique
s = forall a. (LlvmEnv -> a) -> LlvmM a
getEnv (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM Unique
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmEnv -> UniqFM Unique MetaId
envUniqMeta)
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions = do
Platform
platform <- LlvmM Platform
getPlatform
let w :: LlvmType
w = Platform -> LlvmType
llvmWord Platform
platform
cint :: LlvmType
cint = Int -> LlvmType
LMInt forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits forall a b. (a -> b) -> a -> b
$ Platform -> Width
cIntWidth Platform
platform
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) forall a. Maybe a
Nothing
SDoc -> LlvmM ()
renderLlvm forall a b. (a -> b) -> a -> b
$ LlvmFunctionDecl -> SDoc
ppLlvmFunctionDecl LlvmFunctionDecl
decl
forall key. Uniquable key => key -> LlvmType -> LlvmM ()
funInsert LMString
n' (LlvmFunctionDecl -> LlvmType
LMFunction LlvmFunctionDecl
decl)
strCLabel_llvm :: CLabel -> LlvmM LMString
strCLabel_llvm :: CLabel -> LlvmM LMString
strCLabel_llvm CLabel
lbl = do
SDocContext
ctx <- LlvmCgConfig -> SDocContext
llvmCgContext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LlvmM LlvmCgConfig
getConfig
Platform
platform <- LlvmM Platform
getPlatform
let sdoc :: SDoc
sdoc = Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel Platform
platform LabelStyle
CStyle CLabel
lbl
str :: String
str = SDocContext -> SDoc -> String
Outp.renderWithContext SDocContext
ctx SDoc
sdoc
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> LMString
fsLit String
str)
getGlobalPtr :: LMString -> LlvmM LlvmVar
getGlobalPtr :: LMString -> LlvmM LlvmVar
getGlobalPtr LMString
llvmLbl = do
Maybe LlvmType
m_ty <- 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing
case Maybe LlvmType
m_ty of
Just LlvmType
ty -> do
if LMString
llvmLbl forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (forall a b. (a -> b) -> [a] -> [b]
map String -> LMString
fsLit [String
"newSpark", String
"memmove", String
"memcpy", String
"memcmp", String
"memset"])
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LMString -> LlvmType -> LMConst -> LlvmVar
mkGlbVar (LMString
llvmLbl) LlvmType
ty LMConst
Global
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LMString -> LlvmType -> LMConst -> LlvmVar
mkGlbVar (LMString -> LMString
llvmDefLabel LMString
llvmLbl) LlvmType
ty LMConst
Global
Maybe LlvmType
Nothing -> do
LMString -> LlvmM ()
saveAlias LMString
llvmLbl
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LMString -> LlvmType -> LMConst -> LlvmVar
mkGlbVar LMString
llvmLbl LlvmType
i8 LMConst
Alias
llvmDefLabel :: LMString -> LMString
llvmDefLabel :: LMString -> LMString
llvmDefLabel = (LMString -> LMString -> LMString
`appendFS` String -> LMString
fsLit String
"$def")
generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
generateExternDecls = do
[LMString]
delayed <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet forall a b. (a -> b) -> a -> b
$ forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> UniqSet LMString
envAliases
[[LMGlobal]]
defss <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [LMString]
delayed forall a b. (a -> b) -> a -> b
$ \LMString
lbl -> do
Maybe LlvmType
m_ty <- forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
funLookup LMString
lbl
case Maybe LlvmType
m_ty of
Just LlvmType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Maybe LlvmType
Nothing ->
let var :: LlvmVar
var = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
lbl LlvmType
i8Ptr LlvmLinkageType
External forall a. Maybe a
Nothing forall a. Maybe a
Nothing LMConst
Global
in forall (m :: * -> *) a. Monad m => a -> m a
return [LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal LlvmVar
var forall a. Maybe a
Nothing]
(LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envAliases :: UniqSet LMString
envAliases = forall a. UniqSet a
emptyUniqSet }
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LMGlobal]]
defss, [])
isBuiltinLlvmVar :: LlvmVar -> Bool
isBuiltinLlvmVar :: LlvmVar -> Bool
isBuiltinLlvmVar (LMGlobalVar LMString
lbl LlvmType
_ LlvmLinkageType
_ LMSection
_ LMAlign
_ LMConst
_) =
String
"$llvm" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` LMString -> String
unpackFS LMString
lbl
isBuiltinLlvmVar LlvmVar
_ = Bool
False
aliasify :: LMGlobal -> LlvmM [LMGlobal]
aliasify :: LMGlobal -> LlvmM [LMGlobal]
aliasify (LMGlobal var :: LlvmVar
var@(LMGlobalVar LMString
lbl ty :: LlvmType
ty@LMAlias{} LlvmLinkageType
link LMSection
sect LMAlign
align LMConst
Alias)
(Just LlvmStatic
orig))
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ LlvmVar -> Bool
isBuiltinLlvmVar LlvmVar
var = do
let defLbl :: LMString
defLbl = LMString -> LMString
llvmDefLabel LMString
lbl
LMStaticPointer (LMGlobalVar LMString
origLbl LlvmType
_ LlvmLinkageType
oLnk LMSection
Nothing LMAlign
Nothing LMConst
Alias) = LlvmStatic
orig
defOrigLbl :: LMString
defOrigLbl = LMString -> LMString
llvmDefLabel LMString
origLbl
orig' :: LlvmStatic
orig' = LlvmVar -> LlvmStatic
LMStaticPointer (LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
origLbl LlvmType
i8Ptr LlvmLinkageType
oLnk forall a. Maybe a
Nothing forall a. Maybe a
Nothing LMConst
Alias)
Maybe LlvmType
origType <- 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 forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe LlvmType
origType) LlvmLinkageType
oLnk
forall a. Maybe a
Nothing forall a. Maybe a
Nothing LMConst
Alias))
(LlvmType -> LlvmType
pLift LlvmType
ty)
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) (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) (forall a. a -> Maybe a
Just LlvmStatic
orig')
]
aliasify (LMGlobal LlvmVar
var Maybe LlvmStatic
val)
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ LlvmVar -> Bool
isBuiltinLlvmVar LlvmVar
var = do
let LMGlobalVar LMString
lbl LlvmType
ty LlvmLinkageType
link LMSection
sect LMAlign
align LMConst
const = LlvmVar
var
defLbl :: LMString
defLbl = LMString -> LMString
llvmDefLabel LMString
lbl
defVar :: LlvmVar
defVar = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
defLbl LlvmType
ty LlvmLinkageType
Internal LMSection
sect LMAlign
align LMConst
const
defPtrVar :: LlvmVar
defPtrVar = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
defLbl (LlvmType -> LlvmType
LMPointer LlvmType
ty) LlvmLinkageType
link forall a. Maybe a
Nothing forall a. Maybe a
Nothing LMConst
const
aliasVar :: LlvmVar
aliasVar = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
lbl LlvmType
i8Ptr LlvmLinkageType
link forall a. Maybe a
Nothing forall a. Maybe a
Nothing LMConst
Alias
aliasVal :: LlvmStatic
aliasVal = LlvmStatic -> LlvmType -> LlvmStatic
LMBitc (LlvmVar -> LlvmStatic
LMStaticPointer LlvmVar
defPtrVar) LlvmType
i8Ptr
LlvmVar -> LlvmM ()
markUsedVar LlvmVar
defVar
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 (forall a. a -> Maybe a
Just LlvmStatic
aliasVal)
]
aliasify LMGlobal
global = forall (f :: * -> *) a. Applicative f => a -> f a
pure [LMGlobal
global]