Refactor FinderCache

1 files changed, 88 insertions, 63 deletions

diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index e211f221ab..409cb712f2 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -41,6 +41,7 @@ import GHC.Utils.Misc as Utils hiding ( eqListBy )
 import GHC.Utils.Binary
 import GHC.Utils.Fingerprint
 import GHC.Utils.Exception
+import GHC.Utils.Logger
 
 import GHC.Types.Annotations
 import GHC.Types.Name
@@ -157,10 +158,11 @@ check_old_iface
 
 check_old_iface hsc_env mod_summary src_modified maybe_iface
   = let dflags = hsc_dflags hsc_env
+        logger = hsc_logger hsc_env
         getIface =
             case maybe_iface of
                 Just _  -> do
-                    trace_if dflags (text "We already have the old interface for" <+>
+                    trace_if logger dflags (text "We already have the old interface for" <+>
                       ppr (ms_mod mod_summary))
                     return maybe_iface
                 Nothing -> loadIface
@@ -171,20 +173,20 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface
              read_result <- readIface dflags ncu (ms_mod mod_summary) iface_path
              case read_result of
                  Failed err -> do
-                     trace_if dflags (text "FYI: cannot read old interface file:" $$ nest 4 err)
-                     trace_hi_diffs dflags (text "Old interface file was invalid:" $$ nest 4 err)
+                     trace_if logger dflags (text "FYI: cannot read old interface file:" $$ nest 4 err)
+                     trace_hi_diffs logger dflags (text "Old interface file was invalid:" $$ nest 4 err)
                      return Nothing
                  Succeeded iface -> do
-                     trace_if dflags (text "Read the interface file" <+> text iface_path)
+                     trace_if logger dflags (text "Read the interface file" <+> text iface_path)
                      return $ Just iface
 
         src_changed
-            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
+            | gopt Opt_ForceRecomp dflags    = True
             | SourceModified <- src_modified = True
             | otherwise = False
     in do
         when src_changed $
-            liftIO $ trace_hi_diffs dflags (nest 4 $ text "Source file changed or recompilation check turned off")
+            liftIO $ trace_hi_diffs logger dflags (nest 4 $ text "Source file changed or recompilation check turned off")
 
         case src_changed of
             -- If the source has changed and we're in interactive mode,
@@ -227,7 +229,7 @@ checkVersions :: HscEnv
               -> ModIface       -- Old interface
               -> IfG (RecompileRequired, Maybe ModIface)
 checkVersions hsc_env mod_summary iface
-  = do { liftIO $ trace_hi_diffs dflags
+  = do { liftIO $ trace_hi_diffs logger dflags
                         (text "Considering whether compilation is required for" <+>
                         ppr (mi_module iface) <> colon)
 
@@ -245,7 +247,7 @@ checkVersions hsc_env mod_summary iface
        ; if recompileRequired recomp then return (recomp, Nothing) else do {
        ; recomp <- liftIO $ checkMergedSignatures hsc_env mod_summary iface
        ; if recompileRequired recomp then return (recomp, Nothing) else do {
-       ; recomp <- liftIO $ checkHsig hsc_env mod_summary iface
+       ; recomp <- liftIO $ checkHsig logger home_unit dflags mod_summary iface
        ; if recompileRequired recomp then return (recomp, Nothing) else do {
        ; recomp <- pure (checkHie dflags mod_summary)
        ; if recompileRequired recomp then return (recomp, Nothing) else do {
@@ -274,6 +276,7 @@ checkVersions hsc_env mod_summary iface
        ; return (recomp, Just iface)
     }}}}}}}}}}
   where
+    logger = hsc_logger hsc_env
     dflags = hsc_dflags hsc_env
     home_unit = hsc_home_unit hsc_env
     -- This is a bit of a hack really
@@ -352,15 +355,13 @@ pluginRecompileToRecompileRequired old_fp new_fp pr
 
 -- | Check if an hsig file needs recompilation because its
 -- implementing module has changed.
