summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authordoyougnu <jeffrey.young@iohk.io>2021-12-08 12:29:07 -0800
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-12-14 20:55:06 -0500
commitecaec722850cce498b67561708ee8e42df367dda (patch)
tree98eb6c505702858c4663bda1c3f2ec2635df853d /compiler
parent0198bb1190ffc4ac4963140e81cacd72721eab07 (diff)
downloadhaskell-ecaec722850cce498b67561708ee8e42df367dda.tar.gz
CmmToLlvm: Remove DynFlags, add LlvmCgConfig
CodeOutput: LCGConfig, add handshake initLCGConfig Add two modules: GHC.CmmToLlvm.Config -- to hold the Llvm code gen config GHC.Driver.Config.CmmToLlvm -- for initialization, other utils CmmToLlvm: remove HasDynFlags, add LlvmConfig CmmToLlvm: add lcgContext to LCGConfig CmmToLlvm.Base: DynFlags --> LCGConfig Llvm: absorb LlvmOpts into LCGConfig CmmToLlvm.Ppr: swap DynFlags --> LCGConfig CmmToLlvm.CodeGen: swap DynFlags --> LCGConfig CmmToLlvm.CodeGen: swap DynFlags --> LCGConfig CmmToLlvm.Data: swap LlvmOpts --> LCGConfig CmmToLlvm: swap DynFlags --> LCGConfig CmmToLlvm: move LlvmVersion to CmmToLlvm.Config Additionally: - refactor Config and initConfig to hold LlvmVersion - push IO needed to get LlvmVersion to boundary between Cmm and LLvm code generation - remove redundant imports, this is much cleaner! CmmToLlvm.Config: store platformMisc_llvmTarget instead of all of platformMisc
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/CmmToLlvm.hs41
-rw-r--r--compiler/GHC/CmmToLlvm/Base.hs83
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs127
-rw-r--r--compiler/GHC/CmmToLlvm/Config.hs30
-rw-r--r--compiler/GHC/CmmToLlvm/Data.hs7
-rw-r--r--compiler/GHC/CmmToLlvm/Ppr.hs22
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs10
-rw-r--r--compiler/GHC/Driver/Config/CmmToLlvm.hs30
-rw-r--r--compiler/GHC/Llvm.hs3
-rw-r--r--compiler/GHC/Llvm/Ppr.hs106
-rw-r--r--compiler/GHC/Llvm/Types.hs15
-rw-r--r--compiler/GHC/SysTools/Tasks.hs1
-rw-r--r--compiler/ghc.cabal.in2
13 files changed, 251 insertions, 226 deletions
diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs
index 11079c2cf2..ea37099d7f 100644
--- a/compiler/GHC/CmmToLlvm.hs
+++ b/compiler/GHC/CmmToLlvm.hs
@@ -16,6 +16,7 @@ import GHC.Prelude
import GHC.Llvm
import GHC.CmmToLlvm.Base
import GHC.CmmToLlvm.CodeGen
+import GHC.CmmToLlvm.Config
import GHC.CmmToLlvm.Data
import GHC.CmmToLlvm.Ppr
import GHC.CmmToLlvm.Regs
@@ -34,7 +35,6 @@ 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_ )
@@ -44,10 +44,10 @@ import System.IO
-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM Code generator
--
-llvmCodeGen :: Logger -> DynFlags -> Handle
+llvmCodeGen :: Logger -> LCGConfig -> Handle
-> Stream.Stream IO RawCmmGroup a
-> IO a
-llvmCodeGen logger dflags h cmm_stream
+llvmCodeGen logger cfg h cmm_stream
= withTiming logger (text "LLVM CodeGen") (const ()) $ do
bufh <- newBufHandle h
@@ -55,20 +55,20 @@ llvmCodeGen logger dflags h cmm_stream
showPass logger "LLVM CodeGen"
-- get llvm version, cache for later use
- mb_ver <- figureLlvmVersion logger dflags
+ let mb_ver = lcgLlvmVersion cfg
-- warn if unsupported
forM_ mb_ver $ \ver -> do
debugTraceMsg logger 2
(text "Using LLVM version:" <+> text (llvmVersionStr ver))
- let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
+ let doWarn = lcgDoWarn cfg
when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $
"You are using an unsupported version of LLVM!" $$
"Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+>
"to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+>
"System LLVM version: " <> text (llvmVersionStr ver) $$
"We will try though..."
- let isS390X = platformArch (targetPlatform dflags) == ArchS390X
+ let isS390X = platformArch (lcgPlatform cfg) == ArchS390X
let major_ver = head . llvmVersionList $ ver
when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $
"Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>
@@ -81,15 +81,15 @@ llvmCodeGen logger dflags h cmm_stream
llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver
-- run code generation
- a <- runLlvm logger dflags llvm_ver bufh $
- llvmCodeGen' dflags cmm_stream
+ a <- runLlvm logger cfg llvm_ver bufh $
+ llvmCodeGen' cfg cmm_stream
bFlush bufh
return a
-llvmCodeGen' :: DynFlags -> Stream.Stream IO RawCmmGroup a -> LlvmM a
-llvmCodeGen' dflags cmm_stream
+llvmCodeGen' :: LCGConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a
+llvmCodeGen' cfg cmm_stream
= do -- Preamble
renderLlvm header
ghcInternalFunctions
@@ -99,8 +99,7 @@ llvmCodeGen' dflags cmm_stream
a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens
-- Declare aliases for forward references
- opts <- getLlvmOpts
- renderLlvm . pprLlvmData opts =<< generateExternDecls
+ renderLlvm . pprLlvmData cfg =<< generateExternDecls
-- Postamble
cmmUsedLlvmGens
@@ -109,8 +108,9 @@ llvmCodeGen' dflags cmm_stream
where
header :: SDoc
header =
- let target = platformMisc_llvmTarget $ platformMisc dflags
- in text ("target datalayout = \"" ++ getDataLayout (llvmConfig dflags) target ++ "\"")
+ let target = lcgPlatformMisc cfg
+ llvmCfg = lcgLlvmConfig cfg
+ in text ("target datalayout = \"" ++ getDataLayout llvmCfg target ++ "\"")
$+$ text ("target triple = \"" ++ target ++ "\"")
getDataLayout :: LlvmConfig -> String -> String
@@ -158,8 +158,8 @@ cmmDataLlvmGens statics
mapM_ regGlobal gs
gss' <- mapM aliasify $ gs
- opts <- getLlvmOpts
- renderLlvm $ pprLlvmData opts (concat gss', concat tss)
+ cfg <- getConfig
+ renderLlvm $ pprLlvmData cfg (concat gss', concat tss)
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
@@ -203,8 +203,8 @@ cmmMetaLlvmPrelude = do
-- just a name on its own. Previously `null` was accepted as the
-- name.
Nothing -> [ MetaStr name ]
- opts <- getLlvmOpts
- renderLlvm $ ppLlvmMetas opts metas
+ cfg <- getConfig
+ renderLlvm $ ppLlvmMetas cfg metas
-- -----------------------------------------------------------------------------
-- | Marks variables as used where necessary
@@ -222,12 +222,11 @@ cmmUsedLlvmGens = do
-- Which is the LLVM way of protecting them against getting removed.
ivars <- getUsedVars
let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
- ty = (LMArray (length ivars) i8Ptr)
+ ty = LMArray (length ivars) i8Ptr
usedArray = LMStaticArray (map cast ivars) ty
sectName = Just $ fsLit "llvm.metadata"
lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
lmUsed = LMGlobal lmUsedVar (Just usedArray)
- opts <- getLlvmOpts
if null ivars
then return ()
- else renderLlvm $ pprLlvmData opts ([lmUsed], [])
+ else getConfig >>= renderLlvm . flip pprLlvmData ([lmUsed], [])
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index 33798acf72..1fb1b616cc 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -22,9 +22,9 @@ module GHC.CmmToLlvm.Base (
LlvmM,
runLlvm, withClearVars, varLookup, varInsert,
markStackReg, checkStackReg,
- funLookup, funInsert, getLlvmVer, getDynFlags,
+ funLookup, funInsert, getLlvmVer,
dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
- ghcInternalFunctions, getPlatform, getLlvmOpts,
+ ghcInternalFunctions, getPlatform, getConfig,
getMetaUniqueId,
setUniqMeta, getUniqMeta, liftIO,
@@ -46,6 +46,7 @@ import GHC.Utils.Panic
import GHC.Llvm
import GHC.CmmToLlvm.Regs
+import GHC.CmmToLlvm.Config
import GHC.Cmm.CLabel
import GHC.Cmm.Ppr.Expr ()
@@ -149,10 +150,10 @@ llvmInfAlign :: Platform -> LMAlign
llvmInfAlign platform = Just (platformWordSizeInBytes platform)
-- | Section to use for a function
-llvmFunSection :: LlvmOpts -> LMString -> LMSection
+llvmFunSection :: LCGConfig -> LMString -> LMSection
llvmFunSection opts lbl
- | llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])
- | otherwise = Nothing
+ | lcgSplitSections opts = Just (concatFS [fsLit ".text.", lbl])
+ | otherwise = Nothing
-- | A Function's arguments
llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
@@ -263,9 +264,6 @@ llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform
-- * Llvm Version
--
-newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }
- deriving (Eq, Ord)
-
parseLlvmVersion :: String -> Maybe LlvmVersion
parseLlvmVersion =
fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)
@@ -303,21 +301,20 @@ llvmVersionList = NE.toList . llvmVersionNE
--
data LlvmEnv = LlvmEnv
- { envVersion :: LlvmVersion -- ^ LLVM version
- , envOpts :: LlvmOpts -- ^ LLVM backend options
- , envDynFlags :: DynFlags -- ^ Dynamic flags
- , envLogger :: !Logger -- ^ Logger
- , envOutput :: BufHandle -- ^ Output buffer
- , envMask :: !Char -- ^ Mask for creating unique values
- , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs
- , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes
- , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
- , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
- , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
+ { envVersion :: LlvmVersion -- ^ LLVM version
+ , envConfig :: !LCGConfig -- ^ Configuration for LLVM code gen
+ , envLogger :: !Logger -- ^ Logger
+ , envOutput :: BufHandle -- ^ Output buffer
+ , envMask :: !Char -- ^ Mask for creating unique values
+ , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs
+ , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes
+ , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
+ , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
+ , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
-- the following get cleared for every function (see @withClearVars@)
- , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type
- , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude)
+ , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type
+ , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude)
}
type LlvmEnvMap = UniqFM Unique LlvmType
@@ -334,20 +331,16 @@ instance Monad LlvmM where
m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env
runLlvmM (f x) env'
-instance HasDynFlags LlvmM where
- getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
-
instance HasLogger LlvmM where
getLogger = LlvmM $ \env -> return (envLogger env, env)
-- | Get target platform
getPlatform :: LlvmM Platform
-getPlatform = llvmOptsPlatform <$> getLlvmOpts
+getPlatform = lcgPlatform <$> getConfig
--- | Get LLVM options
-getLlvmOpts :: LlvmM LlvmOpts
-getLlvmOpts = LlvmM $ \env -> return (envOpts env, env)
+getConfig :: LlvmM LCGConfig
+getConfig = LlvmM $ \env -> return (envConfig env, env)
instance MonadUnique LlvmM where
getUniqueSupplyM = do
@@ -364,23 +357,22 @@ liftIO m = LlvmM $ \env -> do x <- m
return (x, env)
-- | Get initial Llvm environment.
-runLlvm :: Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
-runLlvm logger dflags ver out m = do
+runLlvm :: Logger -> LCGConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
+runLlvm logger cfg ver out m = do
(a, _) <- runLlvmM m env
return a
- where env = LlvmEnv { envFunMap = emptyUFM
- , envVarMap = emptyUFM
+ where env = LlvmEnv { envFunMap = emptyUFM
+ , envVarMap = emptyUFM
, envStackRegs = []
- , envUsedVars = []
- , envAliases = emptyUniqSet
- , envVersion = ver
- , envOpts = initLlvmOpts dflags
- , envDynFlags = dflags
- , envLogger = logger
- , envOutput = out
- , envMask = 'n'
+ , envUsedVars = []
+ , envAliases = emptyUniqSet
+ , envVersion = ver
+ , envConfig = cfg
+ , envLogger = logger
+ , envOutput = out
+ , envMask = 'n'
, envFreshMeta = MetaId 0
- , envUniqMeta = emptyUFM
+ , envUniqMeta = emptyUFM
}
-- | Get environment (internal)
@@ -435,9 +427,8 @@ renderLlvm :: Outp.SDoc -> LlvmM ()
renderLlvm sdoc = do
-- Write to output
- dflags <- getDynFlags
+ ctx <- lcgContext <$> getConfig
out <- getEnv envOutput
- let ctx = initSDocContext dflags (Outp.PprCode Outp.CStyle)
liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc
-- Dump, if requested
@@ -499,12 +490,10 @@ ghcInternalFunctions = do
-- | Pretty print a 'CLabel'.
strCLabel_llvm :: CLabel -> LlvmM LMString
strCLabel_llvm lbl = do
- dflags <- getDynFlags
+ ctx <- lcgContext <$> getConfig
platform <- getPlatform
let sdoc = pprCLabel platform CStyle lbl
- str = Outp.renderWithContext
- (initSDocContext dflags (Outp.PprCode Outp.CStyle))
- sdoc
+ str = Outp.renderWithContext ctx sdoc
return (fsLit str)
-- ----------------------------------------------------------------------------
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index b10b26d416..fe8d5fb977 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -8,14 +8,12 @@ module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where
import GHC.Prelude
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-
import GHC.Platform
import GHC.Platform.Regs ( activeStgRegs )
import GHC.Llvm
import GHC.CmmToLlvm.Base
+import GHC.CmmToLlvm.Config
import GHC.CmmToLlvm.Regs
import GHC.Cmm.BlockId
@@ -692,14 +690,13 @@ getFunPtr funTy targ = case targ of
ForeignTarget expr _ -> do
(v1, stmts, top) <- exprToVar expr
- dflags <- getDynFlags
let fty = funTy $ fsLit "dynamic"
cast = case getVarType v1 of
ty | isPointer ty -> LM_Bitcast
ty | isInt ty -> LM_Inttoptr
- ty -> panic $ "genCall: Expr is of bad type for function"
- ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"
+ ty -> pprPanic "genCall: Expr is of bad type for function" $
+ text " call! " <> lparen <> ppr ty <> rparen
(v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
return (v2, stmts `snocOL` s1, top)
@@ -728,13 +725,12 @@ arg_vars [] (vars, stmts, tops)
arg_vars ((e, AddrHint):rest) (vars, stmts, tops)
= do (v1, stmts', top') <- exprToVar e
- dflags <- getDynFlags
let op = case getVarType v1 of
ty | isPointer ty -> LM_Bitcast
ty | isInt ty -> LM_Inttoptr
- a -> panic $ "genCall: Can't cast llvmType to i8*! ("
- ++ showSDoc dflags (ppr a) ++ ")"
+ a -> pprPanic "genCall: Can't cast llvmType to i8*! " $
+ lparen <> ppr a <> rparen
(v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
@@ -768,8 +764,7 @@ castVar signage v t | getVarType v == t
= return (v, Nop)
| otherwise
- = do dflags <- getDynFlags
- platform <- getPlatform
+ = do platform <- getPlatform
let op = case (getVarType v, t) of
(LMInt n, LMInt m)
-> if n < m then extend else LM_Trunc
@@ -783,8 +778,11 @@ castVar signage v t | getVarType v == t
(vt, _) | isPointer vt && isPointer t -> LM_Bitcast
(vt, _) | isVector vt && isVector t -> LM_Bitcast
- (vt, _) -> panic $ "castVars: Can't cast this type ("
- ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
+ (vt, _) -> pprPanic "castVars: Can't cast this type " $
+ lparen <> ppr vt <> rparen
+ <> text " to " <>
+ lparen <> ppr t <> rparen
+
doExpr t $ Cast op v t
where extend = case signage of
Signed -> LM_Sext
@@ -800,11 +798,12 @@ cmmPrimOpRetValSignage mop = case mop of
-- | Decide what C function to use to implement a CallishMachOp
cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions mop = do
-
- dflags <- getDynFlags
+ cfg <- getConfig
platform <- getPlatform
- let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)
- intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)
+ let render = renderWithContext (lcgContext cfg)
+ lcgIsBmi2Enabled = lcgBmiVersion cfg >= Just BMI2
+ intrinTy1 = "p0i8.p0i8." ++ render (ppr $ llvmWord platform)
+ intrinTy2 = "p0i8." ++ render (ppr $ llvmWord platform)
unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
++ " not supported here")
dontReach64 = panic ("cmmPrimOpFunctions: " ++ show mop
@@ -867,33 +866,28 @@ cmmPrimOpFunctions mop = do
MO_SuspendThread -> fsLit $ "suspendThread"
MO_ResumeThread -> fsLit $ "resumeThread"
- (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
- (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
- (MO_BRev w) -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
- (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
- (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ render (ppr $ widthToLlvmInt w)
+ (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ render (ppr $ widthToLlvmInt w)
+ (MO_BRev w) -> fsLit $ "llvm.bitreverse." ++ render (ppr $ widthToLlvmInt w)
+ (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ render (ppr $ widthToLlvmInt w)
+ (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ render (ppr $ widthToLlvmInt w)
- (MO_Pdep w) -> let w' = showSDoc dflags (ppr $ widthInBits w)
- in if isBmi2Enabled dflags
+ (MO_Pdep w) -> let w' = render (ppr $ widthInBits w)
+ in if lcgIsBmi2Enabled
then fsLit $ "llvm.x86.bmi.pdep." ++ w'
else fsLit $ "hs_pdep" ++ w'
- (MO_Pext w) -> let w' = showSDoc dflags (ppr $ widthInBits w)
- in if isBmi2Enabled dflags
+ (MO_Pext w) -> let w' = render (ppr $ widthInBits w)
+ in if lcgIsBmi2Enabled
then fsLit $ "llvm.x86.bmi.pext." ++ w'
else fsLit $ "hs_pext" ++ w'
(MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"
- MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow."
- ++ showSDoc dflags (ppr $ widthToLlvmInt w)
- MO_SubIntC w -> fsLit $ "llvm.ssub.with.overflow."
- ++ showSDoc dflags (ppr $ widthToLlvmInt w)
- MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow."
- ++ showSDoc dflags (ppr $ widthToLlvmInt w)
- MO_AddWordC w -> fsLit $ "llvm.uadd.with.overflow."
- ++ showSDoc dflags (ppr $ widthToLlvmInt w)
- MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow."
- ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow." ++ render (ppr $ widthToLlvmInt w)
+ MO_SubIntC w -> fsLit $ "llvm.ssub.with.overflow." ++ render (ppr $ widthToLlvmInt w)
+ MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow." ++ render (ppr $ widthToLlvmInt w)
+ MO_AddWordC w -> fsLit $ "llvm.uadd.with.overflow." ++ render (ppr $ widthToLlvmInt w)
+ MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow." ++ render (ppr $ widthToLlvmInt w)
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
@@ -960,14 +954,13 @@ genJump (CmmLit (CmmLabel lbl)) live = do
genJump expr live = do
fty <- llvmFunTy live
(vf, stmts, top) <- exprToVar expr
- dflags <- getDynFlags
let cast = case getVarType vf of
ty | isPointer ty -> LM_Bitcast
ty | isInt ty -> LM_Inttoptr
- ty -> panic $ "genJump: Expr is of bad type for function call! ("
- ++ showSDoc dflags (ppr ty) ++ ")"
+ ty -> pprPanic "genJump: Expr is of bad type for function call! "
+ $ lparen <> ppr ty <> rparen
(v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
(stgRegs, stgStmts) <- funEpilogue live
@@ -1078,9 +1071,8 @@ genStore_slow addr val meta = do
(vval, stmts2, top2) <- exprToVar val
let stmts = stmts1 `appOL` stmts2
- dflags <- getDynFlags
platform <- getPlatform
- opts <- getLlvmOpts
+ cfg <- getConfig
case getVarType vaddr of
-- sometimes we need to cast an int to a pointer before storing
LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do
@@ -1101,9 +1093,9 @@ genStore_slow addr val meta = do
other ->
pprPanic "genStore: ptr not right type!"
(PprCmm.pprExpr platform addr <+> text (
- "Size of Ptr: " ++ show (llvmPtrBits platform) ++
+ "Size of Ptr: " ++ show (llvmPtrBits platform) ++
", Size of var: " ++ show (llvmWidthInBits platform other) ++
- ", Var: " ++ showSDoc dflags (ppVar opts vaddr)))
+ ", Var: " ++ renderWithContext (lcgContext cfg) (ppVar cfg vaddr)))
-- | Unconditional branch
@@ -1128,22 +1120,22 @@ genCondBranch cond idT idF likely = do
let s1 = BranchIf vc' labelT labelF
return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
else do
- dflags <- getDynFlags
- opts <- getLlvmOpts
- panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppVar opts vc) ++ ")"
+ cfg <- getConfig
+ pprPanic "genCondBranch: Cond expr not bool! " $
+ lparen <> ppVar cfg vc <> rparen
-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData)
genExpectLit expLit expTy var = do
- dflags <- getDynFlags
+ cfg <- getConfig
let
lit = LMLitVar $ LMIntLit expLit expTy
llvmExpectName
- | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)
- | otherwise = panic $ "genExpectedLit: Type not an int!"
+ | isInt expTy = fsLit $ "llvm.expect." ++ renderWithContext (lcgContext cfg) (ppr expTy)
+ | otherwise = panic "genExpectedLit: Type not an int!"
(llvmExpect, stmts, top) <-
getInstrinct llvmExpectName expTy [expTy, expTy]
@@ -1593,6 +1585,7 @@ genMachOp_slow opt op [x, y] = case op of
where
binLlvmOp ty binOp allow_y_cast = do
+ cfg <- getConfig
platform <- getPlatform
runExprData $ do
vx <- exprToVarW x
@@ -1610,10 +1603,8 @@ genMachOp_slow opt op [x, y] = case op of
| otherwise
-> do
-- Error. Continue anyway so we can debug the generated ll file.
- dflags <- getDynFlags
- let style = PprCode CStyle
- toString doc = renderWithContext (initSDocContext dflags style) doc
- cmmToStr = (lines . toString . PprCmm.pprExpr platform)
+ let render = renderWithContext (lcgContext cfg)
+ cmmToStr = (lines . render . PprCmm.pprExpr platform)
statement $ Comment $ map fsLit $ cmmToStr x
statement $ Comment $ map fsLit $ cmmToStr y
doExprW (ty vx) $ binOp vx vy
@@ -1630,8 +1621,7 @@ genMachOp_slow opt op [x, y] = case op of
-- comparisons while LLVM return i1. Need to extend to llvmWord type
-- if expected. See Note [Literals and branch conditions].
genBinComp opt cmp = do
- ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) False
- dflags <- getDynFlags
+ ed@(v1, stmts, top) <- binLlvmOp (const i1) (Compare cmp) False
platform <- getPlatform
if getVarType v1 == i1
then case i1Expected opt of
@@ -1641,8 +1631,8 @@ genMachOp_slow opt op [x, y] = case op of
(v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
return (v2, stmts `snocOL` s1, top)
else
- panic $ "genBinComp: Compare returned type other then i1! "
- ++ (showSDoc dflags $ ppr $ getVarType v1)
+ pprPanic "genBinComp: Compare returned type other then i1! "
+ (ppr $ getVarType v1)
genBinMach op = binLlvmOp getVarType (LlvmOp op) False
@@ -1657,13 +1647,12 @@ genMachOp_slow opt op [x, y] = case op of
isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
isSMulOK _ x y = do
platform <- getPlatform
- dflags <- getDynFlags
runExprData $ do
vx <- exprToVarW x
vy <- exprToVarW y
let word = getVarType vx
- let word2 = LMInt $ 2 * (llvmWidthInBits platform $ getVarType vx)
+ let word2 = LMInt $ 2 * llvmWidthInBits platform (getVarType vx)
let shift = llvmWidthInBits platform word
let shift1 = toIWord platform (shift - 1)
let shift2 = toIWord platform shift
@@ -1680,7 +1669,8 @@ genMachOp_slow opt op [x, y] = case op of
doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2
else
- panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"
+ pprPanic "isSMulOK: Not bit type! " $
+ lparen <> ppr word <> rparen
panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
++ "with two arguments! (" ++ show op ++ ")"
@@ -1760,8 +1750,7 @@ genLoad_fast atomic e r n ty = do
genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
genLoad_slow atomic e ty meta = do
platform <- getPlatform
- dflags <- getDynFlags
- opts <- getLlvmOpts
+ cfg <- getConfig
runExprData $ do
iptr <- exprToVarW e
case getVarType iptr of
@@ -1775,9 +1764,9 @@ genLoad_slow atomic e ty meta = do
other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
(PprCmm.pprExpr platform e <+> text (
- "Size of Ptr: " ++ show (llvmPtrBits platform) ++
+ "Size of Ptr: " ++ show (llvmPtrBits platform) ++
", Size of var: " ++ show (llvmWidthInBits platform other) ++
- ", Var: " ++ showSDoc dflags (ppVar opts iptr)))
+ ", Var: " ++ renderWithContext (lcgContext cfg) (ppVar cfg iptr)))
where
loadInstr ptr | atomic = ALoad SyncSeqCst False ptr
| otherwise = Load ptr
@@ -1789,21 +1778,21 @@ genLoad_slow atomic e ty meta = do
getCmmReg :: CmmReg -> LlvmM LlvmVar
getCmmReg (CmmLocal (LocalReg un _))
= do exists <- varLookup un
- dflags <- getDynFlags
case exists of
Just ety -> return (LMLocalVar un $ pLift ety)
- Nothing -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"
+ Nothing -> pprPanic "getCmmReg: Cmm register " $
+ ppr un <> text " was not allocated!"
-- This should never happen, as every local variable should
-- have been assigned a value at some point, triggering
-- "funPrologue" to allocate it on the stack.
getCmmReg (CmmGlobal g)
- = do onStack <- checkStackReg g
- dflags <- getDynFlags
+ = do onStack <- checkStackReg g
platform <- getPlatform
if onStack
then return (lmGlobalRegVar platform g)
- else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"
+ else pprPanic "getCmmReg: Cmm register " $
+ ppr g <> text " not stack-allocated!"
-- | Return the value of a given register, as well as its type. Might
-- need to be load from stack.
diff --git a/compiler/GHC/CmmToLlvm/Config.hs b/compiler/GHC/CmmToLlvm/Config.hs
new file mode 100644
index 0000000000..e92e97a957
--- /dev/null
+++ b/compiler/GHC/CmmToLlvm/Config.hs
@@ -0,0 +1,30 @@
+-- | Llvm code generator configuration
+module GHC.CmmToLlvm.Config
+ ( LCGConfig(..)
+ , LlvmVersion(..)
+ )
+where
+
+import GHC.Prelude
+import GHC.Platform
+
+import GHC.Utils.Outputable
+import GHC.Driver.Session
+
+import qualified Data.List.NonEmpty as NE
+
+newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }
+ deriving (Eq, Ord)
+
+data LCGConfig = LCGConfig
+ { lcgPlatform :: !Platform -- ^ Target platform
+ , lcgContext :: !SDocContext -- ^ Context for LLVM code generation
+ , lcgFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values
+ , lcgSplitSections :: !Bool -- ^ Split sections
+ , lcgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions
+ , lcgLlvmVersion :: Maybe LlvmVersion -- ^ version of Llvm we're using
+ , lcgDoWarn :: !Bool -- ^ True ==> warn unsupported Llvm version
+ , lcgPlatformMisc :: !String -- ^ mirror DynFlags platformMisc_llvmTarget
+ , lcgLlvmConfig :: LlvmConfig -- ^ mirror DynFlags LlvmConfig NB. this field must be lazy
+ -- see Note [LLVM Configuration] in "GHC.SysTools"
+ }
diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs
index a76f5ee152..9cd4549398 100644
--- a/compiler/GHC/CmmToLlvm/Data.hs
+++ b/compiler/GHC/CmmToLlvm/Data.hs
@@ -11,6 +11,7 @@ import GHC.Prelude
import GHC.Llvm
import GHC.CmmToLlvm.Base
+import GHC.CmmToLlvm.Config
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
@@ -110,9 +111,9 @@ llvmSectionType p t = case t of
-- | Format a Cmm Section into a LLVM section name
llvmSection :: Section -> LlvmM LMSection
llvmSection (Section t suffix) = do
- opts <- getLlvmOpts
- let splitSect = llvmOptsSplitSections opts
- platform = llvmOptsPlatform opts
+ opts <- getConfig
+ let splitSect = lcgSplitSections opts
+ platform = lcgPlatform opts
if not splitSect
then return Nothing
else do
diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs
index 30b671ffb4..e4bb51214d 100644
--- a/compiler/GHC/CmmToLlvm/Ppr.hs
+++ b/compiler/GHC/CmmToLlvm/Ppr.hs
@@ -9,11 +9,10 @@ module GHC.CmmToLlvm.Ppr (
import GHC.Prelude
-import GHC.Driver.Ppr
-
import GHC.Llvm
import GHC.CmmToLlvm.Base
import GHC.CmmToLlvm.Data
+import GHC.CmmToLlvm.Config
import GHC.Cmm.CLabel
import GHC.Cmm
@@ -27,21 +26,21 @@ import GHC.Types.Unique
--
-- | Pretty print LLVM data code
-pprLlvmData :: LlvmOpts -> LlvmData -> SDoc
-pprLlvmData opts (globals, types) =
+pprLlvmData :: LCGConfig -> LlvmData -> SDoc
+pprLlvmData cfg (globals, types) =
let ppLlvmTys (LMAlias a) = ppLlvmAlias a
ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
ppLlvmTys _other = empty
types' = vcat $ map ppLlvmTys types
- globals' = ppLlvmGlobals opts globals
+ globals' = ppLlvmGlobals cfg globals
in types' $+$ globals'
-- | Pretty print LLVM code
pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
pprLlvmCmmDecl (CmmData _ lmdata) = do
- opts <- getLlvmOpts
+ opts <- getConfig
return (vcat $ map (pprLlvmData opts) lmdata, [])
pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
@@ -54,13 +53,12 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
lmblocks = map (\(BasicBlock id stmts) ->
LlvmBlock (getUnique id) stmts) blks
- funDec <- llvmFunSig live lbl link
- dflags <- getDynFlags
- opts <- getLlvmOpts
+ funDec <- llvmFunSig live lbl link
+ cfg <- getConfig
platform <- getPlatform
- let buildArg = fsLit . showSDoc dflags . ppPlainName opts
+ let buildArg = fsLit . renderWithContext (lcgContext cfg). ppPlainName cfg
funArgs = map buildArg (llvmFunArgs platform live)
- funSect = llvmFunSection opts (decName funDec)
+ funSect = llvmFunSection cfg (decName funDec)
-- generate the info table
prefix <- case mb_info of
@@ -94,7 +92,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
(Just $ LMBitc (LMStaticPointer defVar)
i8Ptr)
- return (ppLlvmGlobal opts alias $+$ ppLlvmFunction opts fun', [])
+ return (ppLlvmGlobal cfg alias $+$ ppLlvmFunction cfg fun', [])
-- | The section we are putting info tables and their entry code into, should
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 87b3af42df..1fcce17021 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -27,8 +27,9 @@ import GHC.Cmm ( RawCmmGroup )
import GHC.Cmm.CLabel
import GHC.Driver.Session
-import GHC.Driver.Config.Finder (initFinderOpts)
-import GHC.Driver.Config.CmmToAsm (initNCGConfig)
+import GHC.Driver.Config.Finder (initFinderOpts)
+import GHC.Driver.Config.CmmToAsm (initNCGConfig)
+import GHC.Driver.Config.CmmToLlvm (initLCGConfig)
import GHC.Driver.Ppr
import GHC.Driver.Backend
@@ -187,10 +188,11 @@ outputAsm logger dflags this_mod location filenm cmm_stream = do
-}
outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
-outputLlvm logger dflags filenm cmm_stream =
+outputLlvm logger dflags filenm cmm_stream = do
+ lcg_config <- initLCGConfig logger dflags
{-# SCC "llvm_output" #-} doOutput filenm $
\f -> {-# SCC "llvm_CodeGen" #-}
- llvmCodeGen logger dflags f cmm_stream
+ llvmCodeGen logger lcg_config f cmm_stream
{-
************************************************************************
diff --git a/compiler/GHC/Driver/Config/CmmToLlvm.hs b/compiler/GHC/Driver/Config/CmmToLlvm.hs
new file mode 100644
index 0000000000..fa7eb2f2c5
--- /dev/null
+++ b/compiler/GHC/Driver/Config/CmmToLlvm.hs
@@ -0,0 +1,30 @@
+module GHC.Driver.Config.CmmToLlvm
+ ( initLCGConfig
+ ) where
+
+import GHC.Prelude
+import GHC.Driver.Session
+import GHC.Platform
+import GHC.CmmToLlvm.Config
+import GHC.SysTools.Tasks
+import GHC.Utils.Outputable
+import GHC.Utils.Logger
+
+-- | Initialize the Llvm code generator configuration from DynFlags
+initLCGConfig :: Logger -> DynFlags -> IO LCGConfig
+initLCGConfig logger dflags = do
+ version <- figureLlvmVersion logger dflags
+ pure $! LCGConfig {
+ lcgPlatform = targetPlatform dflags
+ , lcgContext = initSDocContext dflags (PprCode CStyle)
+ , lcgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags
+ , lcgSplitSections = gopt Opt_SplitSections dflags
+ , lcgBmiVersion = case platformArch (targetPlatform dflags) of
+ ArchX86_64 -> bmiVersion dflags
+ ArchX86 -> bmiVersion dflags
+ _ -> Nothing
+ , lcgLlvmVersion = version
+ , lcgDoWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
+ , lcgPlatformMisc = platformMisc_llvmTarget $! platformMisc dflags
+ , lcgLlvmConfig = llvmConfig dflags
+ }
diff --git a/compiler/GHC/Llvm.hs b/compiler/GHC/Llvm.hs
index f4fde68bdd..5226c59db5 100644
--- a/compiler/GHC/Llvm.hs
+++ b/compiler/GHC/Llvm.hs
@@ -10,9 +10,6 @@
--
module GHC.Llvm (
- LlvmOpts (..),
- initLlvmOpts,
-
-- * Modules, Functions and Blocks
LlvmModule(..),
diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs
index 26c6bf5862..d70ac1ad2d 100644
--- a/compiler/GHC/Llvm/Ppr.hs
+++ b/compiler/GHC/Llvm/Ppr.hs
@@ -39,6 +39,8 @@ import GHC.Llvm.Types
import Data.Int
import Data.List ( intersperse )
import GHC.Utils.Outputable
+
+import GHC.CmmToLlvm.Config
import GHC.Utils.Panic
import GHC.Types.Unique
@@ -47,7 +49,7 @@ import GHC.Types.Unique
--------------------------------------------------------------------------------
-- | Print out a whole LLVM module.
-ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc
+ppLlvmModule :: LCGConfig -> LlvmModule -> SDoc
ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs)
= ppLlvmComments comments $+$ newLine
$+$ ppLlvmAliases aliases $+$ newLine
@@ -66,11 +68,11 @@ ppLlvmComment com = semi <+> ftext com
-- | Print out a list of global mutable variable definitions
-ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc
+ppLlvmGlobals :: LCGConfig -> [LMGlobal] -> SDoc
ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls
-- | Print out a global mutable variable definition
-ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc
+ppLlvmGlobal :: LCGConfig -> LMGlobal -> SDoc
ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
let sect = case x of
Just x' -> text ", section" <+> doubleQuotes (ftext x')
@@ -108,11 +110,11 @@ ppLlvmAlias (name, ty)
-- | Print out a list of LLVM metadata.
-ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc
+ppLlvmMetas :: LCGConfig -> [MetaDecl] -> SDoc
ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas
-- | Print out an LLVM metadata definition.
-ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc
+ppLlvmMeta :: LCGConfig -> MetaDecl -> SDoc
ppLlvmMeta opts (MetaUnnamed n m)
= ppr n <+> equals <+> ppMetaExpr opts m
@@ -123,11 +125,11 @@ ppLlvmMeta _opts (MetaNamed n m)
-- | Print out a list of function definitions.
-ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc
+ppLlvmFunctions :: LCGConfig -> LlvmFunctions -> SDoc
ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs
-- | Print out a function definition.
-ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc
+ppLlvmFunction :: LCGConfig -> LlvmFunction -> SDoc
ppLlvmFunction opts fun =
let attrDoc = ppSpaceJoin (funcAttrs fun)
secDoc = case funcSect fun of
@@ -183,12 +185,12 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
-- | Print out a list of LLVM blocks.
-ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc
+ppLlvmBlocks :: LCGConfig -> LlvmBlocks -> SDoc
ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks
-- | Print out an LLVM block.
-- It must be part of a function definition.
-ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc
+ppLlvmBlock :: LCGConfig -> LlvmBlock -> SDoc
ppLlvmBlock opts (LlvmBlock blockId stmts) =
let isLabel (MkLabel _) = True
isLabel _ = False
@@ -207,7 +209,7 @@ ppLlvmBlockLabel id = pprUniqueAlways id <> colon
-- | Print out an LLVM statement.
-ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc
+ppLlvmStatement :: LCGConfig -> LlvmStatement -> SDoc
ppLlvmStatement opts stmt =
let ind = (text " " <>)
in case stmt of
@@ -227,7 +229,7 @@ ppLlvmStatement opts stmt =
-- | Print out an LLVM expression.
-ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc
+ppLlvmExpression :: LCGConfig -> LlvmExpression -> SDoc
ppLlvmExpression opts expr
= case expr of
Alloca tp amount -> ppAlloca opts tp amount
@@ -249,7 +251,7 @@ ppLlvmExpression opts expr
Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk
MExpr meta expr -> ppMetaAnnotExpr opts meta expr
-ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc
+ppMetaExpr :: LCGConfig -> MetaExpr -> SDoc
ppMetaExpr opts = \case
MetaVar (LMLitVar (LMNullLit _)) -> text "null"
MetaStr s -> char '!' <> doubleQuotes (ftext s)
@@ -264,7 +266,7 @@ ppMetaExpr opts = \case
-- | Should always be a function pointer. So a global var of function type
-- (since globals are always pointers) or a local var of pointer function type.
-ppCall :: LlvmOpts -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
+ppCall :: LCGConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall opts ct fptr args attrs = case fptr of
--
-- if local var function pointer, unwrap
@@ -292,7 +294,7 @@ ppCall opts ct fptr args attrs = case fptr of
<> fnty <+> ppName opts fptr <> lparen <+> ppValues
<+> rparen <+> attrDoc
- ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
+ ppCallParams :: LCGConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args
where
-- Metadata needs to be marked as having the `metadata` type when used
@@ -301,13 +303,13 @@ ppCall opts ct fptr args attrs = case fptr of
ppCallMetaExpr _ v = text "metadata" <+> ppMetaExpr opts v
-ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
+ppMachOp :: LCGConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp opts op left right =
(ppr op) <+> (ppr (getVarType left)) <+> ppName opts left
<> comma <+> ppName opts right
-ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
+ppCmpOp :: LCGConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
ppCmpOp opts op left right =
let cmpOp
| isInt (getVarType left) && isInt (getVarType right) = text "icmp"
@@ -322,7 +324,7 @@ ppCmpOp opts op left right =
<+> ppName opts left <> comma <+> ppName opts right
-ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc
+ppAssignment :: LCGConfig -> LlvmVar -> SDoc -> SDoc
ppAssignment opts var expr = ppName opts var <+> equals <+> expr
ppFence :: Bool -> LlvmSyncOrdering -> SDoc
@@ -352,12 +354,12 @@ ppAtomicOp LAO_Min = text "min"
ppAtomicOp LAO_Umax = text "umax"
ppAtomicOp LAO_Umin = text "umin"
-ppAtomicRMW :: LlvmOpts -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
+ppAtomicRMW :: LCGConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
ppAtomicRMW opts aop tgt src ordering =
text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma
<+> ppVar opts src <+> ppSyncOrdering ordering
-ppCmpXChg :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar
+ppCmpXChg :: LCGConfig -> LlvmVar -> LlvmVar -> LlvmVar
-> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
ppCmpXChg opts addr old new s_ord f_ord =
text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new
@@ -371,16 +373,16 @@ ppCmpXChg opts addr old new s_ord f_ord =
-- access patterns are aligned, in which case we will need a more granular way
-- of specifying alignment.
-ppLoad :: LlvmOpts -> LlvmVar -> SDoc
+ppLoad :: LCGConfig -> LlvmVar -> SDoc
ppLoad opts var = text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align
where
derefType = pLower $ getVarType var
align | isVector . pLower . getVarType $ var = text ", align 1"
| otherwise = empty
-ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
+ppALoad :: LCGConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
ppALoad opts ord st var =
- let alignment = (llvmWidthInBits (llvmOptsPlatform opts) $ getVarType var) `quot` 8
+ let alignment = llvmWidthInBits (lcgPlatform opts) (getVarType var) `quot` 8
align = text ", align" <+> ppr alignment
sThreaded | st = text " singlethread"
| otherwise = empty
@@ -388,7 +390,7 @@ ppALoad opts ord st var =
in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded
<+> ppSyncOrdering ord <> align
-ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
+ppStore :: LCGConfig -> LlvmVar -> LlvmVar -> SDoc
ppStore opts val dst
| isVecPtrVar dst = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <>
comma <+> text "align 1"
@@ -398,7 +400,7 @@ ppStore opts val dst
isVecPtrVar = isVector . pLower . getVarType
-ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
+ppCast :: LCGConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast opts op from to
= ppr op
<+> ppr (getVarType from) <+> ppName opts from
@@ -406,19 +408,19 @@ ppCast opts op from to
<+> ppr to
-ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc
+ppMalloc :: LCGConfig -> LlvmType -> Int -> SDoc
ppMalloc opts tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount'
-ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc
+ppAlloca :: LCGConfig -> LlvmType -> Int -> SDoc
ppAlloca opts tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount'
-ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc
+ppGetElementPtr :: LCGConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr opts inb ptr idx =
let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx)
inbound = if inb then text "inbounds" else empty
@@ -427,27 +429,27 @@ ppGetElementPtr opts inb ptr idx =
<> indexes
-ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc
+ppReturn :: LCGConfig -> Maybe LlvmVar -> SDoc
ppReturn opts (Just var) = text "ret" <+> ppVar opts var
ppReturn _ Nothing = text "ret" <+> ppr LMVoid
-ppBranch :: LlvmOpts -> LlvmVar -> SDoc
+ppBranch :: LCGConfig -> LlvmVar -> SDoc
ppBranch opts var = text "br" <+> ppVar opts var
-ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppBranchIf :: LCGConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf opts cond trueT falseT
= text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT
-ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
+ppPhi :: LCGConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
ppPhi opts tp preds =
let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label
in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)
-ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
+ppSwitch :: LCGConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
ppSwitch opts scrut dflt targets =
let ppTarget (val, lab) = ppVar opts val <> comma <+> ppVar opts lab
ppTargets xs = brackets $ vcat (map ppTarget xs)
@@ -455,7 +457,7 @@ ppSwitch opts scrut dflt targets =
<+> ppTargets targets
-ppAsm :: LlvmOpts -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
+ppAsm :: LCGConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
ppAsm opts asm constraints rty vars sideeffect alignstack =
let asm' = doubleQuotes $ ftext asm
cons = doubleQuotes $ ftext constraints
@@ -466,19 +468,19 @@ ppAsm opts asm constraints rty vars sideeffect alignstack =
in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
<+> cons <> vars'
-ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
+ppExtract :: LCGConfig -> LlvmVar -> LlvmVar -> SDoc
ppExtract opts vec idx =
text "extractelement"
<+> ppr (getVarType vec) <+> ppName opts vec <> comma
<+> ppVar opts idx
-ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc
+ppExtractV :: LCGConfig -> LlvmVar -> Int -> SDoc
ppExtractV opts struct idx =
text "extractvalue"
<+> ppr (getVarType struct) <+> ppName opts struct <> comma
<+> ppr idx
-ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppInsert :: LCGConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert opts vec elt idx =
text "insertelement"
<+> ppr (getVarType vec) <+> ppName opts vec <> comma
@@ -486,15 +488,15 @@ ppInsert opts vec elt idx =
<+> ppVar opts idx
-ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc
+ppMetaStatement :: LCGConfig -> [MetaAnnot] -> LlvmStatement -> SDoc
ppMetaStatement opts meta stmt =
ppLlvmStatement opts stmt <> ppMetaAnnots opts meta
-ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc
+ppMetaAnnotExpr :: LCGConfig -> [MetaAnnot] -> LlvmExpression -> SDoc
ppMetaAnnotExpr opts meta expr =
ppLlvmExpression opts expr <> ppMetaAnnots opts meta
-ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc
+ppMetaAnnots :: LCGConfig -> [MetaAnnot] -> SDoc
ppMetaAnnots opts meta = hcat $ map ppMeta meta
where
ppMeta (MetaAnnot name e)
@@ -506,7 +508,7 @@ ppMetaAnnots opts meta = hcat $ map ppMeta meta
-- | Return the variable name or value of the 'LlvmVar'
-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
-ppName :: LlvmOpts -> LlvmVar -> SDoc
+ppName :: LCGConfig -> LlvmVar -> SDoc
ppName opts v = case v of
LMGlobalVar {} -> char '@' <> ppPlainName opts v
LMLocalVar {} -> char '%' <> ppPlainName opts v
@@ -515,7 +517,7 @@ ppName opts v = case v of
-- | Return the variable name or value of the 'LlvmVar'
-- in a plain textual representation (e.g. @x@, @y@ or @42@).
-ppPlainName :: LlvmOpts -> LlvmVar -> SDoc
+ppPlainName :: LCGConfig -> LlvmVar -> SDoc
ppPlainName opts v = case v of
(LMGlobalVar x _ _ _ _ _) -> ftext x
(LMLocalVar x LMLabel ) -> text (show x)
@@ -524,13 +526,13 @@ ppPlainName opts v = case v of
(LMLitVar x ) -> ppLit opts x
-- | Print a literal value. No type.
-ppLit :: LlvmOpts -> LlvmLit -> SDoc
+ppLit :: LCGConfig -> LlvmLit -> SDoc
ppLit opts l = case l of
(LMIntLit i (LMInt 32)) -> ppr (fromInteger i :: Int32)
(LMIntLit i (LMInt 64)) -> ppr (fromInteger i :: Int64)
(LMIntLit i _ ) -> ppr ((fromInteger i)::Int)
- (LMFloatLit r LMFloat ) -> ppFloat (llvmOptsPlatform opts) $ narrowFp r
- (LMFloatLit r LMDouble) -> ppDouble (llvmOptsPlatform opts) r
+ (LMFloatLit r LMFloat ) -> ppFloat (lcgPlatform opts) $ narrowFp r
+ (LMFloatLit r LMDouble) -> ppDouble (lcgPlatform opts) r
f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f)
(LMVectorLit ls ) -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>'
(LMNullLit _ ) -> text "null"
@@ -542,27 +544,27 @@ ppLit opts l = case l of
-- common types) with values that are likely to cause a crash or test
-- failure.
(LMUndefLit t )
- | llvmOptsFillUndefWithGarbage opts
+ | lcgFillUndefWithGarbage opts
, Just lit <- garbageLit t -> ppLit opts lit
| otherwise -> text "undef"
-ppVar :: LlvmOpts -> LlvmVar -> SDoc
+ppVar :: LCGConfig -> LlvmVar -> SDoc
ppVar = ppVar' []
-ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc
+ppVar' :: [LlvmParamAttr] -> LCGConfig -> LlvmVar -> SDoc
ppVar' attrs opts v = case v of
LMLitVar x -> ppTypeLit' attrs opts x
x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x
-ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc
+ppTypeLit :: LCGConfig -> LlvmLit -> SDoc
ppTypeLit = ppTypeLit' []
-ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc
+ppTypeLit' :: [LlvmParamAttr] -> LCGConfig -> LlvmLit -> SDoc
ppTypeLit' attrs opts l = case l of
LMVectorLit {} -> ppLit opts l
_ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l
-ppStatic :: LlvmOpts -> LlvmStatic -> SDoc
+ppStatic :: LCGConfig -> LlvmStatic -> SDoc
ppStatic opts st = case st of
LMComment s -> text "; " <> ftext s
LMStaticLit l -> ppTypeLit opts l
@@ -578,7 +580,7 @@ ppStatic opts st = case st of
LMSub s1 s2 -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub")
-pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc
+pprSpecialStatic :: LCGConfig -> LlvmStatic -> SDoc
pprSpecialStatic opts stat = case stat of
LMBitc v t -> ppr (pLower t)
<> text ", bitcast ("
@@ -589,7 +591,7 @@ pprSpecialStatic opts stat = case stat of
_ -> ppStatic opts stat
-pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc
+pprStaticArith :: LCGConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc
-> SDoc -> SDoc
pprStaticArith opts s1 s2 int_op float_op op_name =
let ty1 = getStatType s1
diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs
index a62f0857fa..c5feba4c45 100644
--- a/compiler/GHC/Llvm/Types.hs
+++ b/compiler/GHC/Llvm/Types.hs
@@ -156,21 +156,6 @@ data LlvmStatic
-- ** Operations on LLVM Basic Types and Variables
--
--- | LLVM code generator options
-data LlvmOpts = LlvmOpts
- { llvmOptsPlatform :: !Platform -- ^ Target platform
- , llvmOptsFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values
- , llvmOptsSplitSections :: !Bool -- ^ Split sections
- }
-
--- | Get LlvmOptions from DynFlags
-initLlvmOpts :: DynFlags -> LlvmOpts
-initLlvmOpts dflags = LlvmOpts
- { llvmOptsPlatform = targetPlatform dflags
- , llvmOptsFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags
- , llvmOptsSplitSections = gopt Opt_SplitSections dflags
- }
-
garbageLit :: LlvmType -> Maybe LlvmLit
garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)
-- Use a value that looks like an untagged pointer, so we are more
diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs
index 25988af4b2..fbae72eefc 100644
--- a/compiler/GHC/SysTools/Tasks.hs
+++ b/compiler/GHC/SysTools/Tasks.hs
@@ -15,6 +15,7 @@ import GHC.ForeignSrcLang
import GHC.IO (catchException)
import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion)
+import GHC.CmmToLlvm.Config
import GHC.SysTools.Process
import GHC.SysTools.Info
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 232d89c89f..db3f5f3926 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -280,6 +280,7 @@ Library
GHC.CmmToLlvm
GHC.CmmToLlvm.Base
GHC.CmmToLlvm.CodeGen
+ GHC.CmmToLlvm.Config
GHC.CmmToLlvm.Data
GHC.CmmToLlvm.Mangler
GHC.CmmToLlvm.Ppr
@@ -386,6 +387,7 @@ Library
GHC.Driver.CodeOutput
GHC.Driver.Config
GHC.Driver.Config.CmmToAsm
+ GHC.Driver.Config.CmmToLlvm
GHC.Driver.Config.Diagnostic
GHC.Driver.Config.Finder
GHC.Driver.Config.Logger