diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC.hs | 51 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Pipeline.hs | 30 | ||||
| -rw-r--r-- | compiler/GHC/CmmToLlvm/Base.hs | 44 | ||||
| -rw-r--r-- | compiler/GHC/CmmToLlvm/Config.hs | 119 | ||||
| -rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config/CmmToLlvm.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Env/Types.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Driver/GenerateCgIPEStub.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Driver/LlvmConfigCache.hs | 26 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 110 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline/Execute.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 23 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Pipeline.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/SysTools.hs | 45 | ||||
| -rw-r--r-- | compiler/GHC/SysTools/Tasks.hs | 3 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 |
16 files changed, 281 insertions, 228 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index d3e9d3978d..b532a2fa97 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -351,9 +351,6 @@ import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family import GHC.Utils.TmpFs -import GHC.SysTools -import GHC.SysTools.BaseDir - import GHC.Utils.Error import GHC.Utils.Monad import GHC.Utils.Misc @@ -559,53 +556,7 @@ withCleanupSession ghc = ghc `MC.finally` cleanup -- <http://hackage.haskell.org/package/ghc-paths>. initGhcMonad :: GhcMonad m => Maybe FilePath -> m () -initGhcMonad mb_top_dir - = do { env <- liftIO $ - do { top_dir <- findTopDir mb_top_dir - ; mySettings <- initSysTools top_dir - ; myLlvmConfig <- lazyInitLlvmConfig top_dir - ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig) - ; hsc_env <- newHscEnv dflags - ; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags - ; setUnsafeGlobalDynFlags dflags - -- c.f. DynFlags.parseDynamicFlagsFull, which - -- creates DynFlags and sets the UnsafeGlobalDynFlags - ; return hsc_env } - ; setSession env } - --- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which --- breaks tables-next-to-code in dynamically linked modules. This --- check should be more selective but there is currently no released --- version where this bug is fixed. --- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and --- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 -checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m () -checkBrokenTablesNextToCode logger dflags - = do { broken <- checkBrokenTablesNextToCode' logger dflags - ; when broken - $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr - ; liftIO $ fail "unsupported linker" - } - } - where - invalidLdErr = text "Tables-next-to-code not supported on ARM" <+> - text "when using binutils ld (please see:" <+> - text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" - -checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool -checkBrokenTablesNextToCode' logger dflags - | not (isARM arch) = return False - | ways dflags `hasNotWay` WayDyn = return False - | not tablesNextToCode = return False - | otherwise = do - linkerInfo <- liftIO $ getLinkerInfo logger dflags - case linkerInfo of - GnuLD _ -> return True - _ -> return False - where platform = targetPlatform dflags - arch = platformArch platform - tablesNextToCode = platformTablesNextToCode platform - +initGhcMonad mb_top_dir = setSession =<< liftIO (initHscEnv mb_top_dir) -- %************************************************************************ -- %* * diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index 53fb4d2e36..40383bff94 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -1,14 +1,13 @@ {-# LANGUAGE BangPatterns #-} module GHC.Cmm.Pipeline ( - -- | Converts C-- with an implicit stack and native C-- calls into - -- optimized, CPS converted and native-call-less C--. The latter - -- C-- can be used to generate assembly. cmmPipeline ) where import GHC.Prelude +import GHC.Driver.Flags + import GHC.Cmm import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt @@ -22,37 +21,38 @@ import GHC.Cmm.Sink import GHC.Cmm.Switch.Implement import GHC.Types.Unique.Supply -import GHC.Driver.Session -import GHC.Driver.Config.Cmm + import GHC.Utils.Error import GHC.Utils.Logger -import GHC.Driver.Env -import Control.Monad import GHC.Utils.Outputable + import GHC.Platform + +import Control.Monad import Data.Either (partitionEithers) ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline ----------------------------------------------------------------------------- +-- | Converts C-- with an implicit stack and native C-- calls into +-- optimized, CPS converted and native-call-less C--. The latter +-- C-- can be used to generate assembly. cmmPipeline - :: HscEnv -- Compilation env including - -- dynamic flags: -dcmm-lint -ddump-cmm-cps + :: Logger + -> CmmConfig -> ModuleSRTInfo -- Info about SRTs generated so far -> CmmGroup -- Input C-- with Procedures -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = do - let logger = hsc_logger hsc_env - let cmmConfig = initCmmConfig (hsc_dflags hsc_env) +cmmPipeline logger cmm_config srtInfo prog = do let forceRes (info, group) = info `seq` foldr seq () group - let platform = cmmPlatform cmmConfig + let platform = cmmPlatform cmm_config withTimingSilent logger (text "Cmm pipeline") forceRes $ do - tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmmConfig) prog + tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog let (procs, data_) = partitionEithers tops - (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmmConfig srtInfo procs data_ + (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_ dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) return (srtInfo, cmms) diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index cc4377240b..338aa3a927 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -15,10 +15,6 @@ module GHC.CmmToLlvm.Base ( LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - LlvmVersion, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, - llvmVersionSupported, parseLlvmVersion, - llvmVersionStr, llvmVersionList, - LlvmM, runLlvm, withClearVars, varLookup, varInsert, markStackReg, checkStackReg, @@ -66,10 +62,8 @@ import GHC.Utils.Logger import Data.Maybe (fromJust) import Control.Monad (ap) -import Data.Char (isDigit) -import Data.List (sortBy, groupBy, intercalate) +import Data.List (sortBy, groupBy) import Data.Ord (comparing) -import qualified Data.List.NonEmpty as NE -- ---------------------------------------------------------------------------- -- * Some Data Types @@ -261,42 +255,6 @@ llvmPtrBits :: Platform -> Int llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform -- ---------------------------------------------------------------------------- --- * Llvm Version --- - -parseLlvmVersion :: String -> Maybe LlvmVersion -parseLlvmVersion = - fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit) - where - go vs s - | null ver_str - = reverse vs - | '.' : rest' <- rest - = go (read ver_str : vs) rest' - | otherwise - = reverse (read ver_str : vs) - where - (ver_str, rest) = span isDigit s - --- | The (inclusive) lower bound on the LLVM Version that is currently supported. -supportedLlvmVersionLowerBound :: LlvmVersion -supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) - --- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported. -supportedLlvmVersionUpperBound :: LlvmVersion -supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) - -llvmVersionSupported :: LlvmVersion -> Bool -llvmVersionSupported v = - v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound - -llvmVersionStr :: LlvmVersion -> String -llvmVersionStr = intercalate "." . map show . llvmVersionList - -llvmVersionList :: LlvmVersion -> [Int] -llvmVersionList = NE.toList . llvmVersionNE - --- ---------------------------------------------------------------------------- -- * Environment Handling -- diff --git a/compiler/GHC/CmmToLlvm/Config.hs b/compiler/GHC/CmmToLlvm/Config.hs index 84455a8b2c..f516b9787b 100644 --- a/compiler/GHC/CmmToLlvm/Config.hs +++ b/compiler/GHC/CmmToLlvm/Config.hs @@ -1,20 +1,35 @@ +{-# LANGUAGE CPP #-} + -- | Llvm code generator configuration module GHC.CmmToLlvm.Config ( LlvmCgConfig(..) + , LlvmConfig(..) + , LlvmTarget(..) + , initLlvmConfig + -- * LLVM version , LlvmVersion(..) + , supportedLlvmVersionLowerBound + , supportedLlvmVersionUpperBound + , parseLlvmVersion + , llvmVersionSupported + , llvmVersionStr + , llvmVersionList ) where +#include "ghc-llvm-version.h" + import GHC.Prelude import GHC.Platform import GHC.Utils.Outputable -import GHC.Driver.Session +import GHC.Settings.Utils +import GHC.Utils.Panic +import Data.Char (isDigit) +import Data.List (intercalate) import qualified Data.List.NonEmpty as NE - -newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } - deriving (Eq, Ord) +import System.FilePath data LlvmCgConfig = LlvmCgConfig { llvmCgPlatform :: !Platform -- ^ Target platform @@ -25,7 +40,97 @@ data LlvmCgConfig = LlvmCgConfig , llvmCgLlvmVersion :: Maybe LlvmVersion -- ^ version of Llvm we're using , llvmCgDoWarn :: !Bool -- ^ True ==> warn unsupported Llvm version , llvmCgLlvmTarget :: !String -- ^ target triple passed to LLVM - , llvmCgLlvmConfig :: !LlvmConfig -- ^ mirror DynFlags LlvmConfig. - -- see Note [LLVM configuration] in "GHC.SysTools". This can be strict since - -- GHC.Driver.Config.CmmToLlvm.initLlvmCgConfig verifies the files are present. + , llvmCgLlvmConfig :: !LlvmConfig -- ^ Supported LLVM configurations. + -- see Note [LLVM configuration] + } + +data LlvmTarget = LlvmTarget + { lDataLayout :: String + , lCPU :: String + , lAttributes :: [String] + } + +-- Note [LLVM configuration] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain +-- information needed by the LLVM backend to invoke `llc` and `opt`. +-- Specifically: +-- +-- * llvm-targets maps autoconf host triples to the corresponding LLVM +-- `data-layout` declarations. This information is extracted from clang using +-- the script in utils/llvm-targets/gen-data-layout.sh and should be updated +-- whenever we target a new version of LLVM. +-- +-- * llvm-passes maps GHC optimization levels to sets of LLVM optimization +-- flags that GHC should pass to `opt`. +-- +-- This information is contained in files rather the GHC source to allow users +-- to add new targets to GHC without having to recompile the compiler. +-- + +initLlvmConfig :: FilePath -> IO LlvmConfig +initLlvmConfig top_dir + = do + targets <- readAndParse "llvm-targets" + passes <- readAndParse "llvm-passes" + return $ LlvmConfig + { llvmTargets = fmap mkLlvmTarget <$> targets + , llvmPasses = passes + } + where + readAndParse :: Read a => String -> IO a + readAndParse name = do + let f = top_dir </> name + llvmConfigStr <- readFile f + case maybeReadFuzzy llvmConfigStr of + Just s -> return s + Nothing -> pgmError ("Can't parse LLVM config file: " ++ show f) + + mkLlvmTarget :: (String, String, String) -> LlvmTarget + mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) + +data LlvmConfig = LlvmConfig + { llvmTargets :: [(String, LlvmTarget)] + , llvmPasses :: [(Int, String)] } + + +--------------------------------------------------------- +-- 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) + where + go vs s + | null ver_str + = reverse vs + | '.' : rest' <- rest + = go (read ver_str : vs) rest' + | otherwise + = reverse (read ver_str : vs) + where + (ver_str, rest) = span isDigit s + +-- | The (inclusive) lower bound on the LLVM Version that is currently supported. +supportedLlvmVersionLowerBound :: LlvmVersion +supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) + +-- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported. +supportedLlvmVersionUpperBound :: LlvmVersion +supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) + +llvmVersionSupported :: LlvmVersion -> Bool +llvmVersionSupported v = + v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound + +llvmVersionStr :: LlvmVersion -> String +llvmVersionStr = intercalate "." . map show . llvmVersionList + +llvmVersionList :: LlvmVersion -> [Int] +llvmVersionList = NE.toList . llvmVersionNE + diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 4a96967932..c073c40323 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -30,6 +30,7 @@ import GHC.Driver.Session import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.CmmToAsm (initNCGConfig) import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig) +import GHC.Driver.LlvmConfigCache (LlvmConfigCache) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -73,6 +74,7 @@ codeOutput :: forall a. Logger -> TmpFs + -> LlvmConfigCache -> DynFlags -> UnitState -> Module @@ -87,7 +89,7 @@ codeOutput (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), [(ForeignSrcLang, FilePath)]{-foreign_fps-}, a) -codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps +codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps cmm_stream = do { @@ -122,7 +124,7 @@ codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStu NCG -> outputAsm logger dflags this_mod location filenm final_stream ViaC -> outputC logger dflags filenm final_stream pkg_deps - LLVM -> outputLlvm logger dflags filenm final_stream + LLVM -> outputLlvm logger llvm_config dflags filenm final_stream Interpreter -> panic "codeOutput: Interpreter" NoBackend -> panic "codeOutput: NoBackend" ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs @@ -209,9 +211,9 @@ 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 = do - lcg_config <- initLlvmCgConfig logger dflags +outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputLlvm logger llvm_config dflags filenm cmm_stream = do + lcg_config <- initLlvmCgConfig logger llvm_config dflags {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-} llvmCodeGen logger lcg_config f cmm_stream diff --git a/compiler/GHC/Driver/Config/CmmToLlvm.hs b/compiler/GHC/Driver/Config/CmmToLlvm.hs index 18721bf845..61ffb8bcf4 100644 --- a/compiler/GHC/Driver/Config/CmmToLlvm.hs +++ b/compiler/GHC/Driver/Config/CmmToLlvm.hs @@ -1,19 +1,23 @@ module GHC.Driver.Config.CmmToLlvm ( initLlvmCgConfig - ) where + ) +where import GHC.Prelude import GHC.Driver.Session +import GHC.Driver.LlvmConfigCache 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 -initLlvmCgConfig :: Logger -> DynFlags -> IO LlvmCgConfig -initLlvmCgConfig logger dflags = do +initLlvmCgConfig :: Logger -> LlvmConfigCache -> DynFlags -> IO LlvmCgConfig +initLlvmCgConfig logger config_cache dflags = do version <- figureLlvmVersion logger dflags + llvm_config <- readLlvmConfigCache config_cache pure $! LlvmCgConfig { llvmCgPlatform = targetPlatform dflags , llvmCgContext = initSDocContext dflags (PprCode CStyle) @@ -26,5 +30,5 @@ initLlvmCgConfig logger dflags = do , llvmCgLlvmVersion = version , llvmCgDoWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags , llvmCgLlvmTarget = platformMisc_llvmTarget $! platformMisc dflags - , llvmCgLlvmConfig = llvmConfig dflags + , llvmCgLlvmConfig = llvm_config } diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs index 9db617780b..63a5eb86cb 100644 --- a/compiler/GHC/Driver/Env/Types.hs +++ b/compiler/GHC/Driver/Env/Types.hs @@ -8,6 +8,8 @@ module GHC.Driver.Env.Types import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Driver.Session ( ContainsDynFlags(..), HasDynFlags(..), DynFlags ) +import GHC.Driver.LlvmConfigCache (LlvmConfigCache) + import GHC.Prelude import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types ( Interp ) @@ -106,4 +108,7 @@ data HscEnv , hsc_tmpfs :: !TmpFs -- ^ Temporary files + + , hsc_llvm_config :: !LlvmConfigCache + -- ^ LLVM configuration cache. } diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs index 96bf352e51..cf6538ef3e 100644 --- a/compiler/GHC/Driver/GenerateCgIPEStub.hs +++ b/compiler/GHC/Driver/GenerateCgIPEStub.hs @@ -16,11 +16,12 @@ import GHC.Cmm.Utils (toBlockList) import GHC.Data.Maybe (firstJusts) import GHC.Data.Stream (Stream, liftIO) import qualified GHC.Data.Stream as Stream -import GHC.Driver.Env (hsc_dflags) +import GHC.Driver.Env (hsc_dflags, hsc_logger) import GHC.Driver.Env.Types (HscEnv) import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap)) import GHC.Driver.Session (gopt, targetPlatform) import GHC.Driver.Config.StgToCmm +import GHC.Driver.Config.Cmm import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep) import GHC.Settings (Platform, platformUnregisterised) @@ -184,7 +185,9 @@ generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> NameEnv TagSig -> S generateCgIPEStub hsc_env this_mod denv tag_sigs s = do let dflags = hsc_dflags hsc_env platform = targetPlatform dflags + logger = hsc_logger hsc_env fstate = initFCodeState platform + cmm_cfg = initCmmConfig dflags cgState <- liftIO initC -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty. @@ -195,7 +198,7 @@ generateCgIPEStub hsc_env this_mod denv tag_sigs s = do let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)} ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv') - (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup + (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup Stream.yield ipeCmmGroupSRTs return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = tag_sigs} diff --git a/compiler/GHC/Driver/LlvmConfigCache.hs b/compiler/GHC/Driver/LlvmConfigCache.hs new file mode 100644 index 0000000000..fefd385518 --- /dev/null +++ b/compiler/GHC/Driver/LlvmConfigCache.hs @@ -0,0 +1,26 @@ +-- | LLVM config cache +module GHC.Driver.LlvmConfigCache + ( LlvmConfigCache + , initLlvmConfigCache + , readLlvmConfigCache + ) +where + +import GHC.Prelude +import GHC.CmmToLlvm.Config + +import System.IO.Unsafe + +-- | Cache LLVM configuration read from files in top_dir +-- +-- See Note [LLVM configuration] in GHC.CmmToLlvm.Config +-- +-- Currently implemented with unsafe lazy IO. But it could be implemented with +-- an IORef as the exposed interface is in IO. +data LlvmConfigCache = LlvmConfigCache LlvmConfig + +initLlvmConfigCache :: FilePath -> IO LlvmConfigCache +initLlvmConfigCache top_dir = pure $ LlvmConfigCache (unsafePerformIO $ initLlvmConfig top_dir) + +readLlvmConfigCache :: LlvmConfigCache -> IO LlvmConfig +readLlvmConfigCache (LlvmConfigCache !config) = pure config diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index f45cdc8020..ddc86ac3e3 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -39,6 +39,7 @@ module GHC.Driver.Main -- * Making an HscEnv newHscEnv , newHscEnvWithHUG + , initHscEnv -- * Compiling complete source files , Messager, batchMsg, batchMultiMsg @@ -99,10 +100,14 @@ module GHC.Driver.Main import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways + import GHC.Driver.Plugins import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Env +import GHC.Driver.Env.KnotVars import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput @@ -111,10 +116,13 @@ import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Stg.Ppr (initStgPprOpts) import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts) -import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) +import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) +import GHC.Driver.Config.Cmm (initCmmConfig) +import GHC.Driver.LlvmConfigCache (initLlvmConfigCache) import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Tidy import GHC.Driver.Hooks +import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) import GHC.Runtime.Context import GHC.Runtime.Interpreter ( addSptEntry ) @@ -172,6 +180,7 @@ import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) ) import GHC.Stg.Syntax import GHC.Stg.Pipeline ( stg2stg ) +import GHC.Stg.InferTags import GHC.Builtin.Utils import GHC.Builtin.Names @@ -215,6 +224,7 @@ import GHC.Types.Name import GHC.Types.Name.Cache ( initNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr +import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo @@ -232,7 +242,11 @@ import GHC.Data.Bag import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) +import GHC.Data.Maybe + import qualified GHC.SysTools +import GHC.SysTools (initSysTools) +import GHC.SysTools.BaseDir (findTopDir) import Data.Data hiding (Fixity, TyCon) import Data.List ( nub, isPrefixOf, partition ) @@ -246,14 +260,9 @@ import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) -import GHC.Data.Maybe -import GHC.Driver.Env.KnotVars -import GHC.Types.Name.Set (NonCaffySet) -import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) import Data.List.NonEmpty (NonEmpty ((:|))) -import GHC.Stg.InferTags {- ********************************************************************** %* * @@ -261,36 +270,80 @@ import GHC.Stg.InferTags %* * %********************************************************************* -} -newHscEnv :: DynFlags -> IO HscEnv -newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph +newHscEnv :: FilePath -> DynFlags -> IO HscEnv +newHscEnv top_dir dflags = newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) home_unit_graph where home_unit_graph = unitEnv_singleton (homeUnitId_ dflags) (mkHomeUnitEnv dflags emptyHomePackageTable Nothing) -newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv -newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do +newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv +newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do nc_var <- initNameCache 'r' knownKeyNames fc_var <- initFinderCache logger <- initLogger tmpfs <- initTmpFs let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) - return HscEnv { hsc_dflags = top_dynflags + llvm_config <- initLlvmConfigCache top_dir + return HscEnv { hsc_dflags = top_dynflags , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) - , hsc_targets = [] - , hsc_mod_graph = emptyMG - , hsc_IC = emptyInteractiveContext dflags - , hsc_NC = nc_var - , hsc_FC = fc_var - , hsc_type_env_vars = emptyKnotVars - , hsc_interp = Nothing - , hsc_unit_env = unit_env - , hsc_plugins = emptyPlugins - , hsc_hooks = emptyHooks - , hsc_tmpfs = tmpfs + , hsc_targets = [] + , hsc_mod_graph = emptyMG + , hsc_IC = emptyInteractiveContext dflags + , hsc_NC = nc_var + , hsc_FC = fc_var + , hsc_type_env_vars = emptyKnotVars + , hsc_interp = Nothing + , hsc_unit_env = unit_env + , hsc_plugins = emptyPlugins + , hsc_hooks = emptyHooks + , hsc_tmpfs = tmpfs + , hsc_llvm_config = llvm_config } +-- | Initialize HscEnv from an optional top_dir path +initHscEnv :: Maybe FilePath -> IO HscEnv +initHscEnv mb_top_dir = do + top_dir <- findTopDir mb_top_dir + mySettings <- initSysTools top_dir + dflags <- initDynFlags (defaultDynFlags mySettings) + hsc_env <- newHscEnv top_dir dflags + checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags + setUnsafeGlobalDynFlags dflags + -- c.f. DynFlags.parseDynamicFlagsFull, which + -- creates DynFlags and sets the UnsafeGlobalDynFlags + return hsc_env + +-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which +-- breaks tables-next-to-code in dynamically linked modules. This +-- check should be more selective but there is currently no released +-- version where this bug is fixed. +-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and +-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 +checkBrokenTablesNextToCode :: Logger -> DynFlags -> IO () +checkBrokenTablesNextToCode logger dflags = do + let invalidLdErr = "Tables-next-to-code not supported on ARM \ + \when using binutils ld (please see: \ + \https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" + broken <- checkBrokenTablesNextToCode' logger dflags + when broken (panic invalidLdErr) + +checkBrokenTablesNextToCode' :: Logger -> DynFlags -> IO Bool +checkBrokenTablesNextToCode' logger dflags + | not (isARM arch) = return False + | ways dflags `hasNotWay` WayDyn = return False + | not tablesNextToCode = return False + | otherwise = do + linkerInfo <- liftIO $ GHC.SysTools.getLinkerInfo logger dflags + case linkerInfo of + GnuLD _ -> return True + _ -> return False + where platform = targetPlatform dflags + arch = platformArch platform + tablesNextToCode = platformTablesNextToCode platform + + -- ----------------------------------------------------------------------------- getDiagnostics :: Hsc (Messages GhcMessage) @@ -1630,6 +1683,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env profile = targetProfile dflags data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -1688,7 +1742,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) <- {-# SCC "codeOutput" #-} - codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location + codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1 return (output_filename, stub_c_exists, foreign_fps, Just cg_infos) @@ -1741,6 +1795,8 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs profile = targetProfile dflags home_unit = hsc_home_unit hsc_env platform = targetPlatform dflags + llvm_config = hsc_llvm_config hsc_env + cmm_config = initCmmConfig dflags do_info_table = gopt Opt_InfoTableMap dflags -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. @@ -1763,7 +1819,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs -- in C we must declare before use, but SRT algorithm is free to -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A] cmmgroup <- - concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm + concatMapM (\cmm -> snd <$> cmmPipeline logger cmm_config (emptySRT cmm_mod) [cmm]) cmm unless (null cmmgroup) $ putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" @@ -1778,7 +1834,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs in NoStubs `appendStubC` ip_init (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) - <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty + <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty rawCmms return stub_c_exists where @@ -1853,11 +1909,13 @@ doCodeGen hsc_env this_mod denv data_tycons ppr_stream1 = Stream.mapM dump1 cmm_stream + cmm_config = initCmmConfig dflags + pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) pipeline_stream = do (non_cafs, lf_infos) <- {-# SCC "cmmPipeline" #-} - Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1 + Stream.mapAccumL_ (cmmPipeline logger cmm_config) (emptySRT this_mod) ppr_stream1 <&> first (srtMapNonCAFs . moduleSRTMap) return (non_cafs, lf_infos) diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index 4f2c30c5a7..58bc1e6907 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -70,7 +70,8 @@ import Data.IORef import GHC.Types.Name.Env import GHC.Platform.Ways import GHC.Platform.ArchOS -import GHC.CmmToLlvm.Base ( llvmVersionList ) +import GHC.Driver.LlvmConfigCache (readLlvmConfigCache) +import GHC.CmmToLlvm.Config (llvmVersionList, LlvmTarget (..), LlvmConfig (..)) import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) import GHC.Settings import System.IO @@ -209,6 +210,7 @@ runLlvmLlcPhase pipe_env hsc_env input_fn = do -- -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa -- + llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env) let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env llvmOpts = case llvmOptLevel dflags of @@ -217,7 +219,7 @@ runLlvmLlcPhase pipe_env hsc_env input_fn = do _ -> "-O2" defaultOptions = map GHC.SysTools.Option . concatMap words . snd - $ unzip (llvmOptions dflags) + $ unzip (llvmOptions llvm_config dflags) optFlag = if null (getOpts dflags opt_lc) then map GHC.SysTools.Option $ words llvmOpts else [] @@ -243,16 +245,17 @@ runLlvmOptPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath runLlvmOptPhase pipe_env hsc_env input_fn = do let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env) let -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate optIdx = max 0 $ min 2 $ llvmOptLevel dflags -- ensure we're in [0,2] - llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of + llvmOpts = case lookup optIdx $ llvmPasses llvm_config of Just passes -> passes Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " ++ "is missing passes for level " ++ show optIdx) defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst - $ unzip (llvmOptions dflags) + $ unzip (llvmOptions llvm_config dflags) -- don't specify anything if user has specified commands. We do this -- for opt but not llc since opt is very specifically for optimisation @@ -867,9 +870,10 @@ getOutputFilename logger tmpfs stop_phase output basename dflags next_phase mayb -- | LLVM Options. These are flags to be passed to opt and llc, to ensure -- consistency we list them in pairs, so that they form groups. -llvmOptions :: DynFlags +llvmOptions :: LlvmConfig + -> DynFlags -> [(String, String)] -- ^ pairs of (opt, llc) arguments -llvmOptions dflags = +llvmOptions llvm_config dflags = [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ] ++ [("-relocation-model=" ++ rmodel ,"-relocation-model=" ++ rmodel) | not (null rmodel)] @@ -883,7 +887,7 @@ llvmOptions dflags = ++ [("", "-target-abi=" ++ abi) | not (null abi) ] where target = platformMisc_llvmTarget $ platformMisc dflags - Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags) + Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets llvm_config) -- Relocation models rmodel | gopt Opt_PIC dflags = "pic" diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 0af3549b7c..0f1a4b6e02 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -71,9 +71,6 @@ module GHC.Driver.Session ( safeDirectImpsReq, safeImplicitImpsReq, unsafeFlags, unsafeFlagsForInfer, - -- ** LLVM Targets - LlvmTarget(..), LlvmConfig(..), - -- ** System tool settings and locations Settings(..), sProgramName, @@ -452,9 +449,6 @@ data DynFlags = DynFlags { rawSettings :: [(String, String)], tmpDir :: TempDir, - llvmConfig :: LlvmConfig, - -- ^ N.B. It's important that this field is lazy since we load the LLVM - -- configuration lazily. See Note [LLVM configuration] in "GHC.SysTools". llvmOptLevel :: Int, -- ^ LLVM optimisation level verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] debugLevel :: Int, -- ^ How much debug information to produce @@ -773,17 +767,6 @@ data ProfAuto | ProfAutoCalls -- ^ annotate call-sites deriving (Eq,Enum) -data LlvmTarget = LlvmTarget - { lDataLayout :: String - , lCPU :: String - , lAttributes :: [String] - } - --- | See Note [LLVM configuration] in "GHC.SysTools". -data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)] - , llvmPasses :: [(Int, String)] - } - ----------------------------------------------------------------------------- -- Accessessors from 'DynFlags' @@ -1117,8 +1100,8 @@ initDynFlags dflags = do -- | The normal 'DynFlags'. Note that they are not suitable for use in this form -- and must be fully initialized by 'GHC.runGhc' first. -defaultDynFlags :: Settings -> LlvmConfig -> DynFlags -defaultDynFlags mySettings llvmConfig = +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = -- See Note [Updating flag description in the User's Guide] DynFlags { ghcMode = CompManager, @@ -1227,8 +1210,6 @@ defaultDynFlags mySettings llvmConfig = tmpDir = panic "defaultDynFlags: uninitialized tmpDir", - -- See Note [LLVM configuration]. - llvmConfig = llvmConfig, llvmOptLevel = 0, -- ghc -M values diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index e1df24c626..f6bf55d398 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -17,6 +17,8 @@ module GHC.Stg.Pipeline import GHC.Prelude +import GHC.Driver.Flags + import GHC.Stg.Syntax import GHC.Stg.Lint ( lintStgTopBindings ) @@ -29,7 +31,6 @@ import GHC.Stg.Lift ( StgLiftConfig, stgLiftLams ) import GHC.Unit.Module ( Module ) import GHC.Runtime.Context ( InteractiveContext ) -import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Error import GHC.Types.Unique.Supply import GHC.Utils.Outputable diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs index adc6e6c241..058fc67d12 100644 --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -14,7 +14,6 @@ module GHC.SysTools ( -- * Initialisation initSysTools, - lazyInitLlvmConfig, -- * Interface to system tools module GHC.SysTools.Tasks, @@ -32,7 +31,6 @@ module GHC.SysTools ( import GHC.Prelude -import GHC.Settings.Utils import GHC.Utils.Panic import GHC.Driver.Session @@ -44,9 +42,7 @@ import GHC.SysTools.BaseDir import GHC.Settings.IO import Control.Monad.Trans.Except (runExceptT) -import System.FilePath import System.IO -import System.IO.Unsafe (unsafeInterleaveIO) import Foreign.Marshal.Alloc (allocaBytes) import System.Directory (copyFile) @@ -102,47 +98,6 @@ stuff. ************************************************************************ -} --- Note [LLVM configuration] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain --- information needed by the LLVM backend to invoke `llc` and `opt`. --- Specifically: --- --- * llvm-targets maps autoconf host triples to the corresponding LLVM --- `data-layout` declarations. This information is extracted from clang using --- the script in utils/llvm-targets/gen-data-layout.sh and should be updated --- whenever we target a new version of LLVM. --- --- * llvm-passes maps GHC optimization levels to sets of LLVM optimization --- flags that GHC should pass to `opt`. --- --- This information is contained in files rather the GHC source to allow users --- to add new targets to GHC without having to recompile the compiler. --- --- Since this information is only needed by the LLVM backend we load it lazily --- with unsafeInterleaveIO. Consequently it is important that we lazily pattern --- match on LlvmConfig until we actually need its contents. - -lazyInitLlvmConfig :: String - -> IO LlvmConfig -lazyInitLlvmConfig top_dir - = unsafeInterleaveIO $ do -- see Note [LLVM configuration] - targets <- readAndParse "llvm-targets" - passes <- readAndParse "llvm-passes" - return $ LlvmConfig { llvmTargets = fmap mkLlvmTarget <$> targets, - llvmPasses = passes } - where - readAndParse :: Read a => String -> IO a - readAndParse name = - do let llvmConfigFile = top_dir </> name - llvmConfigStr <- readFile llvmConfigFile - case maybeReadFuzzy llvmConfigStr of - Just s -> return s - Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile) - - mkLlvmTarget :: (String, String, String) -> LlvmTarget - mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) - initSysTools :: String -- TopDir path -> IO Settings -- Set all the mutable variables above, holding diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index ce741e2c1a..312ec7897a 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -14,8 +14,7 @@ import GHC.Platform import GHC.ForeignSrcLang import GHC.IO (catchException) -import GHC.CmmToLlvm.Base (llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound) -import GHC.CmmToLlvm.Config (LlvmVersion) +import GHC.CmmToLlvm.Config (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound) import GHC.SysTools.Process import GHC.SysTools.Info diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 1036748a8a..9f0d7a81fd 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -407,6 +407,7 @@ Library GHC.Driver.Flags GHC.Driver.GenerateCgIPEStub GHC.Driver.Hooks + GHC.Driver.LlvmConfigCache GHC.Driver.Main GHC.Driver.Make GHC.Driver.MakeFile |