-checkHsig :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired
-checkHsig hsc_env mod_summary iface = do
-    let home_unit = hsc_home_unit hsc_env
-        dflags    = hsc_dflags hsc_env
-        outer_mod = ms_mod mod_summary
+checkHsig :: Logger -> HomeUnit -> DynFlags -> ModSummary -> ModIface -> IO RecompileRequired
+checkHsig logger home_unit dflags mod_summary iface = do
+    let outer_mod = ms_mod mod_summary
         inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)
     MASSERT( isHomeModule home_unit outer_mod )
     case inner_mod == mi_semantic_module iface of
-        True -> up_to_date dflags (text "implementing module unchanged")
+        True -> up_to_date logger dflags (text "implementing module unchanged")
         False -> return (RecompBecause "implementing module changed")
 
 -- | Check if @.hie@ file is out of date or missing.
@@ -382,11 +383,12 @@ checkHie dflags mod_summary =
 checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired
 checkFlagHash hsc_env iface = do
     let dflags   = hsc_dflags hsc_env
+    let logger   = hsc_logger hsc_env
     let old_hash = mi_flag_hash (mi_final_exts iface)
     new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally
     case old_hash == new_hash of
-        True  -> up_to_date dflags (text "Module flags unchanged")
-        False -> out_of_date_hash dflags "flags changed"
+        True  -> up_to_date logger dflags (text "Module flags unchanged")
+        False -> out_of_date_hash logger dflags "flags changed"
                      (text "  Module flags have changed")
                      old_hash new_hash
 
@@ -394,15 +396,16 @@ checkFlagHash hsc_env iface = do
 checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired
 checkOptimHash hsc_env iface = do
     let dflags   = hsc_dflags hsc_env
+    let logger   = hsc_logger hsc_env
     let old_hash = mi_opt_hash (mi_final_exts iface)
     new_hash <- fingerprintOptFlags (hsc_dflags hsc_env)
                                                putNameLiterally
     if | old_hash == new_hash
-         -> up_to_date dflags (text "Optimisation flags unchanged")
+         -> up_to_date logger dflags (text "Optimisation flags unchanged")
        | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
-         -> up_to_date dflags (text "Optimisation flags changed; ignoring")
+         -> up_to_date logger dflags (text "Optimisation flags changed; ignoring")
        | otherwise
-         -> out_of_date_hash dflags "Optimisation flags changed"
+         -> out_of_date_hash logger dflags "Optimisation flags changed"
                      (text "  Optimisation flags have changed")
                      old_hash new_hash
 
@@ -410,15 +413,16 @@ checkOptimHash hsc_env iface = do
 checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired
 checkHpcHash hsc_env iface = do
     let dflags   = hsc_dflags hsc_env
+    let logger   = hsc_logger hsc_env
     let old_hash = mi_hpc_hash (mi_final_exts iface)
     new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env)
                                                putNameLiterally
     if | old_hash == new_hash
-         -> up_to_date dflags (text "HPC flags unchanged")
+         -> up_to_date logger dflags (text "HPC flags unchanged")
        | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
-         -> up_to_date dflags (text "HPC flags changed; ignoring")
+         -> up_to_date logger dflags (text "HPC flags changed; ignoring")
        | otherwise
-         -> out_of_date_hash dflags "HPC flags changed"
+         -> out_of_date_hash logger dflags "HPC flags changed"
                      (text "  HPC flags have changed")
                      old_hash new_hash
 
@@ -427,6 +431,7 @@ checkHpcHash hsc_env iface = do
 checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired
 checkMergedSignatures hsc_env mod_summary iface = do
     let dflags     = hsc_dflags hsc_env
+    let logger     = hsc_logger hsc_env
     let unit_state = hsc_units hsc_env
     let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
         new_merged = case Map.lookup (ms_mod_name mod_summary)
@@ -434,7 +439,7 @@ checkMergedSignatures hsc_env mod_summary iface = do
                         Nothing -> []
                         Just r -> sort $ map (instModuleToModule unit_state) r
     if old_merged == new_merged
-        then up_to_date dflags (text "signatures to merge in unchanged" $$ ppr new_merged)
+        then up_to_date logger dflags (text "signatures to merge in unchanged" $$ ppr new_merged)
         else return (RecompBecause "signatures to merge in changed")
 
 -- If the direct imports of this module are resolved to targets that
@@ -470,20 +475,23 @@ checkDependencies hsc_env summary iface
              checkIfAllOldHomeDependenciesAreSeen seen_home_deps
            _ -> return recomp]
  where
-   dflags = hsc_dflags hsc_env
+   dflags        = hsc_dflags hsc_env
+   logger        = hsc_logger hsc_env
+   fc            = hsc_FC hsc_env
+   home_unit     = hsc_home_unit hsc_env
+   units         = hsc_units hsc_env
    prev_dep_mods = dep_mods (mi_deps iface)
    prev_dep_plgn = dep_plgins (mi_deps iface)
    prev_dep_pkgs = dep_pkgs (mi_deps iface)
-   home_unit     = hsc_home_unit hsc_env
 
    dep_missing (mb_pkg, L _ mod) = do
-     find_res <- findImportedModule hsc_env mod (mb_pkg)
+     find_res <- findImportedModule fc units home_unit dflags mod (mb_pkg)
      let reason = moduleNameString mod ++ " changed"
      case find_res of
         Found _ mod
           | isHomeUnit home_unit pkg
            -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn
-                 then do trace_hi_diffs dflags $
+                 then do trace_hi_diffs logger dflags $
                            text "imported module " <> quotes (ppr mod) <>
                            text " not among previous dependencies"
                          return (RecompBecause reason)
@@ -491,7 +499,7 @@ checkDependencies hsc_env summary iface
                          return UpToDate
           | otherwise
            -> if toUnitId pkg `notElem` (map fst prev_dep_pkgs)
-                 then do trace_hi_diffs dflags $
+                 then do trace_hi_diffs logger dflags $
                            text "imported module " <> quotes (ppr mod) <>
                            text " is from package " <> quotes (ppr pkg) <>
                            text ", which is not among previous dependencies"
@@ -517,13 +525,13 @@ checkDependencies hsc_env summary iface
      if not (isOldHomeDeps mname)
        then return (UpToDate, [])
        else do
-         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> liftIO $ do
+         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do
            let mnames = mname:(map gwib_mod $ filter ((== NotBoot) . gwib_isBoot) $
                  dep_mods $ mi_deps imported_iface)
            case find (not . isOldHomeDeps) mnames of
              Nothing -> return (UpToDate, mnames)
              Just new_dep_mname -> do
-               trace_hi_diffs dflags $
+               trace_hi_diffs logger dflags $
                  text "imported home module " <> quotes (ppr mod) <>
                  text " has a new dependency " <> quotes (ppr new_dep_mname)
                return (RecompBecause reason, [])
@@ -548,7 +556,7 @@ checkDependencies hsc_env summary iface
      if not (null unseen_old_deps)
        then do
          let missing_dep = Set.elemAt 0 unseen_old_deps
-         trace_hi_diffs dflags $
+         trace_hi_diffs logger dflags $
            text "missing old home dependency " <> quotes (ppr missing_dep)
          return $ RecompBecause "missing old dependency"
        else return UpToDate
@@ -560,18 +568,19 @@ needInterface mod continue
       mb_recomp <- getFromModIface
         "need version info for"
         mod
-        (liftIO . continue)
+        continue
       case mb_recomp of
         Nothing -> return MustCompile
         Just recomp -> return recomp
 
-getFromModIface :: String -> Module -> (ModIface -> IfG a)
+getFromModIface :: String -> Module -> (ModIface -> IO a)
               -> IfG (Maybe a)
 getFromModIface doc_msg mod getter
   = do  -- Load the imported interface if possible
     dflags <- getDynFlags
+    logger <- getLogger
     let doc_str = sep [text doc_msg, ppr mod]
