[Git][ghc/ghc][master] DynFlags: don't store buildTag
Marge Bot
gitlab at gitlab.haskell.org
Sat Jun 27 15:57:18 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a04020b8 by Sylvain Henry at 2020-06-27T11:57:11-04:00
DynFlags: don't store buildTag
`DynFlags.buildTag` was a field created from the set of Ways in
`DynFlags.ways`. It had to be kept in sync with `DynFlags.ways` which
was fragile. We want to avoid global state like this (#17957).
Moreover in #14335 we also want to support loading units with different
ways: target units would still use `DynFlags.ways` but plugins would use
`GHC.Driver.Ways.hostFullWays`. To avoid having to deal both with build
tag and with ways, we recompute the buildTag on-the-fly (should be
pretty cheap) and we remove `DynFlags.buildTag` field.
- - - - -
9 changed files:
- compiler/GHC/Driver/Finder.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Driver/Ways.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Runtime/Linker.hs
- compiler/GHC/SysTools.hs
- ghc/Main.hs
Changes:
=====================================
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
=====================================
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"
}
=====================================
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.
--
=====================================
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
=====================================
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
=====================================
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.
=====================================
compiler/GHC/Runtime/Linker.hs
=====================================
@@ -954,7 +954,6 @@ dynLoadObjs hsc_env pls at 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
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a04020b88d4935d675f989806aff251f459561e9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a04020b88d4935d675f989806aff251f459561e9
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200627/a4b13554/attachment-0001.html>
More information about the ghc-commits
mailing list