{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-}
module GHC.CmmToLlvm
( LlvmVersion
, llvmVersionList
, llvmCodeGen
, llvmFixupAsm
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Llvm
import GHC.CmmToLlvm.Base
import GHC.CmmToLlvm.CodeGen
import GHC.CmmToLlvm.Data
import GHC.CmmToLlvm.Ppr
import GHC.CmmToLlvm.Regs
import GHC.CmmToLlvm.Mangler
import GHC.StgToCmm.CgUtils ( fixStgRegisters )
import GHC.Cmm
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Ppr
import GHC.Utils.BufHandle
import GHC.Driver.Session
import GHC.Platform ( platformArch, Arch(..) )
import GHC.Utils.Error
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.SysTools ( figureLlvmVersion )
import qualified GHC.Data.Stream as Stream
import Control.Monad ( when, forM_ )
import Data.Maybe ( fromMaybe, catMaybes )
import System.IO
llvmCodeGen :: Logger -> DynFlags -> Handle
-> Stream.Stream IO RawCmmGroup a
-> IO a
llvmCodeGen :: forall a.
Logger -> DynFlags -> Handle -> Stream IO RawCmmGroup a -> IO a
llvmCodeGen Logger
logger DynFlags
dflags Handle
h Stream IO RawCmmGroup a
cmm_stream
= forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags (String -> SDoc
text String
"LLVM CodeGen") (forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ do
BufHandle
bufh <- Handle -> IO BufHandle
newBufHandle Handle
h
Logger -> DynFlags -> String -> IO ()
showPass Logger
logger DynFlags
dflags String
"LLVM CodeGen"
Maybe LlvmVersion
mb_ver <- Logger -> DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion Logger
logger DynFlags
dflags
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe LlvmVersion
mb_ver forall a b. (a -> b) -> a -> b
$ \LlvmVersion
ver -> do
Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2
(String -> SDoc
text String
"Using LLVM version:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver))
let doWarn :: Bool
doWarn = WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnsupportedLlvmVersion DynFlags
dflags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (LlvmVersion -> Bool
llvmVersionSupported LlvmVersion
ver) Bool -> Bool -> Bool
&& Bool
doWarn) forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$
SDoc
"You are using an unsupported version of LLVM!" SDoc -> SDoc -> SDoc
$$
SDoc
"Currently only" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersionLowerBound) SDoc -> SDoc -> SDoc
<+>
SDoc
"to" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersionUpperBound) SDoc -> SDoc -> SDoc
<+> SDoc
"is supported." SDoc -> SDoc -> SDoc
<+>
SDoc
"System LLVM version: " SDoc -> SDoc -> SDoc
<> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver) SDoc -> SDoc -> SDoc
$$
SDoc
"We will try though..."
let isS390X :: Bool
isS390X = Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) forall a. Eq a => a -> a -> Bool
== Arch
ArchS390X
let major_ver :: Int
major_ver = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVersion -> [Int]
llvmVersionList forall a b. (a -> b) -> a -> b
$ LlvmVersion
ver
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isS390X Bool -> Bool -> Bool
&& Int
major_ver forall a. Ord a => a -> a -> Bool
< Int
10 Bool -> Bool -> Bool
&& Bool
doWarn) forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$
SDoc
"Warning: For s390x the GHC calling convention is only supported since LLVM version 10." SDoc -> SDoc -> SDoc
<+>
SDoc
"You are using LLVM version: " SDoc -> SDoc -> SDoc
<> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver)
let llvm_ver :: LlvmVersion
llvm_ver :: LlvmVersion
llvm_ver = forall a. a -> Maybe a -> a
fromMaybe LlvmVersion
supportedLlvmVersionLowerBound Maybe LlvmVersion
mb_ver
a
a <- forall a.
Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
runLlvm Logger
logger DynFlags
dflags LlvmVersion
llvm_ver BufHandle
bufh forall a b. (a -> b) -> a -> b
$
forall a. DynFlags -> Stream IO RawCmmGroup a -> LlvmM a
llvmCodeGen' DynFlags
dflags Stream IO RawCmmGroup a
cmm_stream
BufHandle -> IO ()
bFlush BufHandle
bufh
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
llvmCodeGen' :: DynFlags -> Stream.Stream IO RawCmmGroup a -> LlvmM a
llvmCodeGen' :: forall a. DynFlags -> Stream IO RawCmmGroup a -> LlvmM a
llvmCodeGen' DynFlags
dflags Stream IO RawCmmGroup a
cmm_stream
= do
SDoc -> LlvmM ()
renderLlvm SDoc
header
LlvmM ()
ghcInternalFunctions
LlvmM ()
cmmMetaLlvmPrelude
a
a <- forall (m :: * -> *) (n :: * -> *) a b.
(Monad m, Monad n) =>
Stream m a b -> (forall a1. m a1 -> n a1) -> (a -> n ()) -> n b
Stream.consume Stream IO RawCmmGroup a
cmm_stream forall a. IO a -> LlvmM a
liftIO RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens
LlvmOpts
opts <- LlvmM LlvmOpts
getLlvmOpts
SDoc -> LlvmM ()
renderLlvm forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmOpts -> LlvmData -> SDoc
pprLlvmData LlvmOpts
opts forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LlvmM LlvmData
generateExternDecls
LlvmM ()
cmmUsedLlvmGens
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
where
header :: SDoc
header :: SDoc
header =
let target :: String
target = PlatformMisc -> String
platformMisc_llvmTarget forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
in String -> SDoc
text (String
"target datalayout = \"" forall a. [a] -> [a] -> [a]
++ LlvmConfig -> String -> String
getDataLayout (DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags) String
target forall a. [a] -> [a] -> [a]
++ String
"\"")
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text (String
"target triple = \"" forall a. [a] -> [a] -> [a]
++ String
target forall a. [a] -> [a] -> [a]
++ String
"\"")
getDataLayout :: LlvmConfig -> String -> String
getDataLayout :: LlvmConfig -> String -> String
getDataLayout LlvmConfig
config String
target =
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
target (LlvmConfig -> [(String, LlvmTarget)]
llvmTargets LlvmConfig
config) of
Just (LlvmTarget {lDataLayout :: LlvmTarget -> String
lDataLayout=String
dl}) -> String
dl
Maybe LlvmTarget
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Failed to lookup LLVM data layout" forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Target:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
target SDoc -> SDoc -> SDoc
$$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Available targets:") Int
4
([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String -> SDoc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ LlvmConfig -> [(String, LlvmTarget)]
llvmTargets LlvmConfig
config)
llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens RawCmmGroup
cmm = do
let split :: GenCmmDecl b (map RawCmmStatics) (GenCmmGraph n)
-> LlvmM (Maybe (Section, b))
split (CmmData Section
s b
d' ) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Section
s, b
d')
split (CmmProc map RawCmmStatics
h CLabel
l [GlobalReg]
live GenCmmGraph n
g) = do
let l' :: CLabel
l' = case forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry GenCmmGraph n
g) map RawCmmStatics
h :: Maybe RawCmmStatics of
Maybe RawCmmStatics
Nothing -> CLabel
l
Just (CmmStaticsRaw CLabel
info_lbl [CmmStatic]
_) -> CLabel
info_lbl
LMString
lml <- CLabel -> LlvmM LMString
strCLabel_llvm CLabel
l'
forall key. Uniquable key => key -> LlvmType -> LlvmM ()
funInsert LMString
lml forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [GlobalReg] -> LlvmM LlvmType
llvmFunTy [GlobalReg]
live
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
[(Section, RawCmmStatics)]
cdata <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {map :: * -> *} {b}
{n :: Extensibility -> Extensibility -> *}.
(KeyOf map ~ Label, IsMap map) =>
GenCmmDecl b (map RawCmmStatics) (GenCmmGraph n)
-> LlvmM (Maybe (Section, b))
split RawCmmGroup
cmm
{-# SCC "llvm_datas_gen" #-}
[(Section, RawCmmStatics)] -> LlvmM ()
cmmDataLlvmGens [(Section, RawCmmStatics)]
cdata
{-# SCC "llvm_procs_gen" #-}
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RawCmmDecl -> LlvmM ()
cmmLlvmGen RawCmmGroup
cmm
cmmDataLlvmGens :: [(Section,RawCmmStatics)] -> LlvmM ()
cmmDataLlvmGens :: [(Section, RawCmmStatics)] -> LlvmM ()
cmmDataLlvmGens [(Section, RawCmmStatics)]
statics
= do [LlvmData]
lmdatas <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Section, RawCmmStatics) -> LlvmM LlvmData
genLlvmData [(Section, RawCmmStatics)]
statics
let (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> [LMGlobal]
gs, [[LlvmType]]
tss) = forall a b. [(a, b)] -> ([a], [b])
unzip [LlvmData]
lmdatas
let regGlobal :: LMGlobal -> LlvmM ()
regGlobal (LMGlobal (LMGlobalVar LMString
l LlvmType
ty LlvmLinkageType
_ LMSection
_ LMAlign
_ LMConst
_) Maybe LlvmStatic
_)
= forall key. Uniquable key => key -> LlvmType -> LlvmM ()
funInsert LMString
l LlvmType
ty
regGlobal LMGlobal
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LMGlobal -> LlvmM ()
regGlobal [LMGlobal]
gs
[[LMGlobal]]
gss' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LMGlobal -> LlvmM [LMGlobal]
aliasify forall a b. (a -> b) -> a -> b
$ [LMGlobal]
gs
LlvmOpts
opts <- LlvmM LlvmOpts
getLlvmOpts
SDoc -> LlvmM ()
renderLlvm forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmData -> SDoc
pprLlvmData LlvmOpts
opts (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LMGlobal]]
gss', forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LlvmType]]
tss)
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
cmmLlvmGen :: RawCmmDecl -> LlvmM ()
cmmLlvmGen cmm :: RawCmmDecl
cmm@CmmProc{} = do
Platform
platform <- LlvmM Platform
getPlatform
let fixed_cmm :: RawCmmDecl
fixed_cmm = {-# SCC "llvm_fix_regs" #-} Platform -> RawCmmDecl -> RawCmmDecl
fixStgRegisters Platform
platform RawCmmDecl
cmm
DumpFlag -> String -> DumpFormat -> SDoc -> LlvmM ()
dumpIfSetLlvm DumpFlag
Opt_D_dump_opt_cmm String
"Optimised Cmm"
DumpFormat
FormatCMM (forall d info g.
(OutputableP Platform d, OutputableP Platform info,
OutputableP Platform g) =>
Platform -> GenCmmGroup d info g -> SDoc
pprCmmGroup Platform
platform [RawCmmDecl
fixed_cmm])
[LlvmCmmDecl]
llvmBC <- forall a. LlvmM a -> LlvmM a
withClearVars forall a b. (a -> b) -> a -> b
$ RawCmmDecl -> LlvmM [LlvmCmmDecl]
genLlvmProc RawCmmDecl
fixed_cmm
([SDoc]
docs, [[LlvmVar]]
ivars) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
pprLlvmCmmDecl [LlvmCmmDecl]
llvmBC
SDoc -> LlvmM ()
renderLlvm ([SDoc] -> SDoc
vcat [SDoc]
docs)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LlvmVar -> LlvmM ()
markUsedVar forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LlvmVar]]
ivars
cmmLlvmGen RawCmmDecl
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
cmmMetaLlvmPrelude :: LlvmM ()
cmmMetaLlvmPrelude :: LlvmM ()
cmmMetaLlvmPrelude = do
[MetaDecl]
metas <- 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 [(Unique, LMString, Maybe Unique)]
stgTBAA forall a b. (a -> b) -> a -> b
$ \(Unique
uniq, LMString
name, Maybe Unique
parent) -> do
MetaId
tbaaId <- LlvmM MetaId
getMetaUniqueId
Unique -> MetaId -> LlvmM ()
setUniqMeta Unique
uniq MetaId
tbaaId
Maybe MetaId
parentId <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) Unique -> LlvmM (Maybe MetaId)
getUniqMeta Maybe Unique
parent
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MetaId -> MetaExpr -> MetaDecl
MetaUnnamed MetaId
tbaaId forall a b. (a -> b) -> a -> b
$ [MetaExpr] -> MetaExpr
MetaStruct forall a b. (a -> b) -> a -> b
$
case Maybe MetaId
parentId of
Just MetaId
p -> [ LMString -> MetaExpr
MetaStr LMString
name, MetaId -> MetaExpr
MetaNode MetaId
p ]
Maybe MetaId
Nothing -> [ LMString -> MetaExpr
MetaStr LMString
name ]
LlvmOpts
opts <- LlvmM LlvmOpts
getLlvmOpts
SDoc -> LlvmM ()
renderLlvm forall a b. (a -> b) -> a -> b
$ LlvmOpts -> [MetaDecl] -> SDoc
ppLlvmMetas LlvmOpts
opts [MetaDecl]
metas
cmmUsedLlvmGens :: LlvmM ()
cmmUsedLlvmGens :: LlvmM ()
cmmUsedLlvmGens = do
[LlvmVar]
ivars <- LlvmM [LlvmVar]
getUsedVars
let cast :: LlvmVar -> LlvmStatic
cast LlvmVar
x = LlvmStatic -> LlvmType -> LlvmStatic
LMBitc (LlvmVar -> LlvmStatic
LMStaticPointer (LlvmVar -> LlvmVar
pVarLift LlvmVar
x)) LlvmType
i8Ptr
ty :: LlvmType
ty = (Int -> LlvmType -> LlvmType
LMArray (forall (t :: * -> *) a. Foldable t => t a -> Int
length [LlvmVar]
ivars) LlvmType
i8Ptr)
usedArray :: LlvmStatic
usedArray = [LlvmStatic] -> LlvmType -> LlvmStatic
LMStaticArray (forall a b. (a -> b) -> [a] -> [b]
map LlvmVar -> LlvmStatic
cast [LlvmVar]
ivars) LlvmType
ty
sectName :: LMSection
sectName = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> LMString
fsLit String
"llvm.metadata"
lmUsedVar :: LlvmVar
lmUsedVar = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar (String -> LMString
fsLit String
"llvm.used") LlvmType
ty LlvmLinkageType
Appending LMSection
sectName forall a. Maybe a
Nothing LMConst
Constant
lmUsed :: LMGlobal
lmUsed = LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal LlvmVar
lmUsedVar (forall a. a -> Maybe a
Just LlvmStatic
usedArray)
LlvmOpts
opts <- LlvmM LlvmOpts
getLlvmOpts
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LlvmVar]
ivars
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else SDoc -> LlvmM ()
renderLlvm forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmData -> SDoc
pprLlvmData LlvmOpts
opts ([LMGlobal
lmUsed], [])