Commit a04020b8 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

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.
parent a74ec37c
Pipeline #21559 failed with stages
in 347 minutes and 11 seconds
......@@ -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
......
......@@ -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"
}
......
......@@ -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.
--
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment