Refactor Logger

Before this patch, the only way to override GHC's default logging
behavior was to set `log_action`, `dump_action` and `trace_action`
fields in DynFlags. This patch introduces a new Logger abstraction and
stores it in HscEnv instead.

This is part of #17957 (avoid storing state in DynFlags). DynFlags are
duplicated and updated per-module (because of OPTIONS_GHC pragma), so
we shouldn't store global state in them.

This patch also fixes a race in parallel "--make" mode which updated
the `generatedDumps` IORef concurrently.

Bump haddock submodule

The increase in MultilayerModules is tracked in #19293.

Metric Increase:
    MultiLayerModules

3 files changed, 34 insertions, 25 deletions

diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 48886ea88f..7dc253b894 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -58,7 +58,7 @@ import GHC.Driver.Config
 import qualified GHC
 import GHC ( LoadHowMuch(..), Target(..),  TargetId(..),
              Resume, SingleStep, Ghc,
-             GetDocsFailure(..),
+             GetDocsFailure(..), putLogMsgM, pushLogHookM,
              getModuleGraph, handleSourceError, ms_mod )
 import GHC.Driver.Main (hscParseDeclsWithLocation, hscParseStmtWithLocation)
 import GHC.Hs.ImpExp
@@ -86,6 +86,7 @@ import GHC.Unit.Module.ModSummary
 
 import GHC.Data.StringBuffer
 import GHC.Utils.Outputable
+import GHC.Utils.Logger
 
 -- Other random utilities
 import GHC.Types.Basic hiding ( isTopLevel )
@@ -478,13 +479,10 @@ interactiveUI config srcs maybe_exprs = do
                $ dflags
    GHC.setInteractiveDynFlags dflags'
 
