Make Logger independent of DynFlags

Introduce LogFlags as a independent subset of DynFlags used for logging.
As a consequence in many places we don't have to pass both Logger and
DynFlags anymore.

The main reason for this refactoring is that I want to refactor the
systools interfaces: for now many systools functions use DynFlags both
to use the Logger and to fetch their parameters (e.g. ldInputs for the
linker). I'm interested in refactoring the way they fetch their
parameters (i.e. use dedicated XxxOpts data types instead of DynFlags)
for #19877. But if I did this refactoring before refactoring the Logger,
we would have duplicate parameters (e.g. ldInputs from DynFlags and
linkerInputs from LinkerOpts). Hence this patch first.

Some flags don't really belong to LogFlags because they are subsystem
specific (e.g. most DumpFlags). For example -ddump-asm should better be
passed in NCGConfig somehow. This patch doesn't fix this tight coupling:
the dump flags are part of the UI but they are passed all the way down
for example to infer the file name for the dumps.

Because LogFlags are a subset of the DynFlags, we must update the former
when the latter changes (not so often). As a consequence we now use
accessors to read/write DynFlags in HscEnv instead of using `hsc_dflags`
directly.

In the process I've also made some subsystems less dependent on DynFlags:

- CmmToAsm: by passing some missing flags via NCGConfig (see new fields
  in GHC.CmmToAsm.Config)
- Core.Opt.*:
    - by passing -dinline-check value into UnfoldingOpts
    - by fixing some Core passes interfaces (e.g. CallArity, FloatIn)
      that took DynFlags argument for no good reason.
    - as a side-effect GHC.Core.Opt.Pipeline.doCorePass is much less
      convoluted.

3 files changed, 34 insertions, 28 deletions

diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 7176b1e596..001caf1fff 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -51,7 +51,7 @@ import GHC.Driver.Session as DynFlags
 import GHC.Driver.Ppr hiding (printForUser)
 import GHC.Utils.Error hiding (traceCmd)
 import GHC.Driver.Monad ( modifySession )
-import GHC.Driver.Config
+import GHC.Driver.Config.Parser (initParserOpts)
 import qualified GHC
 import GHC ( LoadHowMuch(..), Target(..),  TargetId(..),
              Resume, SingleStep, Ghc,
@@ -3117,9 +3117,10 @@ newDynFlags interactive_only minus_opts = do
             newLdInputs     = drop ld0length (ldInputs dflags2)
             newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
 
-            hsc_env' = hsc_env { hsc_dflags =
-                         dflags2 { ldInputs = newLdInputs
-                                 , cmdlineFrameworks = newCLFrameworks } }
+            dflags'  = dflags2 { ldInputs = newLdInputs
+                               , cmdlineFrameworks = newCLFrameworks
+                               }
+            hsc_env' = hscSetFlags dflags' hsc_env
 
         when (not (null newLdInputs && null newCLFrameworks)) $
           liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'
@@ -4462,11 +4463,11 @@ showException se =
 -- in an exception loop (eg. let a = error a in a) the ^C exception
 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 
-ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
+ghciHandle :: (HasLogger m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
 ghciHandle h m = mask $ \restore -> do
                  -- Force dflags to avoid leaking the associated HscEnv
-                 !dflags <- getDynFlags
-                 catch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
+                 !log <- getLogger
+                 catch (restore (GHC.prettyPrintGhcErrors log m)) $ \e -> restore (h e)
 
 ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)
 ghciTry m = fmap Right m `catch` \e -> return $ Left e
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index 888b536d01..a24c40e804 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -19,7 +19,7 @@ module GHCi.UI.Monad (
         PromptFunction,
         BreakLocation(..),
         TickArray,
-        getDynFlags,
+        extractDynFlags, getDynFlags,
 
         runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,
         ActionStats(..), runAndPrintStats, runWithStats, printStats,
@@ -522,9 +522,8 @@ runInternal :: GhcMonad m => m a -> m a
 runInternal =
     withTempSession mkTempSession
   where
-    mkTempSession hsc_env = hsc_env
-      { hsc_dflags = (hsc_dflags hsc_env) {
-        -- Running GHCi's internal expression is incompatible with -XSafe.
+    mkTempSession = hscUpdateFlags (\dflags -> dflags
+      { -- Running GHCi's internal expression is incompatible with -XSafe.
           -- We temporarily disable any Safe Haskell settings while running
           -- GHCi internal expressions. (see #12509)
         safeHaskell = Sf_None,
@@ -539,7 +538,7 @@ runInternal =
           -- We heavily depend on -fimplicit-import-qualified to compile expr
           -- with fully qualified names without imports.
           `gopt_set` Opt_ImplicitImportQualified
-      }
+      )
 
 compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
 compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 2873cba4ad..9f0dc68ec5 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -29,6 +29,7 @@ import GHC.Driver.Pipeline  ( oneShot, compileFile )
 import GHC.Driver.MakeFile  ( doMkDependHS )
 import GHC.Driver.Backpack  ( doBackpack )
 import GHC.Driver.Plugins
+import GHC.Driver.Config.Logger (initLogFlags)
 
 import GHC.Platform
 import GHC.Platform.Ways
@@ -152,7 +153,6 @@ main = do
 main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
       -> Ghc ()
 main' postLoadMode dflags0 args flagWarnings = do
-  logger <- getLogger
 
   -- set the default GhcMode, backend and GhcLink.  The backend
   -- can be further adjusted on a module by module basis, using only
@@ -192,10 +192,13 @@ main' postLoadMode dflags0 args flagWarnings = do
                                        `gopt_set` Opt_IgnoreOptimChanges
                                        `gopt_set` Opt_IgnoreHpcChanges
 
+  logger1 <- getLogger
+  let logger2 = setLogFlags logger1 (initLogFlags dflags2)
+
         -- The rest of the arguments are "dynamic"
         -- Leftover ones are presumably files
   (dflags3, fileish_args, dynamicFlagWarnings) <-
-      GHC.parseDynamicFlags logger dflags2 args
+      GHC.parseDynamicFlags logger2 dflags2 args
 
   let dflags4 = case bcknd of
                 Interpreter | not (gopt Opt_ExternalInterpreter dflags3) ->
@@ -211,14 +214,16 @@ main' postLoadMode dflags0 args flagWarnings = do
                 _ ->
                     dflags3
 
-  GHC.prettyPrintGhcErrors dflags4 $ do
+  let logger4 = setLogFlags logger2 (initLogFlags dflags4)
+
+  GHC.prettyPrintGhcErrors logger4 $ do
 
   let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
 
   handleSourceError (\e -> do
        GHC.printException e
        liftIO $ exitWith (ExitFailure 1)) $ do
-         liftIO $ handleFlagWarnings logger dflags4 flagWarnings'
+         liftIO $ handleFlagWarnings logger4 dflags4 flagWarnings'
 
   liftIO $ showBanner postLoadMode dflags4
 
@@ -228,6 +233,7 @@ main' postLoadMode dflags0 args flagWarnings = do
   _ <- GHC.setSessionDynFlags dflags5
   dflags6 <- GHC.getSessionDynFlags
   hsc_env <- GHC.getSession
+  logger <- getLogger
 
         ---------------- Display configuration -----------
   case verbosity dflags6 of
@@ -244,7 +250,7 @@ main' postLoadMode dflags0 args flagWarnings = do
        GHC.printException e
        liftIO $ exitWith (ExitFailure 1)) $ do
     case postLoadMode of
-       ShowInterface f        -> liftIO $ showIface (hsc_logger hsc_env)
+       ShowInterface f        -> liftIO $ showIface logger
                                                     (hsc_dflags hsc_env)
                                                     (hsc_units  hsc_env)
                                                     (hsc_NC     hsc_env)
@@ -259,7 +265,7 @@ main' postLoadMode dflags0 args flagWarnings = do
        DoFrontend f           -> doFrontend f srcs
        DoBackpack             -> doBackpack (map fst srcs)
 
-  liftIO $ dumpFinalStats logger dflags6
+  liftIO $ dumpFinalStats logger
 
 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
 #if !defined(HAVE_INTERNAL_INTERPRETER)
@@ -760,19 +766,19 @@ showUsage ghci dflags = do
      dump ('$':'$':s) = putStr progName >> dump s
      dump (c:s)       = putChar c >> dump s
 
-dumpFinalStats :: Logger -> DynFlags -> IO ()
-dumpFinalStats logger dflags = do
-  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats logger dflags
+dumpFinalStats :: Logger -> IO ()
+dumpFinalStats logger = do
+  when (logHasDumpFlag logger Opt_D_faststring_stats) $ dumpFastStringStats logger
 
-  when (dopt Opt_D_dump_faststrings dflags) $ do
+  when (logHasDumpFlag logger Opt_D_dump_faststrings) $ do
     fss <- getFastStringTable
     let ppr_table         = fmap ppr_segment (fss `zip` [0..])
         ppr_segment (s,n) = hang (text "Segment" <+> int n) 2 (vcat (fmap ppr_bucket (s `zip` [0..])))
         ppr_bucket  (b,n) = hang (text "Bucket" <+> int n) 2 (vcat (fmap ftext b))
-    dumpIfSet_dyn logger dflags Opt_D_dump_faststrings "FastStrings" FormatText (vcat ppr_table)
+    putDumpFileMaybe logger Opt_D_dump_faststrings "FastStrings" FormatText (vcat ppr_table)
 
-dumpFastStringStats :: Logger -> DynFlags -> IO ()
-dumpFastStringStats logger dflags = do
+dumpFastStringStats :: Logger -> IO ()
+dumpFastStringStats logger = do
   segments <- getFastStringTable
   hasZ <- getFastStringZEncCounter
   let buckets = concat segments
@@ -793,14 +799,14 @@ dumpFastStringStats logger dflags = do
         -- which is not counted as "z-encoded".  Only strings whose
         -- Z-encoding is different from the original string are counted in
         -- the "z-encoded" total.
-  putMsg logger dflags msg
+  putMsg logger msg
   where
    x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'
 
 showUnits, dumpUnits, dumpUnitsSimple :: HscEnv -> IO ()
 showUnits       hsc_env = putStrLn (showSDoc (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env)))
-dumpUnits       hsc_env = putMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env))
-dumpUnitsSimple hsc_env = putMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) (pprUnitsSimple (hsc_units hsc_env))
+dumpUnits       hsc_env = putMsg (hsc_logger hsc_env) (pprUnits (hsc_units hsc_env))
+dumpUnitsSimple hsc_env = putMsg (hsc_logger hsc_env) (pprUnitsSimple (hsc_units hsc_env))
 
 -- -----------------------------------------------------------------------------
 -- Frontend plugin support