{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CmmToLlvm.Base (
LlvmCmmDecl, LlvmBasicBlock,
LiveGlobalRegs, LiveGlobalRegUses,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
LlvmM,
runLlvm, withClearVars, varLookup, varInsert,
markStackReg, checkStackReg,
funLookup, funInsert, getLlvmVer,
dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
ghcInternalFunctions, getPlatform, getConfig,
getMetaUniqueId,
setUniqMeta, getUniqMeta, liftIO, liftUDSMT,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,
lookupRegUse,
strCLabel_llvm,
getGlobalPtr, generateExternDecls,
aliasify, llvmDefLabel
) where
import GHC.Prelude
import GHC.Utils.Panic
import GHC.Llvm
import GHC.CmmToLlvm.Regs
import GHC.CmmToLlvm.Config
import GHC.CmmToLlvm.Version
import GHC.Cmm.CLabel
import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
import GHC.Driver.DynFlags
import GHC.Data.FastString
import GHC.Cmm hiding ( succ )
import GHC.Cmm.Utils (globalRegsOverlap)
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 qualified GHC.Types.Unique.DSM as DSM
import GHC.Utils.Logger
import Control.Monad.Trans.State (StateT (..))
import Control.Applicative (Alternative((<|>)))
import Data.Maybe (fromJust, mapMaybe)
import Data.List (find, isPrefixOf)
import qualified Data.List.NonEmpty as NE
import Data.Ord (comparing)
import qualified Control.Monad.IO.Class as IO
type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement)
type LlvmBasicBlock = GenBasicBlock LlvmStatement
type LiveGlobalRegs = [GlobalReg]
type LiveGlobalRegUses = [GlobalRegUse]
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 (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
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. HasCallStack => 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
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
llvmGhcCC :: Platform -> LlvmCallConvention
llvmGhcCC :: Platform -> LlvmCallConvention
llvmGhcCC Platform
platform
| Platform -> Bool
platformUnregisterised Platform
platform = LlvmCallConvention
CC_Ccc
| Bool
otherwise = LlvmCallConvention
CC_Ghc
llvmFunTy :: LiveGlobalRegUses -> LlvmM LlvmType
llvmFunTy :: LiveGlobalRegUses -> LlvmM LlvmType
llvmFunTy LiveGlobalRegUses
live = LlvmType -> LlvmM LlvmType
forall a. a -> LlvmM a
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
=<< LiveGlobalRegUses
-> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig' LiveGlobalRegUses
live (String -> LMString
fsLit String
"a") LlvmLinkageType
ExternallyVisible
llvmFunSig :: LiveGlobalRegUses -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig :: LiveGlobalRegUses
-> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig LiveGlobalRegUses
live CLabel
lbl LlvmLinkageType
link = do
lbl' <- CLabel -> LlvmM LMString
strCLabel_llvm CLabel
lbl
llvmFunSig' live lbl' link
llvmFunSig' :: LiveGlobalRegUses -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig' :: LiveGlobalRegUses
-> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig' LiveGlobalRegUses
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 <- LlvmM Platform
getPlatform
return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs
(map (toParams . getVarType) (llvmFunArgs platform live))
(llvmFunAlign platform)
llvmFunAlign :: Platform -> LMAlign
llvmFunAlign :: Platform -> LMAlign
llvmFunAlign Platform
platform = Int -> LMAlign
forall a. a -> Maybe a
Just (Platform -> Int
platformWordSizeInBytes Platform
platform)
llvmInfAlign :: Platform -> LMAlign
llvmInfAlign :: Platform -> LMAlign
llvmInfAlign Platform
platform = Int -> LMAlign
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 = 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
llvmFunArgs :: Platform -> LiveGlobalRegUses -> [LlvmVar]
llvmFunArgs :: Platform -> LiveGlobalRegUses -> [LlvmVar]
llvmFunArgs Platform
platform LiveGlobalRegUses
live =
(GlobalRegUse -> LlvmVar) -> LiveGlobalRegUses -> [LlvmVar]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> GlobalRegUse -> LlvmVar
lmGlobalRegArg Platform
platform) ((GlobalReg -> Maybe GlobalRegUse)
-> [GlobalReg] -> LiveGlobalRegUses
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GlobalReg -> Maybe GlobalRegUse
isPassed [GlobalReg]
allRegs)
where allRegs :: [GlobalReg]
allRegs = Platform -> [GlobalReg]
activeStgRegs Platform
platform
paddingRegs :: LiveGlobalRegUses
paddingRegs = Platform -> LiveGlobalRegUses -> LiveGlobalRegUses
padLiveArgs Platform
platform LiveGlobalRegUses
live
isLive :: GlobalReg -> Maybe GlobalRegUse
isLive :: GlobalReg -> Maybe GlobalRegUse
isLive GlobalReg
r =
GlobalReg -> LiveGlobalRegUses -> Maybe GlobalRegUse
lookupRegUse GlobalReg
r (Platform -> LiveGlobalRegUses
alwaysLive Platform
platform)
Maybe GlobalRegUse -> Maybe GlobalRegUse -> Maybe GlobalRegUse
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
GlobalReg -> LiveGlobalRegUses -> Maybe GlobalRegUse
lookupRegUse GlobalReg
r LiveGlobalRegUses
live
Maybe GlobalRegUse -> Maybe GlobalRegUse -> Maybe GlobalRegUse
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
GlobalReg -> LiveGlobalRegUses -> Maybe GlobalRegUse
lookupRegUse GlobalReg
r LiveGlobalRegUses
paddingRegs
isPassed :: GlobalReg -> Maybe GlobalRegUse
isPassed GlobalReg
r =
if Bool -> Bool
not (GlobalReg -> Bool
isFPR GlobalReg
r)
then GlobalRegUse -> Maybe GlobalRegUse
forall a. a -> Maybe a
Just (GlobalRegUse -> Maybe GlobalRegUse)
-> GlobalRegUse -> Maybe GlobalRegUse
forall a b. (a -> b) -> a -> b
$ GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
r (Platform -> GlobalReg -> CmmType
globalRegSpillType Platform
platform GlobalReg
r)
else GlobalReg -> Maybe GlobalRegUse
isLive GlobalReg
r
lookupRegUse :: GlobalReg -> [GlobalRegUse] -> Maybe GlobalRegUse
lookupRegUse :: GlobalReg -> LiveGlobalRegUses -> Maybe GlobalRegUse
lookupRegUse GlobalReg
r = (GlobalRegUse -> Bool) -> LiveGlobalRegUses -> Maybe GlobalRegUse
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((GlobalReg -> GlobalReg -> Bool
forall a. Eq a => a -> a -> Bool
== GlobalReg
r) (GlobalReg -> Bool)
-> (GlobalRegUse -> GlobalReg) -> GlobalRegUse -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRegUse -> GlobalReg
globalRegUse_reg)
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 -> LiveGlobalRegUses -> LiveGlobalRegUses
padLiveArgs :: Platform -> LiveGlobalRegUses -> LiveGlobalRegUses
padLiveArgs Platform
platform LiveGlobalRegUses
live =
if Platform -> Bool
platformUnregisterised Platform
platform
then []
else LiveGlobalRegUses
padded
where
fprLive :: LiveGlobalRegUses
fprLive = (GlobalRegUse -> Bool) -> LiveGlobalRegUses -> LiveGlobalRegUses
forall a. (a -> Bool) -> [a] -> [a]
filter (GlobalReg -> Bool
isFPR (GlobalReg -> Bool)
-> (GlobalRegUse -> GlobalReg) -> GlobalRegUse -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRegUse -> GlobalReg
globalRegUse_reg) LiveGlobalRegUses
live
classes :: [NonEmpty GlobalRegUse]
classes = (GlobalRegUse -> GlobalRegUse -> Bool)
-> LiveGlobalRegUses -> [NonEmpty GlobalRegUse]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy GlobalRegUse -> GlobalRegUse -> Bool
sharesClass LiveGlobalRegUses
fprLive
sharesClass :: GlobalRegUse -> GlobalRegUse -> Bool
sharesClass GlobalRegUse
a GlobalRegUse
b = Platform -> GlobalReg -> GlobalReg -> Bool
globalRegsOverlap Platform
platform (GlobalRegUse -> GlobalReg
norm GlobalRegUse
a) (GlobalRegUse -> GlobalReg
norm GlobalRegUse
b)
norm :: GlobalRegUse -> GlobalReg
norm GlobalRegUse
x = GlobalRegUse -> GlobalReg
globalRegUse_reg (GlobalRegUse -> Int -> GlobalRegUse
fpr_ctor GlobalRegUse
x Int
1)
padded :: [GlobalRegUse]
padded :: LiveGlobalRegUses
padded = (NonEmpty GlobalRegUse -> LiveGlobalRegUses)
-> [NonEmpty GlobalRegUse] -> LiveGlobalRegUses
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty GlobalRegUse -> LiveGlobalRegUses
padClass [NonEmpty GlobalRegUse]
classes
padClass :: NE.NonEmpty GlobalRegUse -> [GlobalRegUse]
padClass :: NonEmpty GlobalRegUse -> LiveGlobalRegUses
padClass NonEmpty GlobalRegUse
rs = LiveGlobalRegUses -> Int -> LiveGlobalRegUses
go (NonEmpty GlobalRegUse -> LiveGlobalRegUses
forall a. NonEmpty a -> [a]
NE.toList NonEmpty GlobalRegUse
sortedRs) Int
1
where
sortedRs :: NonEmpty GlobalRegUse
sortedRs = (GlobalRegUse -> GlobalRegUse -> Ordering)
-> NonEmpty GlobalRegUse -> NonEmpty GlobalRegUse
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy ((GlobalRegUse -> Int) -> GlobalRegUse -> GlobalRegUse -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (GlobalReg -> Int
fpr_num (GlobalReg -> Int)
-> (GlobalRegUse -> GlobalReg) -> GlobalRegUse -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRegUse -> GlobalReg
globalRegUse_reg)) NonEmpty GlobalRegUse
rs
maxr :: GlobalRegUse
maxr = NonEmpty GlobalRegUse -> GlobalRegUse
forall a. NonEmpty a -> a
NE.last NonEmpty GlobalRegUse
sortedRs
ctor :: Int -> GlobalRegUse
ctor = GlobalRegUse -> Int -> GlobalRegUse
fpr_ctor GlobalRegUse
maxr
go :: LiveGlobalRegUses -> Int -> LiveGlobalRegUses
go [] Int
_ = []
go (GlobalRegUse GlobalReg
c1 CmmType
_: GlobalRegUse GlobalReg
c2 CmmType
_:LiveGlobalRegUses
_) Int
_
| 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 -> LiveGlobalRegUses
forall a. String -> SDoc -> a
sorryDoc String
"LLVM code generator" (SDoc -> LiveGlobalRegUses) -> SDoc -> LiveGlobalRegUses
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Found two different Cmm registers (" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
c1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"," SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
c2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
") both alive AND mapped to the same real register: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> RealReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealReg
real SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
". This isn't currently supported by the LLVM backend."
go (cu :: GlobalRegUse
cu@(GlobalRegUse GlobalReg
c CmmType
_):LiveGlobalRegUses
cs) Int
f
| GlobalReg -> Int
fpr_num GlobalReg
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
f = LiveGlobalRegUses -> Int -> LiveGlobalRegUses
go LiveGlobalRegUses
cs Int
f
| Bool
otherwise = Int -> GlobalRegUse
ctor Int
f GlobalRegUse -> LiveGlobalRegUses -> LiveGlobalRegUses
forall a. a -> [a] -> [a]
: LiveGlobalRegUses -> Int -> LiveGlobalRegUses
go (GlobalRegUse
cuGlobalRegUse -> LiveGlobalRegUses -> LiveGlobalRegUses
forall a. a -> [a] -> [a]
:LiveGlobalRegUses
cs) (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
fpr_ctor :: GlobalRegUse -> Int -> GlobalRegUse
fpr_ctor :: GlobalRegUse -> Int -> GlobalRegUse
fpr_ctor (GlobalRegUse GlobalReg
r CmmType
fmt) Int
i =
case GlobalReg
r of
FloatReg Int
_ -> GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse (Int -> GlobalReg
FloatReg Int
i) CmmType
fmt
DoubleReg Int
_ -> GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse (Int -> GlobalReg
DoubleReg Int
i) CmmType
fmt
XmmReg Int
_ -> GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse (Int -> GlobalReg
XmmReg Int
i) CmmType
fmt
YmmReg Int
_ -> GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse (Int -> GlobalReg
YmmReg Int
i) CmmType
fmt
ZmmReg Int
_ -> GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse (Int -> GlobalReg
ZmmReg Int
i) CmmType
fmt
GlobalReg
_ -> String -> GlobalRegUse
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"
llvmStdFunAttrs :: [LlvmFuncAttr]
llvmStdFunAttrs :: [LlvmFuncAttr]
llvmStdFunAttrs = [LlvmFuncAttr
NoUnwind]
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, []))
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
data LlvmEnv = LlvmEnv
{ LlvmEnv -> LlvmVersion
envVersion :: LlvmVersion
, LlvmEnv -> LlvmCgConfig
envConfig :: !LlvmCgConfig
, LlvmEnv -> Logger
envLogger :: !Logger
, LlvmEnv -> BufHandle
envOutput :: BufHandle
, LlvmEnv -> Char
envTag :: !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 -> [GlobalReg]
envStackRegs :: [GlobalReg]
}
type LlvmEnvMap = UniqFM Unique LlvmType
newtype LlvmM a = LlvmM { forall a. LlvmM a -> LlvmEnv -> UniqDSMT IO (a, LlvmEnv)
runLlvmM :: LlvmEnv -> DSM.UniqDSMT IO (a, LlvmEnv) }
deriving stock ((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
$cfmap :: forall a b. (a -> b) -> LlvmM a -> LlvmM b
fmap :: forall a b. (a -> b) -> LlvmM a -> LlvmM b
$c<$ :: forall a b. a -> LlvmM b -> LlvmM a
<$ :: forall a b. a -> LlvmM b -> LlvmM a
Functor)
deriving (Functor LlvmM
Functor LlvmM =>
(forall a. a -> LlvmM a)
-> (forall a b. LlvmM (a -> b) -> LlvmM a -> LlvmM b)
-> (forall a b c. (a -> b -> c) -> LlvmM a -> LlvmM b -> LlvmM c)
-> (forall a b. LlvmM a -> LlvmM b -> LlvmM b)
-> (forall a b. LlvmM a -> LlvmM b -> LlvmM a)
-> Applicative LlvmM
forall a. a -> LlvmM a
forall a b. LlvmM a -> LlvmM b -> LlvmM a
forall a b. LlvmM a -> LlvmM b -> LlvmM b
forall a b. LlvmM (a -> b) -> LlvmM a -> LlvmM b
forall a b c. (a -> b -> c) -> LlvmM a -> LlvmM b -> LlvmM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> LlvmM a
pure :: forall a. a -> LlvmM a
$c<*> :: forall a b. LlvmM (a -> b) -> LlvmM a -> LlvmM b
<*> :: forall a b. LlvmM (a -> b) -> LlvmM a -> LlvmM b
$cliftA2 :: forall a b c. (a -> b -> c) -> LlvmM a -> LlvmM b -> LlvmM c
liftA2 :: forall a b c. (a -> b -> c) -> LlvmM a -> LlvmM b -> LlvmM c
$c*> :: forall a b. LlvmM a -> LlvmM b -> LlvmM b
*> :: forall a b. LlvmM a -> LlvmM b -> LlvmM b
$c<* :: forall a b. LlvmM a -> LlvmM b -> LlvmM a
<* :: forall a b. LlvmM a -> LlvmM b -> LlvmM a
Applicative, Applicative LlvmM
Applicative LlvmM =>
(forall a b. LlvmM a -> (a -> LlvmM b) -> LlvmM b)
-> (forall a b. LlvmM a -> LlvmM b -> LlvmM b)
-> (forall a. a -> LlvmM a)
-> Monad LlvmM
forall a. a -> LlvmM a
forall a b. LlvmM a -> LlvmM b -> LlvmM b
forall a b. LlvmM a -> (a -> LlvmM b) -> LlvmM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. LlvmM a -> (a -> LlvmM b) -> LlvmM b
>>= :: forall a b. LlvmM a -> (a -> LlvmM b) -> LlvmM b
$c>> :: forall a b. LlvmM a -> LlvmM b -> LlvmM b
>> :: forall a b. LlvmM a -> LlvmM b -> LlvmM b
$creturn :: forall a. a -> LlvmM a
return :: forall a. a -> LlvmM a
Monad) via StateT LlvmEnv (DSM.UniqDSMT IO)
instance HasLogger LlvmM where
getLogger :: LlvmM Logger
getLogger = (LlvmEnv -> UniqDSMT IO (Logger, LlvmEnv)) -> LlvmM Logger
forall a. (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> UniqDSMT IO (Logger, LlvmEnv)) -> LlvmM Logger)
-> (LlvmEnv -> UniqDSMT IO (Logger, LlvmEnv)) -> LlvmM Logger
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> (Logger, LlvmEnv) -> UniqDSMT IO (Logger, LlvmEnv)
forall a. a -> UniqDSMT IO a
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 (LlvmCgConfig -> Platform) -> LlvmM LlvmCgConfig -> LlvmM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LlvmM LlvmCgConfig
getConfig
getConfig :: LlvmM LlvmCgConfig
getConfig :: LlvmM LlvmCgConfig
getConfig = (LlvmEnv -> UniqDSMT IO (LlvmCgConfig, LlvmEnv))
-> LlvmM LlvmCgConfig
forall a. (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> UniqDSMT IO (LlvmCgConfig, LlvmEnv))
-> LlvmM LlvmCgConfig)
-> (LlvmEnv -> UniqDSMT IO (LlvmCgConfig, LlvmEnv))
-> LlvmM LlvmCgConfig
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> (LlvmCgConfig, LlvmEnv) -> UniqDSMT IO (LlvmCgConfig, LlvmEnv)
forall a. a -> UniqDSMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> LlvmCgConfig
envConfig LlvmEnv
env, LlvmEnv
env)
instance DSM.MonadGetUnique LlvmM where
getUniqueM :: LlvmM Unique
getUniqueM = do
tag <- (LlvmEnv -> Char) -> LlvmM Char
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> Char
envTag
liftUDSMT $! do
uq <- DSM.getUniqueM
return (newTagUnique uq tag)
liftIO :: IO a -> LlvmM a
liftIO :: forall a. IO a -> LlvmM a
liftIO IO a
m = (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a)
-> (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do x <- IO a -> UniqDSMT IO a
forall a. IO a -> UniqDSMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO IO a
m
return (x, env)
liftUDSMT :: DSM.UniqDSMT IO a -> LlvmM a
liftUDSMT :: forall a. UniqDSMT IO a -> LlvmM a
liftUDSMT UniqDSMT IO a
m = (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a)
-> (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do x <- UniqDSMT IO a
m
return (x, env)
runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> DSM.DUniqSupply -> LlvmM a -> IO (a, DSM.DUniqSupply)
runLlvm :: forall a.
Logger
-> LlvmCgConfig
-> LlvmVersion
-> BufHandle
-> DUniqSupply
-> LlvmM a
-> IO (a, DUniqSupply)
runLlvm Logger
logger LlvmCgConfig
cfg LlvmVersion
ver BufHandle
out DUniqSupply
us LlvmM a
m = do
((a, _), us') <- DUniqSupply
-> UniqDSMT IO (a, LlvmEnv) -> IO ((a, LlvmEnv), DUniqSupply)
forall (m :: * -> *) a.
DUniqSupply -> UniqDSMT m a -> m (a, DUniqSupply)
DSM.runUDSMT DUniqSupply
us (UniqDSMT IO (a, LlvmEnv) -> IO ((a, LlvmEnv), DUniqSupply))
-> UniqDSMT IO (a, LlvmEnv) -> IO ((a, LlvmEnv), DUniqSupply)
forall a b. (a -> b) -> a -> b
$ LlvmM a -> LlvmEnv -> UniqDSMT IO (a, LlvmEnv)
forall a. LlvmM a -> LlvmEnv -> UniqDSMT IO (a, LlvmEnv)
runLlvmM LlvmM a
m LlvmEnv
env
return (a, us')
where env :: LlvmEnv
env = LlvmEnv { envFunMap :: LlvmEnvMap
envFunMap = LlvmEnvMap
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM
, envVarMap :: LlvmEnvMap
envVarMap = LlvmEnvMap
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM
, envStackRegs :: [GlobalReg]
envStackRegs = []
, envUsedVars :: [LlvmVar]
envUsedVars = []
, envAliases :: UniqSet LMString
envAliases = UniqSet LMString
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
, envTag :: Char
envTag = Char
'n'
, envFreshMeta :: MetaId
envFreshMeta = Int -> MetaId
MetaId Int
0
, envUniqMeta :: UniqFM Unique MetaId
envUniqMeta = UniqFM Unique MetaId
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM
}
getEnv :: (LlvmEnv -> a) -> LlvmM a
getEnv :: forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> a
f = (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
LlvmM (\LlvmEnv
env -> (a, LlvmEnv) -> UniqDSMT IO (a, LlvmEnv)
forall a. a -> UniqDSMT IO a
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 = (LlvmEnv -> UniqDSMT IO ((), LlvmEnv)) -> LlvmM ()
forall a. (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
LlvmM (\LlvmEnv
env -> ((), LlvmEnv) -> UniqDSMT IO ((), LlvmEnv)
forall a. a -> UniqDSMT IO a
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 = (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
forall a. (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a)
-> (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> do
(x, env') <- LlvmM a -> LlvmEnv -> UniqDSMT IO (a, LlvmEnv)
forall a. LlvmM a -> LlvmEnv -> UniqDSMT IO (a, LlvmEnv)
runLlvmM LlvmM a
m LlvmEnv
env { envVarMap = emptyUFM, envStackRegs = [] }
return (x, env' { envVarMap = emptyUFM, 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 ((LlvmEnv -> LlvmEnv) -> LlvmM ())
-> (LlvmEnv -> LlvmEnv) -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env -> LlvmEnv
env { envVarMap = addToUFM (envVarMap env) (getUnique s) 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 = addToUFM (envFunMap env) (getUnique s) t }
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)
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 = r : envStackRegs env }
checkStackReg :: GlobalReg -> LlvmM Bool
checkStackReg :: GlobalReg -> LlvmM Bool
checkStackReg GlobalReg
r = (LlvmEnv -> Bool) -> LlvmM Bool
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv ((GlobalReg -> [GlobalReg] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem GlobalReg
r) ([GlobalReg] -> Bool)
-> (LlvmEnv -> [GlobalReg]) -> LlvmEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmEnv -> [GlobalReg]
envStackRegs)
getMetaUniqueId :: LlvmM MetaId
getMetaUniqueId :: LlvmM MetaId
getMetaUniqueId = (LlvmEnv -> UniqDSMT IO (MetaId, LlvmEnv)) -> LlvmM MetaId
forall a. (LlvmEnv -> UniqDSMT IO (a, LlvmEnv)) -> LlvmM a
LlvmM ((LlvmEnv -> UniqDSMT IO (MetaId, LlvmEnv)) -> LlvmM MetaId)
-> (LlvmEnv -> UniqDSMT IO (MetaId, LlvmEnv)) -> LlvmM MetaId
forall a b. (a -> b) -> a -> b
$ \LlvmEnv
env ->
(MetaId, LlvmEnv) -> UniqDSMT IO (MetaId, LlvmEnv)
forall a. a -> UniqDSMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmEnv -> MetaId
envFreshMeta LlvmEnv
env, LlvmEnv
env { envFreshMeta = succ $ envFreshMeta env })
getLlvmVer :: LlvmM LlvmVersion
getLlvmVer :: LlvmM LlvmVersion
getLlvmVer = (LlvmEnv -> LlvmVersion) -> LlvmM LlvmVersion
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 <- LlvmM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
liftIO $ putDumpFileMaybe logger flag hdr fmt doc
renderLlvm :: Outp.HDoc -> Outp.SDoc -> LlvmM ()
renderLlvm :: HDoc -> SDoc -> LlvmM ()
renderLlvm HDoc
hdoc SDoc
sdoc = do
ctx <- LlvmCgConfig -> SDocContext
llvmCgContext (LlvmCgConfig -> SDocContext)
-> LlvmM LlvmCgConfig -> LlvmM SDocContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LlvmM LlvmCgConfig
getConfig
out <- getEnv envOutput
liftIO $ Outp.bPutHDoc out ctx hdoc
dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc
return ()
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 = v : envUsedVars env }
getUsedVars :: LlvmM [LlvmVar]
getUsedVars :: LlvmM [LlvmVar]
getUsedVars = (LlvmEnv -> [LlvmVar]) -> LlvmM [LlvmVar]
forall a. (LlvmEnv -> a) -> LlvmM a
getEnv LlvmEnv -> [LlvmVar]
envUsedVars
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 = addOneToUniqSet (envAliases env) lbl }
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 = addToUFM (envUniqMeta env) f m }
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)
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions = do
platform <- LlvmM Platform
getPlatform
let w = Platform -> LlvmType
llvmWord Platform
platform
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
$ Platform -> Width
cIntWidth Platform
platform
mk "memcmp" cint [i8Ptr, i8Ptr, w]
mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]
mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]
mk "memset" i8Ptr [i8Ptr, w, w]
mk "newSpark" w [i8Ptr, 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
HDoc -> SDoc -> LlvmM ()
renderLlvm (LlvmFunctionDecl -> HDoc
forall doc. IsDoc doc => LlvmFunctionDecl -> doc
ppLlvmFunctionDecl LlvmFunctionDecl
decl) (LlvmFunctionDecl -> SDoc
forall doc. IsDoc doc => LlvmFunctionDecl -> doc
ppLlvmFunctionDecl LlvmFunctionDecl
decl)
LMString -> LlvmType -> LlvmM ()
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
ctx <- LlvmCgConfig -> SDocContext
llvmCgContext (LlvmCgConfig -> SDocContext)
-> LlvmM LlvmCgConfig -> LlvmM SDocContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LlvmM LlvmCgConfig
getConfig
platform <- getPlatform
let sdoc = Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl
str = SDocContext -> SDoc -> String
Outp.showSDocOneLine SDocContext
ctx SDoc
sdoc
return (fsLit str)
getGlobalPtr :: LMString -> LlvmM LlvmVar
getGlobalPtr :: LMString -> LlvmM LlvmVar
getGlobalPtr LMString
llvmLbl = do
m_ty <- LMString -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
funLookup LMString
llvmLbl
let 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 m_ty of
Just LlvmType
ty -> do
if LMString
llvmLbl LMString -> [LMString] -> Bool
forall a. Eq a => a -> [a] -> 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 a. a -> LlvmM a
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 a. a -> LlvmM a
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
Maybe LlvmType
Nothing -> do
LMString -> LlvmM ()
saveAlias LMString
llvmLbl
LlvmVar -> LlvmM LlvmVar
forall a. a -> LlvmM a
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
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
delayed <- (UniqSet LMString -> [LMString])
-> LlvmM (UniqSet LMString) -> LlvmM [LMString]
forall a b. (a -> b) -> LlvmM a -> LlvmM b
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
defss <- flip mapM delayed $ \LMString
lbl -> do
m_ty <- LMString -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
funLookup LMString
lbl
case m_ty of
Just LlvmType
_ -> [LMGlobal] -> LlvmM [LMGlobal]
forall a. a -> LlvmM a
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 LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Global
in [LMGlobal] -> LlvmM [LMGlobal]
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return [LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal LlvmVar
var Maybe LlvmStatic
forall a. Maybe a
Nothing]
modifyEnv $ \LlvmEnv
env -> LlvmEnv
env { envAliases = emptyUniqSet }
return (concat defss, [])
isBuiltinLlvmVar :: LlvmVar -> Bool
isBuiltinLlvmVar :: LlvmVar -> Bool
isBuiltinLlvmVar (LMGlobalVar LMString
lbl LlvmType
_ LlvmLinkageType
_ LMSection
_ LMAlign
_ LMConst
_) =
String
"$llvm" String -> String -> Bool
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 (Bool -> Bool) -> Bool -> Bool
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 LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Alias)
origType <- LMString -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
funLookup LMString
origLbl
let 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)
pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
, LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
]
aliasify (LMGlobal LlvmVar
var Maybe LlvmStatic
val)
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
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 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
LlvmVar -> LlvmM ()
markUsedVar LlvmVar
defVar
[LMGlobal] -> LlvmM [LMGlobal]
forall a. a -> LlvmM a
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)
]
aliasify LMGlobal
global = [LMGlobal] -> LlvmM [LMGlobal]
forall a. a -> LlvmM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LMGlobal
global]