+   -- Update the LogAction. Ensure we don't override the user's log action lest
+   -- we break -ddump-json (#14078)
    lastErrLocationsRef <- liftIO $ newIORef []
-   progDynFlags <- GHC.getProgramDynFlags
-   _ <- GHC.setProgramDynFlags $
-      -- Ensure we don't override the user's log action lest we break
-      -- -ddump-json (#14078)
-      progDynFlags { log_action = ghciLogAction (log_action progDynFlags)
-                                                lastErrLocationsRef }
+   pushLogHookM (ghciLogAction lastErrLocationsRef)
 
    when (isNothing maybe_exprs) $ do
         -- Only for GHCi (not runghc and ghc -e):
@@ -576,8 +574,8 @@ resetLastErrorLocations = do
     st <- getGHCiState
     liftIO $ writeIORef (lastErrorLocations st) []
 
-ghciLogAction :: LogAction -> IORef [(FastString, Int)] ->  LogAction
-ghciLogAction old_log_action lastErrLocations
+ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction
+ghciLogAction lastErrLocations old_log_action
               dflags flag severity srcSpan msg = do
     old_log_action dflags flag severity srcSpan msg
     case severity of
@@ -3014,10 +3012,11 @@ newDynFlags :: GhciMonad m => Bool -> [String] -> m ()
 newDynFlags interactive_only minus_opts = do
       let lopts = map noLoc minus_opts
 
+      logger <- getLogger
       idflags0 <- GHC.getInteractiveDynFlags
-      (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts
+      (idflags1, leftovers, warns) <- GHC.parseDynamicFlags logger idflags0 lopts
 
-      liftIO $ handleFlagWarnings idflags1 warns
+      liftIO $ handleFlagWarnings logger idflags1 warns
       when (not $ null leftovers)
            (throwGhcException . CmdLineError
             $ "Some flags have not been recognized: "
@@ -3031,7 +3030,7 @@ newDynFlags interactive_only minus_opts = do
       dflags0 <- getDynFlags
 
       when (not interactive_only) $ do
-        (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
+        (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags logger dflags0 lopts
         must_reload <- GHC.setProgramDynFlags dflags1
 
         -- if the package flags changed, reset the context and link
@@ -3168,8 +3167,7 @@ showCmd str = do
             , action "bindings"   $ showBindings
             , action "linker"     $ do
                msg <- liftIO $ Loader.showLoaderState (hsc_loader hsc_env)
-               dflags <- getDynFlags
-               liftIO $ putLogMsg dflags NoReason SevDump noSrcSpan msg
+               putLogMsgM NoReason SevDump noSrcSpan msg
             , action "breaks"     $ showBkptTable
             , action "context"    $ showContext
             , action "packages"   $ showUnits
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index b371a9b8b4..ed06d81d75 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -57,6 +57,7 @@ import GHCi.RemoteTypes
 import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
 import GHC.Hs.Utils
 import GHC.Utils.Misc
+import GHC.Utils.Logger
 
 import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch)
 import Numeric
@@ -307,13 +308,20 @@ instance MonadIO GHCi where
 instance HasDynFlags GHCi where
   getDynFlags = getSessionDynFlags
 
+instance HasLogger GHCi where
+  getLogger = hsc_logger <$> getSession
+
 instance GhcMonad GHCi where
   setSession s' = liftGhc $ setSession s'
   getSession    = liftGhc $ getSession
 
+
 instance HasDynFlags (InputT GHCi) where
   getDynFlags = lift getDynFlags
 
+instance HasLogger (InputT GHCi) where
+  getLogger = lift getLogger
+
 instance GhcMonad (InputT GHCi) where
   setSession = lift . setSession
   getSession = lift getSession
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 12acd5a479..a916820015 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -57,6 +57,7 @@ import GHC.Utils.Panic
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Monad       ( liftIO )
 import GHC.Utils.Binary        ( openBinMem, put_ )
+import GHC.Utils.Logger
 
 import GHC.Settings.Config
 import GHC.Settings.Constants
@@ -151,6 +152,8 @@ 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
   -- the -fllvm and -fasm flags.  If the default backend is not
@@ -192,7 +195,7 @@ main' postLoadMode dflags0 args flagWarnings = do
         -- The rest of the arguments are "dynamic"
         -- Leftover ones are presumably files
   (dflags3, fileish_args, dynamicFlagWarnings) <-
-      GHC.parseDynamicFlags dflags2 args
+      GHC.parseDynamicFlags logger dflags2 args
 
   let dflags4 = case bcknd of
                 Interpreter | not (gopt Opt_ExternalInterpreter dflags3) ->
@@ -215,7 +218,7 @@ main' postLoadMode dflags0 args flagWarnings = do
   handleSourceError (\e -> do
        GHC.printException e
        liftIO $ exitWith (ExitFailure 1)) $ do
-         liftIO $ handleFlagWarnings dflags4 flagWarnings'
+         liftIO $ handleFlagWarnings logger dflags4 flagWarnings'
 
   liftIO $ showBanner postLoadMode dflags4
 
@@ -252,7 +255,7 @@ main' postLoadMode dflags0 args flagWarnings = do
        DoFrontend f           -> doFrontend f srcs
        DoBackpack             -> doBackpack (map fst srcs)
 
-  liftIO $ dumpFinalStats dflags6
+  liftIO $ dumpFinalStats logger dflags6
 
 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
 #if !defined(HAVE_INTERNAL_INTERPRETER)
@@ -753,12 +756,12 @@ showUsage ghci dflags = do
      dump ('$':'$':s) = putStr progName >> dump s
      dump (c:s)       = putChar c >> dump s
 
-dumpFinalStats :: DynFlags -> IO ()
-dumpFinalStats dflags =
-  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
+dumpFinalStats :: Logger -> DynFlags -> IO ()
+dumpFinalStats logger dflags =
+  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats logger dflags
 
-dumpFastStringStats :: DynFlags -> IO ()
-dumpFastStringStats dflags = do
+dumpFastStringStats :: Logger -> DynFlags -> IO ()
+dumpFastStringStats logger dflags = do
   segments <- getFastStringTable
   hasZ <- getFastStringZEncCounter
   let buckets = concat segments
@@ -779,14 +782,14 @@ dumpFastStringStats 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 dflags msg
+  putMsg logger dflags 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_dflags hsc_env) (pprUnits (hsc_units hsc_env))
-dumpUnitsSimple hsc_env = putMsg (hsc_dflags hsc_env) (pprUnitsSimple (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))
 
 -- -----------------------------------------------------------------------------
 -- Frontend plugin support