diff options
-rw-r--r-- | compiler/GHC/Driver/Finder.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Driver/MakeFile.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 40 | ||||
-rw-r--r-- | compiler/GHC/Driver/Ways.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Usage.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Iface/Binary.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Linker.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/SysTools.hs | 3 | ||||
-rw-r--r-- | ghc/Main.hs | 2 |
9 files changed, 40 insertions, 43 deletions
diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs index f6f0814739..a1b2f9aff0 100644 --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -42,6 +42,7 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Builtin.Names ( gHC_PRIM ) import GHC.Driver.Session +import GHC.Driver.Ways import GHC.Utils.Outputable as Outputable import GHC.Data.Maybe ( expectJust ) @@ -368,7 +369,7 @@ findPackageModule_ hsc_env mod pkg_conf = let dflags = hsc_dflags hsc_env - tag = buildTag dflags + tag = waysBuildTag (ways dflags) -- hi-suffix for packages depends on the build tag. package_hisuf | null tag = "hi" @@ -700,7 +701,7 @@ cantFindErr cannot_find _ dflags mod_name find_result _ -> panic "cantFindErr" - build_tag = buildTag dflags + build_tag = waysBuildTag (ways dflags) not_found_in_package pkg files | build_tag /= "" @@ -809,7 +810,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result _ -> panic "cantFindInstalledErr" - build_tag = buildTag dflags + build_tag = waysBuildTag (ways dflags) pkgstate = unitState dflags looks_like_srcpkgid :: UnitId -> SDoc diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 78d030b6dd..ed963ec733 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -20,7 +20,6 @@ import GHC.Prelude import qualified GHC import GHC.Driver.Monad import GHC.Driver.Session -import GHC.Driver.Ways import GHC.Utils.Misc import GHC.Driver.Types import qualified GHC.SysTools as SysTools @@ -65,7 +64,6 @@ doMkDependHS srcs = do -- be specified. let dflags = dflags0 { ways = Set.empty, - buildTag = waysTag Set.empty, hiSuf = "hi", objectSuf = "o" } diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 2ffcf250b7..a439dbe9aa 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -64,7 +64,7 @@ module GHC.Driver.Session ( optimisationFlags, setFlagsFromEnvFile, - addWay', updateWays, + addWay', homeUnit, mkHomeModule, isHomeModule, @@ -526,7 +526,6 @@ data DynFlags = DynFlags { -- ways ways :: Set Way, -- ^ Way flags from the command line - buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) -- For object splitting splitInfo :: Maybe (String,Int), @@ -1208,9 +1207,8 @@ dynamicTooMkDynamicDynFlags dflags0 hiSuf = dynHiSuf dflags1, objectSuf = dynObjectSuf dflags1 } - dflags3 = updateWays dflags2 - dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo - in dflags4 + dflags3 = gopt_unset dflags2 Opt_BuildDynamicToo + in dflags3 -- | Compute the path of the dynamic object corresponding to an object file. dynamicOutputFile :: DynFlags -> FilePath -> FilePath @@ -1367,7 +1365,6 @@ defaultDynFlags mySettings llvmConfig = unitDatabases = Nothing, unitState = emptyUnitState, ways = defaultWays mySettings, - buildTag = waysTag (defaultWays mySettings), splitInfo = Nothing, ghcNameVersion = sGhcNameVersion mySettings, @@ -2127,47 +2124,40 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do -- check for disabled flags in safe haskell let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 - dflags3 = updateWays dflags2 - theWays = ways dflags3 + theWays = ways dflags2 unless (allowed_combination theWays) $ liftIO $ throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ intercalate "/" (map wayDesc (Set.toAscList theWays)))) let chooseOutput - | isJust (outputFile dflags3) -- Only iff user specified -o ... - , not (isJust (dynOutputFile dflags3)) -- but not -dyno - = return $ dflags3 { dynOutputFile = Just $ dynamicOutputFile dflags3 outFile } + | isJust (outputFile dflags2) -- Only iff user specified -o ... + , not (isJust (dynOutputFile dflags2)) -- but not -dyno + = return $ dflags2 { dynOutputFile = Just $ dynamicOutputFile dflags2 outFile } | otherwise - = return dflags3 + = return dflags2 where - outFile = fromJust $ outputFile dflags3 - dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3) + outFile = fromJust $ outputFile dflags2 + dflags3 <- ifGeneratingDynamicToo dflags2 chooseOutput (return dflags2) - let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4 + let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3 -- Set timer stats & heap size - when (enableTimeStats dflags5) $ liftIO enableTimingStats - case (ghcHeapSize dflags5) of + when (enableTimeStats dflags4) $ liftIO enableTimingStats + case (ghcHeapSize dflags4) of Just x -> liftIO (setHeapSize x) _ -> return () - liftIO $ setUnsafeGlobalDynFlags dflags5 + liftIO $ setUnsafeGlobalDynFlags dflags4 let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) - return (dflags5, leftover, warns' ++ warns) + return (dflags4, leftover, warns' ++ warns) -- | Write an error or warning to the 'LogOutput'. putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO () putLogMsg dflags = log_action dflags dflags -updateWays :: DynFlags -> DynFlags -updateWays dflags - = dflags { - buildTag = waysTag (Set.filter (not . wayRTSOnly) (ways dflags)) - } - -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. -- diff --git a/compiler/GHC/Driver/Ways.hs b/compiler/GHC/Driver/Ways.hs index eae86864d4..c33cf24702 100644 --- a/compiler/GHC/Driver/Ways.hs +++ b/compiler/GHC/Driver/Ways.hs @@ -30,6 +30,7 @@ module GHC.Driver.Ways , wayRTSOnly , wayTag , waysTag + , waysBuildTag -- * Host GHC ways , hostFullWays , hostIsProfiled @@ -70,10 +71,17 @@ allowed_combination ways = not disallowed -- List of disallowed couples of ways couples = [] -- we don't have any disallowed combination of ways nowadays --- | Unique build-tag associated to a list of ways +-- | Unique tag associated to a list of ways waysTag :: Set Way -> String waysTag = concat . intersperse "_" . map wayTag . Set.toAscList +-- | Unique build-tag associated to a list of ways +-- +-- RTS only ways are filtered out because they have no impact on the build. +waysBuildTag :: Set Way -> String +waysBuildTag ws = waysTag (Set.filter (not . wayRTSOnly) ws) + + -- | Unique build-tag associated to a way wayTag :: Way -> String wayTag (WayCustom xs) = xs diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index 567c84625e..0d9d8aabd6 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -186,7 +186,7 @@ mkPluginUsage hsc_env pluginModule if useDyn then libLocs else - let dflags' = updateWays (addWay' WayDyn dflags) + let dflags' = addWay' WayDyn dflags dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc | searchPath <- searchPaths , dlibLoc <- packageHsLibs dflags' pkg diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index 4c676c4d11..d92aa742af 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -43,6 +43,7 @@ import GHC.Driver.Types import GHC.Unit import GHC.Types.Name import GHC.Driver.Session +import GHC.Driver.Ways import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Utils.Panic @@ -58,6 +59,7 @@ import GHC.Data.FastString import GHC.Settings.Constants import GHC.Utils.Misc +import Data.Set (Set) import Data.Array import Data.Array.ST import Data.Array.Unsafe @@ -136,7 +138,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do errorOnMismatch "mismatched interface file versions" our_ver check_ver check_way <- get bh - let way_descr = getWayDescr dflags + let way_descr = getWayDescr platform (ways dflags) wantedGot "Way" way_descr check_way ppr when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file ways" way_descr check_way @@ -191,7 +193,7 @@ writeBinIface dflags hi_path mod_iface = do -- The version and way descriptor go next put_ bh (show hiVersion) - let way_descr = getWayDescr dflags + let way_descr = getWayDescr platform (ways dflags) put_ bh way_descr extFields_p_p <- tellBin bh @@ -428,10 +430,10 @@ data BinDictionary = BinDictionary { -- indexed by FastString } -getWayDescr :: DynFlags -> String -getWayDescr dflags - | platformUnregisterised (targetPlatform dflags) = 'u':tag - | otherwise = tag - where tag = buildTag dflags +getWayDescr :: Platform -> Set Way -> String +getWayDescr platform ws + | platformUnregisterised platform = 'u':tag + | otherwise = tag + where tag = waysBuildTag ws -- if this is an unregisterised build, make sure our interfaces -- can't be used by a registerised build. diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index 68dadc53a4..f94d225889 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -954,7 +954,6 @@ dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do -- the vanilla dynamic libraries, so we set the -- ways / build tag to be just WayDyn. ways = Set.singleton WayDyn, - buildTag = waysTag (Set.singleton WayDyn), outputFile = Just soFile } -- link all "loaded packages" so symbols in those can be resolved diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs index 24a3fefca9..ab83b3bf2a 100644 --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -239,10 +239,9 @@ linkDynLib dflags0 o_files dep_packages dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0 then addWay' WayThreaded dflags0 else dflags0 - dflags2 = if platformMisc_ghcDebugged $ platformMisc dflags1 + dflags = if platformMisc_ghcDebugged $ platformMisc dflags1 then addWay' WayDebug dflags1 else dflags1 - dflags = updateWays dflags2 verbFlags = getVerbFlags dflags o_file = outputFile dflags diff --git a/ghc/Main.hs b/ghc/Main.hs index 14e2b8048c..541c07bdfa 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -198,7 +198,7 @@ main' postLoadMode dflags0 args flagWarnings = do let dflags4 = case lang of HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) -> let platform = targetPlatform dflags3 - dflags3a = updateWays $ dflags3 { ways = hostFullWays } + dflags3a = dflags3 { ways = hostFullWays } dflags3b = foldl gopt_set dflags3a $ concatMap (wayGeneralFlags platform) hostFullWays |