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.

1 files changed, 40 insertions, 42 deletions

diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 99f01c492c..f3fb9d7645 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -577,14 +577,12 @@ initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatab
 initUnits logger dflags cached_dbs = do
 
   let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
-  let ctx     = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages
-  let printer = debugTraceMsg logger dflags             -- printer for trace messages
 
-  (unit_state,dbs) <- withTiming logger dflags (text "initializing unit database")
+  (unit_state,dbs) <- withTiming logger (text "initializing unit database")
                    forceUnitInfoMap
-                 $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs)
+                 $ mkUnitState logger (initUnitConfig dflags cached_dbs)
 
-  dumpIfSet_dyn logger dflags Opt_D_dump_mod_map "Module Map"
+  putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
     FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
                 $ pprModuleMap (moduleNameProvidersMap unit_state))
 
@@ -643,11 +641,11 @@ mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ =
 -- -----------------------------------------------------------------------------
 -- Reading the unit database(s)
 
-readUnitDatabases :: (Int -> SDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId]
-readUnitDatabases printer cfg = do
+readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
+readUnitDatabases logger cfg = do
   conf_refs <- getUnitDbRefs cfg
   confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
-  mapM (readUnitDatabase printer cfg) confs
+  mapM (readUnitDatabase logger cfg) confs
 
 
 getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]
@@ -699,8 +697,8 @@ resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
   if exist then return pkgconf else mzero
 resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
 
-readUnitDatabase :: (Int -> SDoc -> IO ()) -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
-readUnitDatabase printer cfg conf_file = do
+readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
+readUnitDatabase logger cfg conf_file = do
   isdir <- doesDirectoryExist conf_file
 
   proto_pkg_configs <-
@@ -736,21 +734,21 @@ readUnitDatabase printer cfg conf_file = do
       cache_exists <- doesFileExist filename
       if cache_exists
         then do
-          printer 2 $ text "Using binary package database:" <+> text filename
+          debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename
           readPackageDbForGhc filename
         else do
           -- If there is no package.cache file, we check if the database is not
           -- empty by inspecting if the directory contains any .conf file. If it
           -- does, something is wrong and we fail. Otherwise we assume that the
           -- database is empty.
-          printer 2 $ text "There is no package.cache in"
+          debugTraceMsg logger 2 $ text "There is no package.cache in"
                       <+> text conf_dir
                        <> text ", checking if the database is empty"
           db_empty <- all (not . isSuffixOf ".conf")
                    <$> getDirectoryContents conf_dir
           if db_empty
             then do
-              printer 3 $ text "There are no .conf files in"
+              debugTraceMsg logger 3 $ text "There are no .conf files in"
                           <+> text conf_dir <> text ", treating"
                           <+> text "package database as empty"
               return []
@@ -775,7 +773,7 @@ readUnitDatabase printer cfg conf_file = do
           let conf_dir = conf_file <.> "d"
           direxists <- doesDirectoryExist conf_dir
           if direxists
-             then do printer 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
+             then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
                      liftM Just (readDirStyleUnitInfo conf_dir)
              else return (Just []) -- ghc-pkg will create it when it's updated
         else return Nothing
@@ -1030,7 +1028,7 @@ pprTrustFlag flag = case flag of
 type WiringMap = Map UnitId UnitId
 
 findWiredInUnits
-   :: (SDoc -> IO ())      -- debug trace
+   :: Logger
    -> UnitPrecedenceMap
    -> [UnitInfo]           -- database
    -> VisibilityMap             -- info on what units are visible
@@ -1038,7 +1036,7 @@ findWiredInUnits
    -> IO ([UnitInfo],  -- unit database updated for wired in
           WiringMap)   -- map from unit id to wired identity
 
-findWiredInUnits printer prec_map pkgs vis_map = do
+findWiredInUnits logger prec_map pkgs vis_map = do
   -- Now we must find our wired-in units, and rename them to
   -- their canonical names (eg. base-1.0 ==> base), as described
   -- in Note [Wired-in units] in GHC.Unit.Module
@@ -1076,14 +1074,14 @@ findWiredInUnits printer prec_map pkgs vis_map = do
             many -> pick (head (sortByPreference prec_map many))
           where
                 notfound = do
-                          printer $
+                          debugTraceMsg logger 2 $
                             text "wired-in package "
                                  <> ftext (unitIdFS wired_pkg)
                                  <> text " not found."
                           return Nothing
                 pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo))
                 pick pkg = do
-                        printer $
+                        debugTraceMsg logger 2 $
                             text "wired-in package "
                                  <> ftext (unitIdFS wired_pkg)
                                  <> text " mapped to "
@@ -1203,20 +1201,20 @@ pprReason pref reason = case reason of
       pref <+> text "unusable due to shadowed dependencies:" $$
         nest 2 (hsep (map ppr deps))
 
-reportCycles :: (SDoc -> IO ()) -> [SCC UnitInfo] -> IO ()
-reportCycles printer sccs = mapM_ report sccs
+reportCycles :: Logger -> [SCC UnitInfo] -> IO ()
+reportCycles logger sccs = mapM_ report sccs
   where
     report (AcyclicSCC _) = return ()
     report (CyclicSCC vs) =
-        printer $
+        debugTraceMsg logger 2 $
           text "these packages are involved in a cycle:" $$
             nest 2 (hsep (map (ppr . unitId) vs))
 
