[Git][ghc/ghc][wip/romes/better-main] driver: Move DynFlags consistency fixes off Main
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Wed Mar 12 14:04:36 UTC 2025
Rodrigo Mesquita pushed to branch wip/romes/better-main at Glasgow Haskell Compiler / GHC
Commits:
077c9ff8 by Rodrigo Mesquita at 2025-03-12T14:04:21+00:00
driver: Move DynFlags consistency fixes off Main
These consistency fixes found in Main.hs are required for the proper
functioning of the compiler and should live together with all remaining
fixes in `makeDynFlagsConsistent`.
This is especially relevant to GHC applications that shouldn't have to
copy/fix themselves possibly inconsistent DynFlags.
Additionally, outputs information when verbosity is high about these
consistency fixes that were previously quiet, adds information to the
Note on consistency of DynFlags, and improves one of the fixes that
incorrectly used `dynNow`.
- - - - -
7 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- utils/check-exact/Parsers.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -918,7 +918,7 @@ parseDynamicFlags
-> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
parseDynamicFlags logger dflags cmdline = do
- (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
+ (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine logger dflags cmdline
-- flags that have just been read are used by the logger when loading package
-- env (this is checked by T16318)
let logger1 = setLogFlags logger (initLogFlags dflags1)
@@ -1015,11 +1015,13 @@ normalise_hyp fp
checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags logger dflags = do
-- See Note [DynFlags consistency]
- let (dflags', warnings) = makeDynFlagsConsistent dflags
+ let (dflags', warnings, infoverb) = makeDynFlagsConsistent dflags
let diag_opts = initDiagOpts dflags
print_config = initPrintConfig dflags
liftIO $ printOrThrowDiagnostics logger print_config diag_opts
$ fmap GhcDriverMessage $ warnsToMessages diag_opts warnings
+ when (logVerbAtLeast logger 3) $
+ mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb
return dflags'
checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -100,8 +100,9 @@ doBackpack [src_filename] = do
dflags0 <- getDynFlags
let dflags1 = dflags0
let parser_opts1 = initParserOpts dflags1
+ logger0 <- getLogger
(p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 (supportedLanguagePragmas dflags1) src_filename
- (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
+ (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma logger0 dflags1 src_opts
modifySession (hscSetFlags dflags)
logger <- getLogger -- Get the logger after having set the session flags,
-- so that logger options are correctly set.
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -655,10 +655,11 @@ runUnlitPhase hsc_env input_fn output_fn = do
getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages DriverMessage))
getFileArgs hsc_env input_fn = do
let dflags0 = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
parser_opts = initParserOpts dflags0
(warns0, src_opts) <- getOptionsFromFile parser_opts (supportedLanguagePragmas dflags0) input_fn
(dflags1, unhandled_flags, warns)
- <- parseDynamicFilePragma dflags0 src_opts
+ <- parseDynamicFilePragma logger dflags0 src_opts
checkProcessArgsResult unhandled_flags
return (dflags1, warns0, warns)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -247,6 +247,7 @@ import GHC.Driver.Plugins.External
import GHC.Settings.Config
import GHC.Core.Unfold
import GHC.Driver.CmdLine
+import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Constants (debugIsOn)
@@ -265,7 +266,7 @@ import GHC.Data.FastString
import GHC.Utils.TmpFs
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
-import GHC.Utils.Error (emptyDiagOpts)
+import GHC.Utils.Error (emptyDiagOpts, logInfo)
import GHC.Settings
import GHC.CmmToAsm.CFG.Weight
import GHC.Core.Opt.CallerCC
@@ -806,7 +807,7 @@ updOptLevel n = fst . updOptLevelChanged n
-- the parsed 'DynFlags', the left-over arguments, and a list of warnings.
-- Throws a 'UsageError' if errors occurred during parsing (such as unknown
-- flags or missing arguments).
-parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String]
+parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
@@ -816,7 +817,7 @@ parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True
-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags
-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).
-- Used to parse flags set in a modules pragma.
-parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String]
+parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
@@ -865,10 +866,11 @@ parseDynamicFlagsFull
:: forall m. MonadIO m
=> [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against
-> Bool -- ^ are the arguments from the command line?
+ -> Logger -- ^ logger
-> DynFlags -- ^ current dynamic flags
-> [Located String] -- ^ arguments to parse
-> m (DynFlags, [Located String], Messages DriverMessage)
-parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
+parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do
((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args
-- See Note [Handling errors when parsing command-line flags]
@@ -884,7 +886,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
throwGhcExceptionIO (CmdLineError ("combination not supported: " ++
intercalate "/" (map wayDesc (Set.toAscList theWays))))
- let (dflags3, consistency_warnings) = makeDynFlagsConsistent dflags2
+ let (dflags3, consistency_warnings, infoverb) = makeDynFlagsConsistent dflags2
-- Set timer stats & heap size
when (enableTimeStats dflags3) $ liftIO enableTimingStats
@@ -898,6 +900,9 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
let diag_opts = initDiagOpts dflags3
warns = warnsToMessages diag_opts $ mconcat [consistency_warnings, sh_warns, cli_warns]
+ when (logVerbAtLeast logger 3) $
+ mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb
+
return (dflags3, leftover, warns)
-- | Check (and potentially disable) any extensions that aren't allowed
@@ -3491,12 +3496,35 @@ combination when parsing flags, we also need to check when we update
the flags; this is because API clients may parse flags but update the
DynFlags afterwords, before finally running code inside a session (see
T10052 and #10052).
+
+Host ways vs Build ways mismatch
+--------------------------------
+Many consistency checks aim to fix the situation where the wanted build ways
+are not compatible with the ways the compiler is built in. This happens when
+using the interpreter, TH, and the runtime linker, where the compiler cannot
+load objects compiled for ways not matching its own.
+
+For instance, a profiled-dynamic object can only be loaded by a
+profiled-dynamic compiler (and not any other kind of compiler).
+
+This incompatibility is traditionally solved in either of two ways:
+
+(1) Force the "wanted" build ways to match the compiler ways exactly,
+ guaranteeing they match.
+
+(2) Force the use of the external interpreter. When interpreting is offloaded
+ to the external interpreter it no longer matters what are the host compiler ways.
+
+In the checks and fixes performed by `makeDynFlagsConsistent`, the choice
+between the two does not seem uniform. TODO: Make this choice more evident and uniform.
-}
-- | Resolve any internal inconsistencies in a set of 'DynFlags'.
-- Returns the consistent 'DynFlags' as well as a list of warnings
--- to report to the user.
-makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn])
+-- to report to the user, and a list of verbose info msgs.
+--
+-- See Note [DynFlags consistency]
+makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn], [Located SDoc])
-- Whenever makeDynFlagsConsistent does anything, it starts over, to
-- ensure that a later change doesn't invalidate an earlier check.
-- Be careful not to introduce potential loops!
@@ -3587,13 +3615,41 @@ makeDynFlagsConsistent dflags
| LinkMergedObj <- ghcLink dflags
, Nothing <- outputFile dflags
- = pgmError "--output must be specified when using --merge-objs"
+ = pgmError "--output must be specified when using --merge-objs"
+
+ -- When we do ghci, force using dyn ways if the target RTS linker
+ -- only supports dynamic code
+ | LinkInMemory <- ghcLink dflags
+ , sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags
+ , not (ways dflags `hasWay` WayDyn && gopt Opt_ExternalInterpreter dflags)
+ = flip loopNoWarn "Forcing dynamic way because target RTS linker only supports dynamic code" $
+ -- See checkOptions, -fexternal-interpreter is
+ -- required when using --interactive with a non-standard
+ -- way (-prof, -static, or -dynamic).
+ setGeneralFlag' Opt_ExternalInterpreter $
+ addWay' WayDyn dflags
- | otherwise = (dflags, mempty)
+ | LinkInMemory <- ghcLink dflags
+ , not (gopt Opt_ExternalInterpreter dflags)
+ , targetWays_ dflags /= hostFullWays
+ = flip loopNoWarn "Forcing build ways to match the compiler ways because we're using the internal interpreter" $
+ let dflags_a = dflags { targetWays_ = hostFullWays }
+ dflags_b = foldl gopt_set dflags_a
+ $ concatMap (wayGeneralFlags platform)
+ hostFullWays
+ dflags_c = foldl gopt_unset dflags_b
+ $ concatMap (wayUnsetGeneralFlags platform)
+ hostFullWays
+ in dflags_c
+
+ | otherwise = (dflags, mempty, mempty)
where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")
loop updated_dflags warning
= case makeDynFlagsConsistent updated_dflags of
- (dflags', ws) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws)
+ (dflags', ws, is) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws, is)
+ loopNoWarn updated_dflags doc
+ = case makeDynFlagsConsistent updated_dflags of
+ (dflags', ws, is) -> (dflags', ws, L loc (text doc):is)
platform = targetPlatform dflags
arch = platformArch platform
os = platformOS platform
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3148,7 +3148,7 @@ newDynFlags interactive_only minus_opts = do
logger <- getLogger
idflags0 <- GHC.getInteractiveDynFlags
- (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts
+ (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger idflags0 lopts
liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)
when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)
@@ -3161,7 +3161,7 @@ newDynFlags interactive_only minus_opts = do
dflags0 <- getDynFlags
when (not interactive_only) $ do
- (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine dflags0 lopts
+ (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine logger dflags0 lopts
must_reload <- GHC.setProgramDynFlags dflags1
-- if the package flags changed, reset the context and link
=====================================
ghc/Main.hs
=====================================
@@ -224,41 +224,9 @@ main' postLoadMode units dflags0 args flagWarnings = do
-- The rest of the arguments are "dynamic"
-- Leftover ones are presumably files
- (dflags3', fileish_args, dynamicFlagWarnings) <-
+ (dflags4, fileish_args, dynamicFlagWarnings) <-
GHC.parseDynamicFlags logger2 dflags2 args'
- -- When we do ghci, force using dyn ways if the target RTS linker
- -- only supports dynamic code
- let dflags3
- | LinkInMemory <- link,
- sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags3'
- = setDynamicNow $
- -- See checkOptions below, -fexternal-interpreter is
- -- required when using --interactive with a non-standard
- -- way (-prof, -static, or -dynamic).
- setGeneralFlag' Opt_ExternalInterpreter $
- -- Use .o for dynamic object, otherwise it gets dropped
- -- with "Warning: ignoring unrecognised input", see
- -- objish_suffixes
- dflags3' { dynObjectSuf_ = objectSuf dflags3' }
- | otherwise
- = dflags3'
-
- let dflags4 = if backendNeedsFullWays bcknd &&
- not (gopt Opt_ExternalInterpreter dflags3)
- then
- let platform = targetPlatform dflags3
- dflags3a = dflags3 { targetWays_ = hostFullWays }
- dflags3b = foldl gopt_set dflags3a
- $ concatMap (wayGeneralFlags platform)
- hostFullWays
- dflags3c = foldl gopt_unset dflags3b
- $ concatMap (wayUnsetGeneralFlags platform)
- hostFullWays
- in dflags3c
- else
- dflags3
-
let logger4 = setLogFlags logger2 (initLogFlags dflags4)
GHC.prettyPrintGhcErrors logger4 $ do
@@ -804,7 +772,7 @@ initMulti unitArgsFiles = do
dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do
when (verbosity initial_dflags > 2) (liftIO $ print f)
args <- liftIO $ expandResponse [f]
- (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine initial_dflags (map (mkGeneralLocated f) (removeRTS args))
+ (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine logger initial_dflags (map (mkGeneralLocated f) (removeRTS args))
handleSourceError (\e -> do
GHC.printException e
liftIO $ exitWith (ExitFailure 1)) $ do
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -348,12 +348,14 @@ initDynFlags file = do
-- Based on GHC backpack driver doBackPack
dflags0 <- GHC.getSessionDynFlags
let parser_opts0 = GHC.initParserOpts dflags0
+ logger <- GHC.getLogger
(_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 (GHC.supportedLanguagePragmas dflags0) file
- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts
+ (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 src_opts
-- Turn this on last to avoid T10942
let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
-- Prevent parsing of .ghc.environment.* "package environment files"
(dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
+ logger
dflags2
[GHC.noLoc "-hide-all-packages"]
_ <- GHC.setSessionDynFlags dflags3
@@ -375,13 +377,15 @@ initDynFlagsPure fp s = do
-- as long as `parseDynamicFilePragma` is impure there seems to be
-- no reason to use it.
dflags0 <- GHC.getSessionDynFlags
+ logger <- GHC.getLogger
let parser_opts0 = GHC.initParserOpts dflags0
let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.supportedLanguagePragmas dflags0) (GHC.stringToStringBuffer $ s) fp
- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo
+ (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 pragmaInfo
-- Turn this on last to avoid T10942
let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
-- Prevent parsing of .ghc.environment.* "package environment files"
(dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
+ logger
dflags2
[GHC.noLoc "-hide-all-packages"]
_ <- GHC.setSessionDynFlags dflags3
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/077c9ff8fd7ed561983a18813f84056e1cc2967c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/077c9ff8fd7ed561983a18813f84056e1cc2967c
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/20250312/dde0663b/attachment-0001.html>
More information about the ghc-commits
mailing list