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

8 files changed, 56 insertions, 35 deletions

diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index e3dec46f91..4d072fff5f 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -61,6 +61,7 @@ import GHC.Types.SrcLoc
 import GHC.Utils.Misc
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
+import GHC.Utils.Logger
 import GHC.Data.FastString
 import GHC.Data.Bag
 import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)
@@ -199,6 +200,7 @@ tcDeriving deriv_infos deriv_decls
         ; insts2 <- mapM genInst infer_specs
 
         ; dflags <- getDynFlags
+        ; logger <- getLogger
 
         ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)
         ; loc <- getSrcSpanM
@@ -233,7 +235,7 @@ tcDeriving deriv_infos deriv_decls
         ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds
 
         ; unless (isEmptyBag inst_info) $
-             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+             liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Derived instances"
                         FormatHaskell
                         (ddump_deriving inst_info rn_binds famInsts))
 
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index e04f22be8f..61b09e27e0 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -119,6 +119,7 @@ import GHC.Utils.Misc
 import GHC.Utils.Panic as Panic
 import GHC.Utils.Lexeme
 import GHC.Utils.Outputable
+import GHC.Utils.Logger
 
 import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) )
 
@@ -1135,7 +1136,8 @@ instance TH.Quasi TcM where
 
   qAddTempFile suffix = do
     dflags <- getDynFlags
-    liftIO $ newTempName dflags TFL_GhcSession suffix
+    logger <- getLogger
+    liftIO $ newTempName logger dflags TFL_GhcSession suffix
 
   qAddTopDecls thds = do
       l <- getSrcSpanM
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 75a5bda5fe..084a98883d 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -128,6 +128,7 @@ import GHC.Utils.Error
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Misc
+import GHC.Utils.Logger
 
 import GHC.Types.Error
 import GHC.Types.Name.Reader
@@ -193,7 +194,7 @@ tcRnModule :: HscEnv
 tcRnModule hsc_env mod_sum save_rn_syntax
    parsedModule@HsParsedModule {hpm_module= L loc this_module}
  | RealSrcSpan real_loc _ <- loc
- = withTiming dflags
+ = withTiming logger dflags
               (text "Renamer/typechecker"<+>brackets (ppr this_mod))
               (const ()) $
    initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
@@ -206,7 +207,8 @@ tcRnModule hsc_env mod_sum save_rn_syntax
 
   where
     hsc_src = ms_hsc_src mod_sum
-    dflags = hsc_dflags hsc_env
+    dflags  = hsc_dflags hsc_env
+    logger  = hsc_logger hsc_env
     home_unit = hsc_home_unit hsc_env
     err_msg = mkPlainMsgEnvelope loc $
               text "Module does not have a RealSrcSpan:" <+> ppr this_mod
@@ -296,7 +298,7 @@ tcRnModuleTcRnM hsc_env mod_sum
                                  tcRnSrcDecls explicit_mod_hdr local_decls export_ies
 
                ; whenM (goptM Opt_DoCoreLinting) $
