diff options
author | doyougnu <jeffrey.young@iohk.io> | 2021-12-08 12:29:07 -0800 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-12-14 20:55:06 -0500 |
commit | ecaec722850cce498b67561708ee8e42df367dda (patch) | |
tree | 98eb6c505702858c4663bda1c3f2ec2635df853d /compiler | |
parent | 0198bb1190ffc4ac4963140e81cacd72721eab07 (diff) | |
download | haskell-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.hs | 41 | ||||
-rw-r--r-- | compiler/GHC/CmmToLlvm/Base.hs | 83 | ||||
-rw-r--r-- | compiler/GHC/CmmToLlvm/CodeGen.hs | 127 | ||||
-rw-r--r-- | compiler/GHC/CmmToLlvm/Config.hs | 30 | ||||
-rw-r--r-- | compiler/GHC/CmmToLlvm/Data.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/CmmToLlvm/Ppr.hs | 22 | ||||
-rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Driver/Config/CmmToLlvm.hs | 30 | ||||
-rw-r--r-- | compiler/GHC/Llvm.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Llvm/Ppr.hs | 106 | ||||
-rw-r--r-- | compiler/GHC/Llvm/Types.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/SysTools/Tasks.hs | 1 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 2 |
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 |