-    liftIO $ trace_hi_diffs dflags (text "Checking innterface for module" <+> ppr mod)
+    liftIO $ trace_hi_diffs logger dflags (text "Checking interface for module" <+> ppr mod)
 
     mb_iface <- loadInterface doc_str mod ImportBySystem
         -- Load the interface, but don't complain on failure;
@@ -579,13 +588,13 @@ getFromModIface doc_msg mod getter
 
     case mb_iface of
       Failed _ -> do
-        liftIO $ trace_hi_diffs dflags (sep [text "Couldn't load interface for module", ppr mod])
+        liftIO $ trace_hi_diffs logger dflags (sep [text "Couldn't load interface for module", ppr mod])
         return Nothing
                   -- Couldn't find or parse a module mentioned in the
                   -- old interface file.  Don't complain: it might
                   -- just be that the current module doesn't need that
                   -- import and it's been deleted
-      Succeeded iface -> Just <$> getter iface
+      Succeeded iface -> Just <$> liftIO (getter iface)
 
 -- | Given the usage information extracted from the old
 -- M.hi file for the module being compiled, figure out
@@ -595,9 +604,10 @@ checkModUsage _this_pkg UsagePackageModule{
                                 usg_mod = mod,
                                 usg_mod_hash = old_mod_hash } = do
   dflags <- getDynFlags
+  logger <- getLogger
   needInterface mod $ \iface -> do
     let reason = moduleNameString (moduleName mod) ++ " changed"
-    checkModuleFingerprint dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
+    checkModuleFingerprint logger dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
         -- We only track the ABI hash of package modules, rather than
         -- individual entity usages, so if the ABI hash changes we must
         -- recompile.  This is safe but may entail more recompilation when