-reportUnusable :: (SDoc -> IO ()) -> UnusableUnits -> IO ()
-reportUnusable printer pkgs = mapM_ report (Map.toList pkgs)
+reportUnusable :: Logger -> UnusableUnits -> IO ()
+reportUnusable logger pkgs = mapM_ report (Map.toList pkgs)
   where
     report (ipid, (_, reason)) =
-       printer $
+       debugTraceMsg logger 2 $
          pprReason
            (text "package" <+> ppr ipid <+> text "is") reason
 
@@ -1306,15 +1304,15 @@ type UnitPrecedenceMap = Map UnitId Int
 -- units with the same unit id in later databases override
 -- earlier ones.  This does NOT check if the resulting database
 -- makes sense (that's done by 'validateDatabase').
-mergeDatabases :: (SDoc -> IO ()) -> [UnitDatabase UnitId]
+mergeDatabases :: Logger -> [UnitDatabase UnitId]
                -> IO (UnitInfoMap, UnitPrecedenceMap)
-mergeDatabases printer = foldM merge (Map.empty, Map.empty) . zip [1..]
+mergeDatabases logger = foldM merge (Map.empty, Map.empty) . zip [1..]
   where
     merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
-      printer $
+      debugTraceMsg logger 2 $
           text "loading package database" <+> text db_path
       forM_ (Set.toList override_set) $ \pkg ->
-          printer $
+          debugTraceMsg logger 2 $
               text "package" <+> ppr pkg <+>
               text "overrides a previously defined package"
       return (pkg_map', prec_map')
@@ -1397,11 +1395,10 @@ validateDatabase cfg pkg_map1 =
 -- settings and populate the unit state.
 
 mkUnitState
-    :: SDocContext            -- ^ SDocContext used to render exception messages
-    -> (Int -> SDoc -> IO ()) -- ^ Trace printer
+    :: Logger
     -> UnitConfig
     -> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState ctx printer cfg = do
+mkUnitState logger cfg = do
 {-
    Plan.
 
@@ -1457,7 +1454,7 @@ mkUnitState ctx printer cfg = do
 
   -- if databases have not been provided, read the database flags
   raw_dbs <- case unitConfigDBCache cfg of
-               Nothing  -> readUnitDatabases printer cfg
+               Nothing  -> readUnitDatabases logger cfg
                Just dbs -> return dbs
 
   -- distrust all units if the flag is set
@@ -1470,18 +1467,18 @@ mkUnitState ctx printer cfg = do
   -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
   -- than they are on the command line.
   let other_flags = reverse (unitConfigFlagsExposed cfg)
-  printer 2 $
+  debugTraceMsg logger 2 $
       text "package flags" <+> ppr other_flags
 
   -- Merge databases together, without checking validity
-  (pkg_map1, prec_map) <- mergeDatabases (printer 2) dbs
+  (pkg_map1, prec_map) <- mergeDatabases logger dbs
 
   -- Now that we've merged everything together, prune out unusable
   -- packages.
   let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
 
-  reportCycles   (printer 2) sccs
-  reportUnusable (printer 2) unusable
+  reportCycles   logger sccs
+  reportUnusable logger unusable
 
   -- Apply trust flags (these flags apply regardless of whether
   -- or not packages are visible or not)
@@ -1554,7 +1551,7 @@ mkUnitState ctx printer cfg = do
   -- it modifies the unit ids of wired in packages, but when we process
   -- package arguments we need to key against the old versions.
   --
-  (pkgs2, wired_map) <- findWiredInUnits (printer 2) prec_map pkgs1 vis_map2
+  (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
   let pkg_db = mkUnitInfoMap pkgs2
 
   -- Update the visibility map, so we treat wired packages as visible.
@@ -1624,7 +1621,7 @@ mkUnitState ctx printer cfg = do
                     $ closeUnitDeps pkg_db
                     $ zip (map toUnitId preload3) (repeat Nothing)
 
-  let mod_map1 = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet vis_map
+  let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
       mod_map2 = mkUnusableModuleNameProvidersMap unusable
       mod_map = Map.union mod_map1 mod_map2
 
@@ -1635,7 +1632,7 @@ mkUnitState ctx printer cfg = do
          , unitInfoMap                  = pkg_db
          , preloadClosure               = emptyUniqSet
          , moduleNameProvidersMap       = mod_map
-         , pluginModuleNameProvidersMap = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet plugin_vis_map
+         , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
          , packageNameMap               = pkgname_map
          , wireMap                      = wired_map
          , unwireMap                    = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ]
@@ -1659,13 +1656,13 @@ unwireUnit _ uid = uid
 -- packages a bit bothersome.
 
 mkModuleNameProvidersMap
-  :: SDocContext     -- ^ SDocContext used to render exception messages
+  :: Logger
   -> UnitConfig
   -> UnitInfoMap
   -> PreloadUnitClosure
   -> VisibilityMap
   -> ModuleNameProvidersMap
-mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map =
+mkModuleNameProvidersMap logger cfg pkg_map closure vis_map =
     -- What should we fold on?  Both situations are awkward:
     --
     --    * Folding on the visibility map means that we won't create
@@ -1716,7 +1713,8 @@ mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map =
     rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
      where origEntry = case lookupUFM esmap orig of
             Just r -> r
-            Nothing -> throwGhcException (CmdLineError (renderWithContext ctx
+            Nothing -> throwGhcException (CmdLineError (renderWithContext
+                        (log_default_user_context (logFlags logger))
                         (text "package flag: could not find module name" <+>
                             ppr orig <+> text "in package" <+> ppr pk)))