More strictness around HomePackageTable

This patch makes some operations to do with HomePackageTable stricter

* Adding a new entry into the HPT would not allow the old HomeModInfo to be
  collected because the function used by insertWith wouldn't be forced.
* We're careful to force the new MVar value before it's inserted into
  the global MVar as otherwise we retain references to old entries.

3 files changed, 20 insertions, 10 deletions

diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 1482bdb539..7f740f0123 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -738,11 +738,11 @@ pruneHomePackageTable hpt summ
   where prune hmi = hmi'{ hm_details = emptyModDetails }
           where
            modl = moduleName (mi_module (hm_iface hmi))
-           hmi' | mi_src_hash (hm_iface hmi) /= ms_hs_hash ms
+           hmi' | Just ms <- lookupUFM ms_map modl
+                , mi_src_hash (hm_iface hmi) /= ms_hs_hash ms
                 = hmi{ hm_linkable = Nothing }
                 | otherwise
                 = hmi
-                where ms = expectJust "prune" (lookupUFM ms_map modl)
 
         ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
 
@@ -990,7 +990,7 @@ interpretBuildPlan deps_map plan = do
                   hmi <- executeCompileNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) knot_var (emsModSummary ms)
                   -- This global MVar is incrementally modified in order to avoid having to
                   -- recreate the HPT before compiling each module which leads to a quadratic amount of work.
-                  liftIO $ modifyMVar_ hpt_var (return . addHomeModInfoToHpt hmi)
+                  liftIO $ modifyMVar_ hpt_var (\hpt -> return $! addHomeModInfoToHpt hmi hpt)
                   return (Just hmi)
 
       res_var <- liftIO newEmptyMVar
@@ -1009,8 +1009,8 @@ interpretBuildPlan deps_map plan = do
       hpt_var <- gets hpt_var
       res_var <- liftIO newEmptyMVar
       let loop_action = do
-            hmis <- executeTypecheckLoop (readMVar hpt_var) (wait_deps wait_modules)
-            liftIO $ modifyMVar_ hpt_var (\hpt -> return $ foldl' (flip addHomeModInfoToHpt) hpt hmis)
+            !hmis <- executeTypecheckLoop (readMVar hpt_var) (wait_deps wait_modules)
+            liftIO $ modifyMVar_ hpt_var (\hpt -> return $! foldl' (flip addHomeModInfoToHpt) hpt hmis)
             return hmis
 
 
diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs
index f143af2b58..4b0f5e545d 100644
--- a/compiler/GHC/Types/Unique/DFM.hs
+++ b/compiler/GHC/Types/Unique/DFM.hs
@@ -72,6 +72,7 @@ import GHC.Prelude
 import GHC.Types.Unique ( Uniquable(..), Unique, getKey )
 import GHC.Utils.Outputable
 
+import qualified Data.IntMap.Strict as MS
 import qualified Data.IntMap as M
 import Data.Data
 import Data.Functor.Classes (Eq1 (..))
@@ -121,7 +122,7 @@ import Unsafe.Coerce
 -- | A type of values tagged with insertion time
 data TaggedVal val =
   TaggedVal
-    val
+    !val
     {-# UNPACK #-} !Int -- ^ insertion time
   deriving stock (Data, Functor, Foldable, Traversable)
 
@@ -174,20 +175,24 @@ addToUDFM m k v = addToUDFM_Directly m (getUnique k) v
 -- The new binding always goes to the right of existing ones
 addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt
 addToUDFM_Directly (UDFM m i) u v
-  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
+  = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
   where
     tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i
       -- Keep the old tag, but insert the new value
       -- This means that udfmToList typically returns elements
       -- in the order of insertion, rather than the reverse
 
+      -- It is quite critical that the strict insertWith is used as otherwise
+      -- the combination function 'tf' is not forced and both old values are retained
+      -- in the map.
+
 addToUDFM_C_Directly
   :: (elt -> elt -> elt)   -- old -> new -> result
   -> UniqDFM key elt
   -> Unique -> elt
   -> UniqDFM key elt
 addToUDFM_C_Directly f (UDFM m i) u v
-  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
+  = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
     where
       tf (TaggedVal new_v _) (TaggedVal old_v old_i)
          = TaggedVal (f old_v new_v) old_i
@@ -399,7 +404,10 @@ alterUDFM f (UDFM m i) k =
 
 -- | Map a function over every value in a UniqDFM
 mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
-mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i
+mapUDFM f (UDFM m i) = UDFM (MS.map (fmap f) m) i
+-- Critical this is strict map, otherwise you get a big space leak when reloading
+-- in GHCi because all old ModDetails are retained (see pruneHomePackageTable).
+-- Modify with care.
 
 mapMaybeUDFM :: forall elt1 elt2 key.
                 (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs
index d41bc0c9f6..b5960a5223 100644
--- a/compiler/GHC/Unit/Home/ModInfo.hs
+++ b/compiler/GHC/Unit/Home/ModInfo.hs
@@ -41,10 +41,12 @@ data HomeModInfo = HomeModInfo
         -- ^ The basic loaded interface file: every loaded module has one of
         -- these, even if it is imported from another package
 
-   , hm_details  :: !ModDetails
+   , hm_details  :: ModDetails
         -- ^ Extra information that has been created from the 'ModIface' for
         -- the module, typically during typechecking
 
+        -- This field is LAZY because a ModDetails is constructed by knot tying.
+
    , hm_linkable :: !(Maybe Linkable)
         -- ^ The actual artifact we would like to link to access things in
         -- this module.