ghci: Explicitly store and restore interface file cachewip/t20217

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

13 files changed, 83 insertions, 57 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 0488ccad11..ad584905a4 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -53,7 +53,7 @@ module GHC (
 
         -- * Loading\/compiling the program
         depanal, depanalE,
-        load, LoadHowMuch(..), InteractiveImport(..),
+        load, loadWithCache, LoadHowMuch(..), InteractiveImport(..),
         SuccessFlag(..), succeeded, failed,
         defaultWarnErrLogger, WarnErrLogger,
         workingDirectoryChanged,
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
diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs
index 6102df9e04..e99ff405aa 100644
--- a/ghc/GHCi/Leak.hs
+++ b/ghc/GHCi/Leak.hs
@@ -59,7 +59,9 @@ checkLeakIndicators dflags (LeakIndicators leakmods)  = do
       Just hmi ->
         report ("HomeModInfo for " ++
           showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)
-    deRefWeak leakIface >>= report "ModIface"
+    deRefWeak leakIface >>= \case
+      Nothing -> return ()
+      Just miface -> report ("ModIface:" ++ moduleNameString (moduleName (mi_module miface))) (Just miface)
     deRefWeak leakDetails >>= report "ModDetails"
     forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"
  where
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 369002b8bc..4a82a51e84 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -550,7 +550,8 @@ interactiveUI config srcs maybe_exprs = do
                    lastErrorLocations = lastErrLocationsRef,
                    mod_infos          = M.empty,
                    flushStdHandles    = flush,
-                   noBuffering        = nobuffering
+                   noBuffering        = nobuffering,
+                   hmiCache = []
                  }
 
    return ()
@@ -1656,6 +1657,12 @@ trySuccess act =
                                 return Failed) $ do
       act
 
+trySuccessWithRes :: (Monoid a, GHC.GhcMonad m) => m (SuccessFlag, a) -> m (SuccessFlag, a)
+trySuccessWithRes act =
+    handleSourceError (\e -> do GHC.printException e
+                                return (Failed, mempty))
+      act
+
 -----------------------------------------------------------------------------
 -- :edit
 
@@ -2114,7 +2121,10 @@ doLoad retain_context howmuch = do
              (\_ ->
               liftIO $ do hSetBuffering stdout NoBuffering
                           hSetBuffering stderr NoBuffering) $ \_ -> do
-      ok <- trySuccess $ GHC.load howmuch
+      hmis <- hmiCache <$> getGHCiState
+      modifyGHCiState (\ghci -> ghci { hmiCache = [] })
+      (ok, new_cache) <- trySuccessWithRes $ GHC.loadWithCache hmis howmuch
+      modifyGHCiState (\ghci -> ghci { hmiCache = new_cache })
       afterLoad ok retain_context
       return ok
 
@@ -4397,6 +4407,11 @@ discardActiveBreakPoints = do
    mapM_ (turnBreakOnOff False) $ breaks st
    setGHCiState $ st { breaks = IntMap.empty }
 
+-- don't reset the counter back to zero?
+discardInterfaceCache :: GhciMonad m => m ()
+discardInterfaceCache = do
+   modifyGHCiState $ (\st -> st { hmiCache = [] })
+
 deleteBreak :: GhciMonad m => Int -> m ()
 deleteBreak identity = do
    st <- getGHCiState
@@ -4579,6 +4594,7 @@ wantNameFromInterpretedModule noCanDo str and_then =
 
 clearAllTargets :: GhciMonad m => m ()
 clearAllTargets = discardActiveBreakPoints
+                >> discardInterfaceCache
                 >> GHC.setTargets []
                 >> GHC.load LoadAllTargets
                 >> pure ()
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index a24c40e804..72a44530e6 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -56,6 +56,7 @@ import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
 import GHC.Hs.Utils
 import GHC.Utils.Misc
 import GHC.Utils.Logger
+import GHC.Unit.Home.ModInfo
 
 import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch)
 import Numeric
@@ -159,8 +160,9 @@ data GHCiState = GHCiState
 
         flushStdHandles :: ForeignHValue,
             -- ^ @hFlush stdout; hFlush stderr@ in the interpreter
-        noBuffering :: ForeignHValue
+        noBuffering :: ForeignHValue,
             -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr
+        hmiCache :: [HomeModInfo]
      }
 
 type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
@@ -288,7 +290,7 @@ class GhcMonad m => GhciMonad m where
 instance GhciMonad GHCi where
   getGHCiState      = GHCi $ \r -> liftIO $ readIORef r
   setGHCiState s    = GHCi $ \r -> liftIO $ writeIORef r s
-  modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
+  modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef' r f
   reifyGHCi f       = GHCi $ \r -> reifyGhc $ \s -> f (s, r)
 
 instance GhciMonad (InputT GHCi) where
@@ -327,7 +329,7 @@ instance GhcMonad (InputT GHCi) where
 isOptionSet :: GhciMonad m => GHCiOption -> m Bool
 isOptionSet opt
  = do st <- getGHCiState
-      return (opt `elem` options st)
+      return $! (opt `elem` options st)
 
 setOption :: GhciMonad m => GHCiOption -> m ()
 setOption opt
diff --git a/testsuite/tests/ghci/scripts/T20217.hs b/testsuite/tests/ghci/scripts/T20217.hs
new file mode 100644
index 0000000000..4529633222
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217.hs
@@ -0,0 +1,3 @@
+module T20217 where
+
+import {-# SOURCE #-} T20217A
diff --git a/testsuite/tests/ghci/scripts/T20217.script b/testsuite/tests/ghci/scripts/T20217.script
new file mode 100644
index 0000000000..27bffe4e61
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217.script
@@ -0,0 +1,4 @@
+:set -fno-code
+:set -v1
+:l T20217
+:r
diff --git a/testsuite/tests/ghci/scripts/T20217.stdout b/testsuite/tests/ghci/scripts/T20217.stdout
new file mode 100644
index 0000000000..fa229321bf
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217.stdout
@@ -0,0 +1,5 @@
+[1 of 3] Compiling T20217A[boot]    ( T20217A.hs-boot, nothing )
+[2 of 3] Compiling T20217           ( T20217.hs, nothing )
+[3 of 3] Compiling T20217A          ( T20217A.hs, nothing )
+Ok, three modules loaded.
+Ok, three modules loaded.
diff --git a/testsuite/tests/ghci/scripts/T20217A.hs b/testsuite/tests/ghci/scripts/T20217A.hs
new file mode 100644
index 0000000000..326b0d7607
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217A.hs
@@ -0,0 +1 @@
+module T20217A where x = x
diff --git a/testsuite/tests/ghci/scripts/T20217A.hs-boot b/testsuite/tests/ghci/scripts/T20217A.hs-boot
new file mode 100644
index 0000000000..c4c1f8a75b
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217A.hs-boot
@@ -0,0 +1 @@
+module T20217A where
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index d8c80e9543..c47b3b0569 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -346,3 +346,4 @@ test('T19650',
 test('T20019', normal, ghci_script, ['T20019.script'])
 test('T20101', normal, ghci_script, ['T20101.script'])
 test('T20206', normal, ghci_script, ['T20206.script'])
+test('T20217', normal, ghci_script, ['T20217.script'])