ghci: Explicitly store and restore interface file cache

In the old days the old HPT was used as an interface file cache when
using ghci. The HPT is a `ModuleEnv HomeModInfo` and so if you were
using hs-boot files then the interface file from compiling the .hs file
would be present in the cache but not the hi-boot file. This used to be
ok, because the .hi file used to just be a better version of the
.hi-boot file, with more information so it was fine to reuse it. Now the
source hash of a module is kept track of in the interface file and the
source hash for the .hs and .hs-boot file are correspondingly different
so it's no longer safe to reuse an interface file.

I took the decision to move the cache management of interface files to
GHCi itself, and provide an API where `load` can be provided with a list
of interface files which can be used as a cache. An alternative would be
to manage this cache somewhere in the HscEnv but it seemed that an API
user should be responsible for populating and suppling the cache rather
than having it managed implicitly.

Fixes #20217

3 files changed, 41 insertions, 50 deletions

diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 5d0a6a828c..b966a08884 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -323,7 +323,7 @@ buildUnit session cid insts lunit = do
         mod_graph <- hsunitModuleGraph (unLoc lunit)
 
         msg <- mkBackpackMsg
-        ok <- load' LoadAllTargets (Just msg) mod_graph
+        (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
         when (failed ok) (liftIO $ exitWith (ExitFailure 1))
 
         let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
@@ -412,7 +412,7 @@ compileExe lunit = do
     withBkpExeSession deps_w_rns $ do
         mod_graph <- hsunitModuleGraph (unLoc lunit)
         msg <- mkBackpackMsg
-        ok <- load' LoadAllTargets (Just msg) mod_graph
+        (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
         when (failed ok) (liftIO $ exitWith (ExitFailure 1))
 
 -- | Register a new virtual unit database containing a single unit
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 8918ca1d34..fa1348bfe1 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -27,7 +27,7 @@
 -- -----------------------------------------------------------------------------
 module GHC.Driver.Make (
         depanal, depanalE, depanalPartial,
-        load, load', LoadHowMuch(..),
+        load, loadWithCache, load', LoadHowMuch(..),
         instantiationNodes,
 
         downsweep,
@@ -87,7 +87,7 @@ import GHC.Data.Maybe      ( expectJust )
 import GHC.Data.StringBuffer
 import qualified GHC.LanguageExtensions as LangExt
 
-import GHC.Utils.Exception ( evaluate, throwIO, SomeAsyncException )
+import GHC.Utils.Exception ( throwIO, SomeAsyncException )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
@@ -346,11 +346,14 @@ data LoadHowMuch
 -- returns together with the errors an empty ModuleGraph.
 -- After processing this empty ModuleGraph, the errors of depanalE are thrown.
 -- All other errors are reported using the 'defaultWarnErrLogger'.
---
-load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
-load how_much = do
+
+load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
+load how_much = fst <$> loadWithCache [] how_much
+
+loadWithCache :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> m (SuccessFlag, [HomeModInfo])
+loadWithCache cache how_much = do
     (errs, mod_graph) <- depanalE [] False                        -- #17459
-    success <- load' how_much (Just batchMsg) mod_graph
+    success <- load' cache how_much (Just batchMsg) mod_graph
     if isEmptyMessages errs
       then pure success
       else throwErrors (fmap GhcDriverMessage errs)
@@ -483,13 +486,12 @@ createBuildPlan mod_graph maybe_top_mod =
 -- | Generalized version of 'load' which also supports a custom
 -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
 -- produced by calling 'depanal'.
-load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
-load' how_much mHscMessage mod_graph = do
+load' :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m (SuccessFlag, [HomeModInfo])
+load' cache how_much mHscMessage mod_graph = do
     modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
     guessOutputFile
     hsc_env <- getSession
 
-    let hpt1   = hsc_HPT hsc_env
     let dflags = hsc_dflags hsc_env
     let logger = hsc_logger hsc_env
     let interp = hscInterp hsc_env
@@ -519,7 +521,7 @@ load' how_much mHscMessage mod_graph = do
             | otherwise = do
                     liftIO $ errorMsg logger
                         (text "no such module:" <+> quotes (ppr m))
-                    return Failed
+                    return (Failed, [])
 
     checkHowMuch how_much $ do
 
@@ -545,15 +547,14 @@ load' how_much mHscMessage mod_graph = do
     let
         -- prune the HPT so everything is not retained when doing an
         -- upsweep.
-        pruned_hpt = pruneHomePackageTable hpt1
+        !pruned_cache = pruneCache cache
                             (flattenSCCs (filterToposortToModules  mg2_with_srcimps))
 
-    _ <- liftIO $ evaluate pruned_hpt
 
     -- before we unload anything, make sure we don't leave an old
     -- interactive context around pointing to dead bindings.  Also,
-    -- write the pruned HPT to allow the old HPT to be GC'd.
-    setSession $ discardIC $ hscUpdateHPT (const pruned_hpt) hsc_env
+    -- write an empty HPT to allow the old HPT to be GC'd.
+    setSession $ discardIC $ hscUpdateHPT (const emptyHomePackageTable) hsc_env
 
     -- Unload everything
     liftIO $ unload interp hsc_env
@@ -569,11 +570,12 @@ load' how_much mHscMessage mod_graph = do
 
     setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env
     hsc_env <- getSession
-    (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $
-      liftIO $ upsweep n_jobs hsc_env mHscMessage pruned_hpt direct_deps build_plan
+    (upsweep_ok, hsc_env1, new_cache) <- withDeferredDiagnostics $
+      liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) direct_deps build_plan
     setSession hsc_env1
-    case upsweep_ok of
+    fmap (, new_cache) $ case upsweep_ok of
       Failed -> loadFinish upsweep_ok Succeeded
+
       Succeeded -> do
        -- Make modsDone be the summaries for each home module now
        -- available; this should equal the domain of hpt3.
@@ -730,11 +732,11 @@ guessOutputFile = modifySession $ \env ->
 -- space at the end of the upsweep, because the topmost ModDetails of the
 -- old HPT holds on to the entire type environment from the previous
 -- compilation.
-pruneHomePackageTable :: HomePackageTable
+pruneCache :: [HomeModInfo]
                       -> [ModSummary]
-                      -> HomePackageTable
-pruneHomePackageTable hpt summ
-  = mapHpt prune hpt
+                      -> [HomeModInfo]
+pruneCache hpt summ
+  = strictMap prune hpt
   where prune hmi = hmi'{ hm_details = emptyModDetails }
           where
            modl = moduleName (mi_module (hm_iface hmi))
@@ -922,7 +924,7 @@ withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
 
 -- | Environment used when compiling a module
 data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module
-                       , old_hpt :: !HomePackageTable -- A cache of old interface files
+                       , old_hpt :: !(M.Map ModuleNameWithIsBoot HomeModInfo) -- A cache of old interface files
                        , compile_sem :: !AbstractSem
                        , lqq_var :: !(TVar LogQueueQueue)
                        , env_messager :: !(Maybe Messager)
@@ -1030,10 +1032,10 @@ upsweep
     :: Int -- ^ The number of workers we wish to run in parallel
     -> HscEnv -- ^ The base HscEnv, which is augmented for each module
     -> Maybe Messager
-    -> HomePackageTable
+    -> M.Map ModuleNameWithIsBoot HomeModInfo
     -> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey
     -> [BuildPlan]
-    -> IO (SuccessFlag, HscEnv)
+    -> IO (SuccessFlag, HscEnv, [HomeModInfo])
 upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do
     (cycle, pipelines, collect_result) <- interpretBuildPlan direct_deps build_plan
     runPipelines n_jobs hsc_env old_hpt mHscMessage pipelines
@@ -1048,10 +1050,13 @@ upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do
         Just mss -> do
           let logger = hsc_logger hsc_env
           liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)
-          return (Failed, hsc_env)
+          return (Failed, hsc_env, completed)
         Nothing  -> do
           let success_flag = successIf (all isJust res)
-          return (success_flag, hsc_env')
+          return (success_flag, hsc_env', completed)
+
+toCache :: [HomeModInfo] -> M.Map ModuleNameWithIsBoot HomeModInfo
+toCache hmis = M.fromList ([(mi_mnwib $ hm_iface hmi, hmi) | hmi <- hmis])
 
 upsweep_inst :: HscEnv
              -> Maybe Messager
@@ -1070,34 +1075,16 @@ upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do
 -- successful.  If no compilation happened, return the old Linkable.
 upsweep_mod :: HscEnv
             -> Maybe Messager
-            -> HomePackageTable
+            -> M.Map ModuleNameWithIsBoot HomeModInfo
             -> ModSummary
             -> Int  -- index of module
             -> Int  -- total number of modules
             -> IO HomeModInfo
 upsweep_mod hsc_env mHscMessage old_hpt summary mod_index nmods =  do
-  let old_hmi = lookupHpt old_hpt (ms_mod_name summary)
-
-    -- The old interface is ok if
-    --  a) we're compiling a source file, and the old HPT
-    --     entry is for a source file
-    --  b) we're compiling a hs-boot file
-    -- Case (b) allows an hs-boot file to get the interface of its
-    -- real source file on the second iteration of the compilation
-    -- manager, but that does no harm.  Otherwise the hs-boot file
-    -- will always be recompiled
-
-      mb_old_iface
-        = case old_hmi of
-             Nothing                                        -> Nothing
-             Just hm_info | isBootSummary summary == IsBoot -> Just iface
-                          | mi_boot iface == NotBoot        -> Just iface
-                          | otherwise                       -> Nothing
-                           where
-                             iface = hm_iface hm_info
+  let old_hmi = M.lookup (ms_mnwib summary) old_hpt
 
   hmi <- compileOne' mHscMessage hsc_env summary
-          mod_index nmods mb_old_iface (old_hmi >>= hm_linkable)
+          mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable)
 
   -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module
   -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I
@@ -2368,7 +2355,7 @@ label_self thread_name = do
 -- | Build and run a pipeline
 runPipelines :: Int              -- ^ How many capabilities to use
              -> HscEnv           -- ^ The basic HscEnv which is augmented with specific info for each module
-             -> HomePackageTable -- ^ The old HPT which is used as a cache (TODO: The cache should be from the ActionMap)
+             -> M.Map ModuleNameWithIsBoot HomeModInfo -- ^ The old HPT which is used as a cache (TODO: The cache should be from the ActionMap)
              -> Maybe Messager   -- ^ Optional custom messager to use to report progress
              -> [MakeAction]  -- ^ The build plan for all the module nodes
              -> IO ()
diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs
index 695e1ff6c2..a339df92cc 100644
--- a/compiler/GHC/Unit/Module/ModIface.hs
+++ b/compiler/GHC/Unit/Module/ModIface.hs
@@ -18,6 +18,7 @@ module GHC.Unit.Module.ModIface
    , mi_fix
    , mi_semantic_module
    , mi_free_holes
+   , mi_mnwib
    , renameFreeHoles
    , emptyPartialModIface
    , emptyFullModIface
@@ -262,6 +263,9 @@ mi_boot iface = if mi_hsc_src iface == HsBootFile
     then IsBoot
     else NotBoot
 
+mi_mnwib :: ModIface -> ModuleNameWithIsBoot
+mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface)
+
 -- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be
 -- found, 'defaultFixity' is returned instead.
 mi_fix :: ModIface -> OccName -> Fixity