GHCi: Fix load/reload space leaks (#4029)

This patch addresses GHCi load/reload space leaks which could be
fixed without adversely affecting performance.

Test Plan: make test "TEST=T4029"

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: mpickering, thomie

Differential Revision: https://phabricator.haskell.org/D1950

GHC Trac Issues: #4029

3 files changed, 22 insertions, 13 deletions

diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 1729a5bfdc..62321195f2 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -367,7 +367,10 @@ load how_much = do
           liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1
 
           -- there should be no Nothings where linkables should be, now
-          ASSERT(all (isJust.hm_linkable) (eltsUFM (hsc_HPT hsc_env))) do
+          ASSERT(   isNoLink (ghcLink dflags)
+                 || all (isJust.hm_linkable)
+                        (filter ((== HsSrcFile).mi_hsc_src.hm_iface)
+                                (eltsUFM hpt4))) do
 
           -- Link everything together
           linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
@@ -404,15 +407,18 @@ discardProg hsc_env
 -- external packages.
 discardIC :: HscEnv -> HscEnv
 discardIC hsc_env
-  = hsc_env { hsc_IC = new_ic { ic_int_print = keep_external_name ic_int_print
-                              , ic_monad = keep_external_name ic_monad } }
+  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
+                                , ic_monad = new_ic_monad } }
   where
+  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic
+  !new_ic_int_print = keep_external_name ic_int_print
+  !new_ic_monad = keep_external_name ic_monad
   dflags = ic_dflags old_ic
   old_ic = hsc_IC hsc_env
-  new_ic = emptyInteractiveContext dflags
+  empty_ic = emptyInteractiveContext dflags
   keep_external_name ic_name
     | nameIsFromExternalPackage this_pkg old_name = old_name
-    | otherwise = ic_name new_ic
+    | otherwise = ic_name empty_ic
     where
     this_pkg = thisPackage dflags
     old_name = ic_name old_ic
@@ -439,7 +445,8 @@ intermediateCleanTempFiles dflags summaries hsc_env
 guessOutputFile :: GhcMonad m => m ()
 guessOutputFile = modifySession $ \env ->
     let dflags = hsc_dflags env
-        mod_graph = hsc_mod_graph env
+        -- Force mod_graph to avoid leaking env
+        !mod_graph = hsc_mod_graph env
         mainModuleSrcPath :: Maybe String
         mainModuleSrcPath = do
             let isMain = (== mainModIs dflags) . ms_mod
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index ac4c60e735..b609f8d02b 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -694,8 +694,8 @@ setContext imports
            Left (mod, err) ->
                liftIO $ throwGhcExceptionIO (formatError dflags mod err)
            Right all_env -> do {
-       ; let old_ic        = hsc_IC hsc_env
-             final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
+       ; let old_ic         = hsc_IC hsc_env
+             !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
        ; modifySession $ \_ ->
          hsc_env{ hsc_IC = old_ic { ic_imports    = imports
                                   , ic_rn_gbl_env = final_rdr_env }}}}
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 3c646a5a5d..decd7a1019 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -1,6 +1,6 @@
 -- (c) The University of Glasgow, 2006
 
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns #-}
 
 -- | Package manipulation
 module Packages (
@@ -82,6 +82,7 @@ import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
 #endif
 import qualified Data.Map as Map
+import qualified Data.Map.Strict as MapStrict
 import qualified FiniteMap as Map
 import qualified Data.Set as Set
 
@@ -267,10 +268,10 @@ data PackageState = PackageState {
   -- | This is a full map from 'ModuleName' to all modules which may possibly
   -- be providing it.  These providers may be hidden (but we'll still want
   -- to report them in error messages), or it may be an ambiguous import.
-  moduleToPkgConfAll    :: ModuleToPkgConfAll,
+  moduleToPkgConfAll    :: !ModuleToPkgConfAll,
 
   -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.
-  pluginModuleToPkgConfAll    :: ModuleToPkgConfAll
+  pluginModuleToPkgConfAll    :: !ModuleToPkgConfAll
   }
 
 emptyPackageState :: PackageState
@@ -1107,7 +1108,8 @@ mkPackageState dflags0 dbs preload0 = do
   dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing))
   let new_dep_preload = filter (`notElem` preload0) dep_preload
 
-  let pstate = PackageState{
+  -- Force pstate to avoid leaking the dflags0 passed to mkPackageState
+  let !pstate = PackageState{
     preloadPackages     = dep_preload,
     explicitPackages    = foldUFM (\pkg xs ->
                             if elemUFM (packageConfigId pkg) vis_map
@@ -1134,7 +1136,7 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
   emptyMap = Map.empty
   sing pk m _ = Map.singleton (mkModule pk m)
   addListTo = foldl' merge
-  merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m
+  merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
   setOrigins m os = fmap (const os) m
   extend_modmap modmap pkg = addListTo modmap theBindings
    where