{-# 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, getDynFlags,
dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
ghcInternalFunctions, getPlatform, getLlvmOpts,
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 "GhclibHsVersions.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.Logger
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
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 :: LlvmOpts -> LMString -> LMSection
llvmFunSection :: LlvmOpts -> LMString -> LMSection
llvmFunSection LlvmOpts
opts LMString
lbl
| LlvmOpts -> Bool
llvmOptsSplitSections LlvmOpts
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
newtype LlvmVersion = LlvmVersion { LlvmVersion -> NonEmpty Int
llvmVersionNE :: NE.NonEmpty Int }
deriving (LlvmVersion -> LlvmVersion -> Bool
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
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 =
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 -> LlvmOpts
envOpts :: LlvmOpts
, LlvmEnv -> DynFlags
envDynFlags :: DynFlags
, 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 HasDynFlags LlvmM where
getDynFlags :: LlvmM DynFlags
getDynFlags = 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 -> DynFlags
envDynFlags LlvmEnv
env, 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 = LlvmOpts -> Platform
llvmOptsPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LlvmM LlvmOpts
getLlvmOpts
getLlvmOpts :: LlvmM LlvmOpts
getLlvmOpts :: LlvmM LlvmOpts
getLlvmOpts = 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 -> LlvmOpts
envOpts 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 -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
runLlvm :: forall a.
Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
runLlvm Logger
logger DynFlags
dflags 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
, envOpts :: LlvmOpts
envOpts = DynFlags -> LlvmOpts
initLlvmOpts DynFlags
dflags
, envDynFlags :: DynFlags
envDynFlags = DynFlags
dflags
, 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
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall a. IO a -> LlvmM a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
flag String
hdr DumpFormat
fmt SDoc
doc
renderLlvm :: Outp.SDoc -> LlvmM ()
renderLlvm :: SDoc -> LlvmM ()
renderLlvm SDoc
sdoc = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
BufHandle
out <- forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> BufHandle
envOutput
let ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (LabelStyle -> PprStyle
Outp.PprCode LabelStyle
Outp.CStyle)
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
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
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
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (LabelStyle -> PprStyle
Outp.PprCode LabelStyle
Outp.CStyle))
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, [])
aliasify :: LMGlobal -> LlvmM [LMGlobal]
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 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) = 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)
]