module GHC.CmmToLlvm.Data (
genLlvmData, genData
) where
import GHC.Prelude
import GHC.Llvm
import GHC.CmmToLlvm.Base
import GHC.CmmToLlvm.Config
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.InitFini
import GHC.Cmm
import GHC.Platform
import GHC.Data.FastString
import GHC.Utils.Panic
import qualified Data.ByteString as BS
structStr :: LMString
structStr :: LMString
structStr = String -> LMString
fsLit String
"_struct"
linkage :: CLabel -> LlvmLinkageType
linkage :: CLabel -> LlvmLinkageType
linkage CLabel
lbl = if CLabel -> Bool
externallyVisibleCLabel CLabel
lbl
then LlvmLinkageType
ExternallyVisible else LlvmLinkageType
Internal
genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData
genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData
genLlvmData (Section
_, CmmStaticsRaw CLabel
alias [CmmStaticLit (CmmLabel CLabel
lbl), CmmStaticLit CmmLit
ind, CmmStatic
_, CmmStatic
_])
| CLabel
lbl CLabel -> CLabel -> Bool
forall a. Eq a => a -> a -> Bool
== CLabel
mkIndStaticInfoLabel
, let labelInd :: CmmLit -> Maybe CLabel
labelInd (CmmLabelOff CLabel
l Int
_) = CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
l
labelInd (CmmLabel CLabel
l) = CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
l
labelInd CmmLit
_ = Maybe CLabel
forall a. Maybe a
Nothing
, Just CLabel
ind' <- CmmLit -> Maybe CLabel
labelInd CmmLit
ind
, CLabel
alias CLabel -> CLabel -> Bool
`mayRedirectTo` CLabel
ind' = do
label <- CLabel -> LlvmM LMString
strCLabel_llvm CLabel
alias
label' <- strCLabel_llvm ind'
let link = CLabel -> LlvmLinkageType
linkage CLabel
alias
link' = CLabel -> LlvmLinkageType
linkage CLabel
ind'
tyAlias = LlvmAlias -> LlvmType
LMAlias (LMString
label LMString -> LMString -> LMString
`appendFS` LMString
structStr, [LlvmType] -> LlvmType
LMStructU [])
aliasDef = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
label LlvmType
tyAlias LlvmLinkageType
link LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Alias
indType = String -> a
forall a. HasCallStack => String -> a
panic String
"will be filled by 'aliasify', later"
orig = LlvmVar -> LlvmStatic
LMStaticPointer (LlvmVar -> LlvmStatic) -> LlvmVar -> LlvmStatic
forall a b. (a -> b) -> a -> b
$ LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
label' LlvmType
forall {a}. a
indType LlvmLinkageType
link' LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Alias
pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
genLlvmData (Section
sect, RawCmmStatics
statics)
| Just (InitOrFini
initOrFini, [CLabel]
clbls) <- RawCmmDecl -> Maybe (InitOrFini, [CLabel])
isInitOrFiniArray (Section -> RawCmmStatics -> RawCmmDecl
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sect RawCmmStatics
statics)
= let var :: LMString
var = case InitOrFini
initOrFini of
InitOrFini
IsInitArray -> String -> LMString
fsLit String
"llvm.global_ctors"
InitOrFini
IsFiniArray -> String -> LMString
fsLit String
"llvm.global_dtors"
in LMString -> [CLabel] -> LlvmM LlvmData
genGlobalLabelArray LMString
var [CLabel]
clbls
genLlvmData (Section
sec, CmmStaticsRaw CLabel
lbl [CmmStatic]
xs) = do
label <- CLabel -> LlvmM LMString
strCLabel_llvm CLabel
lbl
static <- mapM genData xs
lmsec <- llvmSection sec
platform <- getPlatform
let types = (LlvmStatic -> LlvmType) -> [LlvmStatic] -> [LlvmType]
forall a b. (a -> b) -> [a] -> [b]
map LlvmStatic -> LlvmType
getStatType [LlvmStatic]
static
strucTy = [LlvmType] -> LlvmType
LMStruct [LlvmType]
types
tyAlias = LlvmAlias -> LlvmType
LMAlias (LMString
label LMString -> LMString -> LMString
`appendFS` LMString
structStr, LlvmType
strucTy)
struct = LlvmStatic -> Maybe LlvmStatic
forall a. a -> Maybe a
Just (LlvmStatic -> Maybe LlvmStatic) -> LlvmStatic -> Maybe LlvmStatic
forall a b. (a -> b) -> a -> b
$ [LlvmStatic] -> LlvmType -> LlvmStatic
LMStaticStruc [LlvmStatic]
static LlvmType
tyAlias
link = CLabel -> LlvmLinkageType
linkage CLabel
lbl
align = case Section
sec of
Section SectionType
CString CLabel
_ -> if (Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchS390X)
then Int -> LMAlign
forall a. a -> Maybe a
Just Int
2 else Int -> LMAlign
forall a. a -> Maybe a
Just Int
1
Section SectionType
Data CLabel
_ -> Int -> LMAlign
forall a. a -> Maybe a
Just (Int -> LMAlign) -> Int -> LMAlign
forall a b. (a -> b) -> a -> b
$ Platform -> Int
platformWordSizeInBytes Platform
platform
Section
_ -> LMAlign
forall a. Maybe a
Nothing
const = if Section -> SectionProtection
sectionProtection Section
sec SectionProtection -> SectionProtection -> Bool
forall a. Eq a => a -> a -> Bool
== SectionProtection
ReadOnlySection
then LMConst
Constant else LMConst
Global
varDef = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
label LlvmType
tyAlias LlvmLinkageType
link LMSection
lmsec LMAlign
align LMConst
const
globDef = LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal LlvmVar
varDef Maybe LlvmStatic
struct
return ([globDef], [tyAlias])
genGlobalLabelArray :: FastString -> [CLabel] -> LlvmM LlvmData
genGlobalLabelArray :: LMString -> [CLabel] -> LlvmM LlvmData
genGlobalLabelArray LMString
var_nm [CLabel]
clbls = do
lbls <- (CLabel -> LlvmM LMString) -> [CLabel] -> LlvmM [LMString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CLabel -> LlvmM LMString
strCLabel_llvm [CLabel]
clbls
decls <- mapM mkFunDecl lbls
let entries = (LMString -> LlvmStatic) -> [LMString] -> [LlvmStatic]
forall a b. (a -> b) -> [a] -> [b]
map LMString -> LlvmStatic
toArrayEntry [LMString]
lbls
static = [LlvmStatic] -> LlvmType -> LlvmStatic
LMStaticArray [LlvmStatic]
entries LlvmType
arr_ty
arr = LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal LlvmVar
arr_var (LlvmStatic -> Maybe LlvmStatic
forall a. a -> Maybe a
Just LlvmStatic
static)
return ([arr], decls)
where
mkFunDecl :: LMString -> LlvmM LlvmType
mkFunDecl :: LMString -> LlvmM LlvmType
mkFunDecl LMString
fn_lbl = do
let fn_ty :: LlvmType
fn_ty = LMString -> LlvmType
mkFunTy LMString
fn_lbl
LMString -> LlvmType -> LlvmM ()
forall key. Uniquable key => key -> LlvmType -> LlvmM ()
funInsert LMString
fn_lbl LlvmType
fn_ty
LlvmType -> LlvmM LlvmType
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmType
fn_ty)
toArrayEntry :: LMString -> LlvmStatic
toArrayEntry :: LMString -> LlvmStatic
toArrayEntry LMString
fn_lbl =
let fn_var :: LlvmVar
fn_var = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
fn_lbl (LlvmType -> LlvmType
LMPointer (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LMString -> LlvmType
mkFunTy LMString
fn_lbl) LlvmLinkageType
Internal LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Global
fn :: LlvmStatic
fn = LlvmVar -> LlvmStatic
LMStaticPointer LlvmVar
fn_var
null :: LlvmStatic
null = LlvmLit -> LlvmStatic
LMStaticLit (LlvmType -> LlvmLit
LMNullLit LlvmType
i8Ptr)
prio :: LlvmStatic
prio = LlvmLit -> LlvmStatic
LMStaticLit (LlvmLit -> LlvmStatic) -> LlvmLit -> LlvmStatic
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit Integer
0xffff LlvmType
i32
in [LlvmStatic] -> LlvmType -> LlvmStatic
LMStaticStrucU [LlvmStatic
prio, LlvmStatic
fn, LlvmStatic
null] LlvmType
entry_ty
arr_var :: LlvmVar
arr_var = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
var_nm LlvmType
arr_ty LlvmLinkageType
Internal LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Global
mkFunTy :: LMString -> LlvmType
mkFunTy LMString
lbl = LlvmFunctionDecl -> LlvmType
LMFunction (LlvmFunctionDecl -> LlvmType) -> LlvmFunctionDecl -> LlvmType
forall a b. (a -> b) -> a -> b
$ LMString
-> LlvmLinkageType
-> LlvmCallConvention
-> LlvmType
-> LlvmParameterListType
-> [LlvmParameter]
-> LMAlign
-> LlvmFunctionDecl
LlvmFunctionDecl LMString
lbl LlvmLinkageType
ExternallyVisible LlvmCallConvention
CC_Ccc LlvmType
LMVoid LlvmParameterListType
FixedArgs [] LMAlign
forall a. Maybe a
Nothing
entry_ty :: LlvmType
entry_ty = [LlvmType] -> LlvmType
LMStructU [LlvmType
i32, LlvmType -> LlvmType
LMPointer (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LMString -> LlvmType
mkFunTy (LMString -> LlvmType) -> LMString -> LlvmType
forall a b. (a -> b) -> a -> b
$ String -> LMString
fsLit String
"placeholder", LlvmType -> LlvmType
LMPointer LlvmType
i8]
arr_ty :: LlvmType
arr_ty = Int -> LlvmType -> LlvmType
LMArray ([CLabel] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CLabel]
clbls) LlvmType
entry_ty
llvmSectionType :: Platform -> SectionType -> FastString
llvmSectionType :: Platform -> SectionType -> LMString
llvmSectionType Platform
p SectionType
t = case SectionType
t of
SectionType
Text -> String -> LMString
fsLit String
".text"
SectionType
ReadOnlyData -> case Platform -> OS
platformOS Platform
p of
OS
OSMinGW32 -> String -> LMString
fsLit String
".rdata"
OS
_ -> String -> LMString
fsLit String
".rodata"
SectionType
RelocatableReadOnlyData -> case Platform -> OS
platformOS Platform
p of
OS
OSMinGW32 -> String -> LMString
fsLit String
".rdata$rel.ro"
OS
_ -> String -> LMString
fsLit String
".data.rel.ro"
SectionType
Data -> String -> LMString
fsLit String
".data"
SectionType
UninitialisedData -> String -> LMString
fsLit String
".bss"
SectionType
CString -> case Platform -> OS
platformOS Platform
p of
OS
OSMinGW32 -> String -> LMString
fsLit String
".rdata$str"
OS
_ -> String -> LMString
fsLit String
".rodata.str"
SectionType
InitArray -> String -> LMString
forall a. HasCallStack => String -> a
panic String
"llvmSectionType: InitArray"
SectionType
FiniArray -> String -> LMString
forall a. HasCallStack => String -> a
panic String
"llvmSectionType: FiniArray"
OtherSection String
_ -> String -> LMString
forall a. HasCallStack => String -> a
panic String
"llvmSectionType: unknown section type"
llvmSection :: Section -> LlvmM LMSection
llvmSection :: Section -> LlvmM LMSection
llvmSection (Section SectionType
t CLabel
suffix) = do
opts <- LlvmM LlvmCgConfig
getConfig
let splitSect = LlvmCgConfig -> Bool
llvmCgSplitSection LlvmCgConfig
opts
platform = LlvmCgConfig -> Platform
llvmCgPlatform LlvmCgConfig
opts
if not splitSect
then return Nothing
else do
lmsuffix <- strCLabel_llvm suffix
let result String
sep = LMString -> LMSection
forall a. a -> Maybe a
Just ([LMString] -> LMString
concatFS [Platform -> SectionType -> LMString
llvmSectionType Platform
platform SectionType
t
, String -> LMString
fsLit String
sep, LMString
lmsuffix])
case platformOS platform of
OS
OSMinGW32 -> LMSection -> LlvmM LMSection
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> LMSection
result String
"$")
OS
_ -> LMSection -> LlvmM LMSection
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> LMSection
result String
".")
genData :: CmmStatic -> LlvmM LlvmStatic
genData :: CmmStatic -> LlvmM LlvmStatic
genData (CmmFileEmbed {}) = String -> LlvmM LlvmStatic
forall a. HasCallStack => String -> a
panic String
"Unexpected CmmFileEmbed literal"
genData (CmmString ByteString
str) = do
let v :: [LlvmStatic]
v = (Word8 -> LlvmStatic) -> [Word8] -> [LlvmStatic]
forall a b. (a -> b) -> [a] -> [b]
map (\Word8
x -> LlvmLit -> LlvmStatic
LMStaticLit (LlvmLit -> LlvmStatic) -> LlvmLit -> LlvmStatic
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x) LlvmType
i8)
(ByteString -> [Word8]
BS.unpack ByteString
str)
ve :: [LlvmStatic]
ve = [LlvmStatic]
v [LlvmStatic] -> [LlvmStatic] -> [LlvmStatic]
forall a. [a] -> [a] -> [a]
++ [LlvmLit -> LlvmStatic
LMStaticLit (LlvmLit -> LlvmStatic) -> LlvmLit -> LlvmStatic
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit Integer
0 LlvmType
i8]
LlvmStatic -> LlvmM LlvmStatic
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatic -> LlvmM LlvmStatic) -> LlvmStatic -> LlvmM LlvmStatic
forall a b. (a -> b) -> a -> b
$ [LlvmStatic] -> LlvmType -> LlvmStatic
LMStaticArray [LlvmStatic]
ve (Int -> LlvmType -> LlvmType
LMArray ([LlvmStatic] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LlvmStatic]
ve) LlvmType
i8)
genData (CmmUninitialised Int
bytes)
= LlvmStatic -> LlvmM LlvmStatic
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatic -> LlvmM LlvmStatic) -> LlvmStatic -> LlvmM LlvmStatic
forall a b. (a -> b) -> a -> b
$ LlvmType -> LlvmStatic
LMUninitType (Int -> LlvmType -> LlvmType
LMArray Int
bytes LlvmType
i8)
genData (CmmStaticLit CmmLit
lit)
= CmmLit -> LlvmM LlvmStatic
genStaticLit CmmLit
lit
genStaticLit :: CmmLit -> LlvmM LlvmStatic
genStaticLit :: CmmLit -> LlvmM LlvmStatic
genStaticLit (CmmInt Integer
i Width
w)
= LlvmStatic -> LlvmM LlvmStatic
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatic -> LlvmM LlvmStatic) -> LlvmStatic -> LlvmM LlvmStatic
forall a b. (a -> b) -> a -> b
$ LlvmLit -> LlvmStatic
LMStaticLit (Integer -> LlvmType -> LlvmLit
LMIntLit Integer
i (Int -> LlvmType
LMInt (Int -> LlvmType) -> Int -> LlvmType
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits Width
w))
genStaticLit (CmmFloat Rational
r Width
w)
= LlvmStatic -> LlvmM LlvmStatic
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatic -> LlvmM LlvmStatic) -> LlvmStatic -> LlvmM LlvmStatic
forall a b. (a -> b) -> a -> b
$ LlvmLit -> LlvmStatic
LMStaticLit (Double -> LlvmType -> LlvmLit
LMFloatLit (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r) (Width -> LlvmType
widthToLlvmFloat Width
w))
genStaticLit (CmmVec [CmmLit]
ls)
= do sls <- (CmmLit -> LlvmM LlvmLit) -> [CmmLit] -> LlvmM [LlvmLit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmLit -> LlvmM LlvmLit
toLlvmLit [CmmLit]
ls
return $ LMStaticLit (LMVectorLit sls)
where
toLlvmLit :: CmmLit -> LlvmM LlvmLit
toLlvmLit :: CmmLit -> LlvmM LlvmLit
toLlvmLit CmmLit
lit = do
slit <- CmmLit -> LlvmM LlvmStatic
genStaticLit CmmLit
lit
case slit of
LMStaticLit LlvmLit
llvmLit -> LlvmLit -> LlvmM LlvmLit
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return LlvmLit
llvmLit
LlvmStatic
_ -> String -> LlvmM LlvmLit
forall a. HasCallStack => String -> a
panic String
"genStaticLit"
genStaticLit cmm :: CmmLit
cmm@(CmmLabel CLabel
l) = do
var <- LMString -> LlvmM LlvmVar
getGlobalPtr (LMString -> LlvmM LlvmVar) -> LlvmM LMString -> LlvmM LlvmVar
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CLabel -> LlvmM LMString
strCLabel_llvm CLabel
l
platform <- getPlatform
let ptr = LlvmVar -> LlvmStatic
LMStaticPointer LlvmVar
var
lmty = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
cmm
return $ LMPtoI ptr lmty
genStaticLit (CmmLabelOff CLabel
label Int
off) = do
platform <- LlvmM Platform
getPlatform
var <- genStaticLit (CmmLabel label)
let offset = LlvmLit -> LlvmStatic
LMStaticLit (LlvmLit -> LlvmStatic) -> LlvmLit -> LlvmStatic
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
off) (Platform -> LlvmType
llvmWord Platform
platform)
return $ LMAdd var offset
genStaticLit (CmmLabelDiffOff CLabel
l1 CLabel
l2 Int
off Width
w) = do
platform <- LlvmM Platform
getPlatform
var1 <- genStaticLit (CmmLabel l1)
var2 <- genStaticLit (CmmLabel l2)
let var
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = LlvmStatic -> LlvmStatic -> LlvmStatic
LMSub LlvmStatic
var1 LlvmStatic
var2
| Bool
otherwise = LlvmStatic -> LlvmType -> LlvmStatic
LMTrunc (LlvmStatic -> LlvmStatic -> LlvmStatic
LMSub LlvmStatic
var1 LlvmStatic
var2) (Width -> LlvmType
widthToLlvmInt Width
w)
offset = LlvmLit -> LlvmStatic
LMStaticLit (LlvmLit -> LlvmStatic) -> LlvmLit -> LlvmStatic
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
off) (Int -> LlvmType
LMInt (Int -> LlvmType) -> Int -> LlvmType
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits Width
w)
return $ LMAdd var offset
genStaticLit (CmmBlock BlockId
b) = CmmLit -> LlvmM LlvmStatic
genStaticLit (CmmLit -> LlvmM LlvmStatic) -> CmmLit -> LlvmM LlvmStatic
forall a b. (a -> b) -> a -> b
$ CLabel -> CmmLit
CmmLabel (CLabel -> CmmLit) -> CLabel -> CmmLit
forall a b. (a -> b) -> a -> b
$ BlockId -> CLabel
infoTblLbl BlockId
b
genStaticLit (CmmLit
CmmHighStackMark)
= String -> LlvmM LlvmStatic
forall a. HasCallStack => String -> a
panic String
"genStaticLit: CmmHighStackMark unsupported!"