-                 lintGblEnv (hsc_dflags hsc_env) tcg_env
+                 lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env
 
                ; setGblEnv tcg_env
                  $ do { -- Process the export list
@@ -2889,7 +2891,7 @@ tcDump env
 
         -- Dump short output if -ddump-types or -ddump-tc
         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
-          (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types)
+          (dumpTcRn True Opt_D_dump_types
             "" FormatText (pprWithUnitState unit_state short_dump)) ;
 
         -- Dump bindings if -ddump-tc
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index d92d8e3d5c..bc9680c233 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -152,7 +152,6 @@ import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very lo
 import GHC.Core.Coercion
 import GHC.Core.Unify
 
-import GHC.Utils.Error
 import GHC.Tc.Types.Evidence
 import GHC.Core.Class
 import GHC.Core.TyCon
@@ -168,6 +167,7 @@ import GHC.Types.Var.Env
 import GHC.Types.Var.Set
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
+import GHC.Utils.Logger
 import GHC.Data.Bag as Bag
 import GHC.Types.Unique.Supply
 import GHC.Utils.Misc
@@ -2986,7 +2986,7 @@ csTraceTcM mk_doc
                   || dopt Opt_D_dump_tc_trace dflags )
               ( do { msg <- mk_doc
                    ; TcM.dumpTcRn False
-                       (dumpOptionsFromFlag Opt_D_dump_cs_trace)
+                       Opt_D_dump_cs_trace
                        "" FormatText
                        msg }) }
 {-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 469ef20778..2fb7c58101 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -71,6 +71,7 @@ import GHC.Types.Fixity
 import GHC.Driver.Session
 import GHC.Driver.Ppr
 import GHC.Utils.Error
+import GHC.Utils.Logger
 import GHC.Data.FastString
 import GHC.Types.Id
 import GHC.Types.SourceText
@@ -2056,6 +2057,7 @@ mkDefMethBind :: DFunId -> Class -> Id -> Name
 -- visible type application here
 mkDefMethBind dfun_id clas sel_id dm_name
   = do  { dflags <- getDynFlags
+        ; logger <- getLogger
         ; dm_id <- tcLookupId dm_name
         ; let inline_prag = idInlinePragma dm_id
               inline_prags | isAnyInlinePragma inline_prag
@@ -2072,7 +2074,7 @@ mkDefMethBind dfun_id clas sel_id dm_name
               bind = noLoc $ mkTopFunBind Generated fn $
                              [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
 
-        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
+        ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body"
                    FormatHaskell
                    (vcat [ppr clas <+> ppr inst_tys,
                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index c7a78901f4..aad52c5d93 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -142,6 +142,7 @@ import GHC.Utils.Outputable
 import GHC.Utils.Fingerprint
 import GHC.Utils.Misc
 import GHC.Utils.Panic
+import GHC.Utils.Logger
 
 import GHC.Builtin.Names ( isUnboundName )
 
@@ -236,6 +237,9 @@ data Env gbl lcl
 instance ContainsDynFlags (Env gbl lcl) where
     extractDynFlags env = hsc_dflags (env_top env)
 
+instance ContainsLogger (Env gbl lcl) where
+    extractLogger env = hsc_logger (env_top env)
+
 instance ContainsModule gbl => ContainsModule (Env gbl lcl) where
     extractModule env = extractModule (env_gbl env)
 
@@ -1712,8 +1716,8 @@ getRoleAnnots bndrs role_env
 
 -- | Check the 'TcGblEnv' for consistency. Currently, only checks
 -- axioms, but should check other aspects, too.
-lintGblEnv :: DynFlags -> TcGblEnv -> TcM ()
-lintGblEnv dflags tcg_env =
-  liftIO $ lintAxioms dflags (text "TcGblEnv axioms") axioms
+lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM ()
+lintGblEnv logger dflags tcg_env =
+  liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms
   where
     axioms = typeEnvCoAxioms (tcg_type_env tcg_env)
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 9a38a9c5be..066755e8f7 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -363,7 +363,7 @@ tcRnCheckUnit ::
     HscEnv -> Unit ->
     IO (Messages DecoratedSDoc, Maybe ())
 tcRnCheckUnit hsc_env uid =
-   withTiming dflags
+   withTiming logger dflags
               (text "Check unit id" <+> ppr uid)
               (const ()) $
    initTc hsc_env
@@ -374,6 +374,7 @@ tcRnCheckUnit hsc_env uid =
     $ checkUnit uid
   where
    dflags = hsc_dflags hsc_env
+   logger = hsc_logger hsc_env
    loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)
 
 -- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...
@@ -383,13 +384,14 @@ tcRnCheckUnit hsc_env uid =
 tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
                     -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)
 tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
-  withTiming dflags
+  withTiming logger dflags
              (text "Signature merging" <+> brackets (ppr this_mod))
              (const ()) $
   initTc hsc_env HsigFile False this_mod real_loc $
     mergeSignatures hpm orig_tcg_env iface
  where
   dflags   = hsc_dflags hsc_env
+  logger   = hsc_logger hsc_env
   this_mod = mi_module iface
   real_loc = tcg_top_loc orig_tcg_env
 
@@ -914,12 +916,13 @@ tcRnInstantiateSignature ::
     HscEnv -> Module -> RealSrcSpan ->
     IO (Messages DecoratedSDoc, Maybe TcGblEnv)
 tcRnInstantiateSignature hsc_env this_mod real_loc =
-   withTiming dflags
+   withTiming logger dflags
               (text "Signature instantiation"<+>brackets (ppr this_mod))
               (const ()) $
    initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
   where
    dflags = hsc_dflags hsc_env
+   logger = hsc_logger hsc_env
 
 exportOccs :: [AvailInfo] -> [OccName]
 exportOccs = concatMap (map occName . availNames)
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index c92da610fb..0c276d9e16 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -187,6 +187,7 @@ import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Error
 import GHC.Utils.Panic
 import GHC.Utils.Misc
+import GHC.Utils.Logger
 
 import GHC.Types.Error
 import GHC.Types.Fixity.Env
@@ -752,14 +753,14 @@ formatTraceMsg herald doc = hang (text herald) 2 doc
 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
 traceOptTcRn flag doc =
   whenDOptM flag $
-    dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc
+    dumpTcRn False flag "" FormatText doc
 {-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
 
 -- | Dump if the given 'DumpFlag' is set.
 dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
 dumpOptTcRn flag title fmt doc =
   whenDOptM flag $
-    dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc
+    dumpTcRn False flag title fmt doc
 {-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
 
 -- | Unconditionally dump some trace output
@@ -769,15 +770,16 @@ dumpOptTcRn flag title fmt doc =
 -- generally we want all other debugging output to use 'PprDump'
 -- style. We 'PprUser' style if 'useUserStyle' is True.
 --
-dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn ()
-dumpTcRn useUserStyle dumpOpt title fmt doc = do
+dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
+dumpTcRn useUserStyle flag title fmt doc = do
   dflags <- getDynFlags
+  logger <- getLogger
   printer <- getPrintUnqualified
   real_doc <- wrapDocLoc doc
   let sty = if useUserStyle
               then mkUserStyle printer AllTheWay
               else mkDumpStyle printer
-  liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc
+  liftIO $ putDumpMsg logger dflags sty flag title fmt real_doc
 
 -- | Add current location if -dppr-debug
 -- (otherwise the full location is usually way too much)
@@ -799,10 +801,11 @@ getPrintUnqualified
 
 -- | Like logInfoTcRn, but for user consumption
 printForUserTcRn :: SDoc -> TcRn ()
-printForUserTcRn doc
-  = do { dflags <- getDynFlags
-       ; printer <- getPrintUnqualified
-       ; liftIO (printOutputForUser dflags printer doc) }
+printForUserTcRn doc = do
+    dflags <- getDynFlags
+    logger <- getLogger
+    printer <- getPrintUnqualified
+    liftIO (printOutputForUser logger dflags printer doc)
 
 {-
 traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
@@ -819,9 +822,10 @@ traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
 
 traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
 traceOptIf flag doc
-  = whenDOptM flag $    -- No RdrEnv available, so qualify everything
-    do { dflags <- getDynFlags
-       ; liftIO (putMsg dflags doc) }
+  = whenDOptM flag $ do   -- No RdrEnv available, so qualify everything
+        dflags <- getDynFlags
+        logger <- getLogger
+        liftIO (putMsg logger dflags doc)
 {-# INLINE traceOptIf #-}  -- see Note [INLINE conditional tracing utilities]
 
 {-
@@ -2058,13 +2062,14 @@ failIfM :: SDoc -> IfL a
 -- The Iface monad doesn't have a place to accumulate errors, so we
 -- just fall over fast if one happens; it "shouldn't happen".
 -- We use IfL here so that we can get context info out of the local env
-failIfM msg
-  = do  { env <- getLclEnv
-        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
-        ; dflags <- getDynFlags
-        ; liftIO (putLogMsg dflags NoReason SevFatal
-                   noSrcSpan $ withPprStyle defaultErrStyle full_msg)
-        ; failM }
+failIfM msg = do
+    env <- getLclEnv
+    let full_msg = (if_loc env <> colon) $$ nest 2 msg
+    dflags <- getDynFlags
+    logger <- getLogger
+    liftIO (putLogMsg logger dflags NoReason SevFatal
+             noSrcSpan $ withPprStyle defaultErrStyle full_msg)
+    failM
 
 --------------------
 
@@ -2093,9 +2098,10 @@ forkM_maybe doc thing_inside
                 -- happen when compiling interface signatures (see tcInterfaceSigs)
                   whenDOptM Opt_D_dump_if_trace $ do
                       dflags <- getDynFlags
+                      logger <- getLogger
                       let msg = hang (text "forkM failed:" <+> doc)
                                    2 (text (show exn))
-                      liftIO $ putLogMsg dflags
+                      liftIO $ putLogMsg logger dflags
                                          NoReason
                                          SevFatal
                                          noSrcSpan