@@ -605,9 +615,10 @@ checkModUsage _this_pkg UsagePackageModule{
 
 checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do
   dflags <- getDynFlags
+  logger <- getLogger
   needInterface mod $ \iface -> do
     let reason = moduleNameString (moduleName mod) ++ " changed (raw)"
-    checkModuleFingerprint dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
+    checkModuleFingerprint logger dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
 
 checkModUsage this_pkg UsageHomeModule{
                                 usg_mod_name = mod_name,
@@ -617,6 +628,7 @@ checkModUsage this_pkg UsageHomeModule{
   = do
     let mod = mkModule this_pkg mod_name
     dflags <- getDynFlags
+    logger <- getLogger
     needInterface mod $ \iface -> do
      let
          new_mod_hash    = mi_mod_hash (mi_final_exts iface)
@@ -627,20 +639,20 @@ checkModUsage this_pkg UsageHomeModule{
 
      liftIO $ do
            -- CHECK MODULE
-       recompile <- checkModuleFingerprint dflags reason old_mod_hash new_mod_hash
+       recompile <- checkModuleFingerprint logger dflags reason old_mod_hash new_mod_hash
        if not (recompileRequired recompile)
          then return UpToDate
          else
            -- CHECK EXPORT LIST
-           checkMaybeHash dflags reason maybe_old_export_hash new_export_hash
+           checkMaybeHash logger dflags reason maybe_old_export_hash new_export_hash
                (text "  Export list changed") $ do
 
                  -- CHECK ITEMS ONE BY ONE
-                 recompile <- checkList [ checkEntityUsage dflags reason new_decl_hash u
+                 recompile <- checkList [ checkEntityUsage logger dflags reason new_decl_hash u
                                         | u <- old_decl_hash]
                  if recompileRequired recompile
                    then return recompile     -- This one failed, so just bail out now
-                   else up_to_date dflags (text "  Great!  The bits I use are up to date")
+                   else up_to_date logger dflags (text "  Great!  The bits I use are up to date")
 
 
 checkModUsage _this_pkg UsageFile{ usg_file_path = file,
@@ -661,52 +673,65 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file,
 #endif
 
 ------------------------
-checkModuleFingerprint :: DynFlags -> String -> Fingerprint -> Fingerprint
-                       -> IO RecompileRequired
-checkModuleFingerprint dflags reason old_mod_hash new_mod_hash
+checkModuleFingerprint
+  :: Logger
+  -> DynFlags
+  -> String
+  -> Fingerprint
+  -> Fingerprint
+  -> IO RecompileRequired
+checkModuleFingerprint logger dflags reason old_mod_hash new_mod_hash
   | new_mod_hash == old_mod_hash
-  = up_to_date dflags (text "Module fingerprint unchanged")
+  = up_to_date logger dflags (text "Module fingerprint unchanged")
 
   | otherwise
-  = out_of_date_hash dflags reason (text "  Module fingerprint has changed")
+  = out_of_date_hash logger dflags reason (text "  Module fingerprint has changed")
                      old_mod_hash new_mod_hash
 
 ------------------------
-checkMaybeHash :: DynFlags -> String -> Maybe Fingerprint -> Fingerprint -> SDoc
-               -> IO RecompileRequired -> IO RecompileRequired
-checkMaybeHash dflags reason maybe_old_hash new_hash doc continue
+checkMaybeHash
+  :: Logger
+  -> DynFlags
+  -> String
+  -> Maybe Fingerprint
+  -> Fingerprint
+  -> SDoc
+  -> IO RecompileRequired
+  -> IO RecompileRequired
+checkMaybeHash logger dflags reason maybe_old_hash new_hash doc continue
   | Just hash <- maybe_old_hash, hash /= new_hash
-  = out_of_date_hash dflags reason doc hash new_hash
+  = out_of_date_hash logger dflags reason doc hash new_hash
   | otherwise
   = continue
 
 ------------------------
-checkEntityUsage :: DynFlags
+checkEntityUsage :: Logger
+                 -> DynFlags
                  -> String
                  -> (OccName -> Maybe (OccName, Fingerprint))
                  -> (OccName, Fingerprint)
                  -> IO RecompileRequired
-checkEntityUsage dflags reason new_hash (name,old_hash) = do
+checkEntityUsage logger dflags reason new_hash (name,old_hash) = do
   case new_hash name of
     -- We used it before, but it ain't there now
-    Nothing       -> out_of_date dflags reason (sep [text "No longer exported:", ppr name])
+    Nothing       -> out_of_date logger dflags reason (sep [text "No longer exported:", ppr name])
     -- It's there, but is it up to date?
     Just (_, new_hash)
       | new_hash == old_hash
-      -> do trace_hi_diffs dflags (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
+      -> do trace_hi_diffs logger dflags (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
             return UpToDate
       | otherwise
-      -> out_of_date_hash dflags reason (text "  Out of date:" <+> ppr name) old_hash new_hash
+      -> out_of_date_hash logger dflags reason (text "  Out of date:" <+> ppr name) old_hash new_hash
 
-up_to_date :: DynFlags -> SDoc -> IO RecompileRequired
-up_to_date dflags msg = trace_hi_diffs dflags msg >> return UpToDate
+up_to_date :: Logger -> DynFlags -> SDoc -> IO RecompileRequired
+up_to_date logger dflags msg = trace_hi_diffs logger dflags msg >> return UpToDate
 
-out_of_date :: DynFlags -> String -> SDoc -> IO RecompileRequired
-out_of_date dflags reason msg = trace_hi_diffs dflags msg >> return (RecompBecause reason)
+out_of_date :: Logger -> DynFlags -> String -> SDoc -> IO RecompileRequired
+out_of_date logger dflags reason msg = trace_hi_diffs logger dflags msg >> return (RecompBecause reason)
 
-out_of_date_hash :: DynFlags -> String -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired
-out_of_date_hash dflags reason msg old_hash new_hash
-  = out_of_date dflags reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
+out_of_date_hash :: Logger -> DynFlags -> String -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired
+out_of_date_hash logger dflags reason msg old_hash new_hash
+  = out_of_date logger dflags reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
 
 ----------------------
 checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired