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

9 files changed, 402 insertions, 19 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
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 4b39159c83..cc180f27ff 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1463,7 +1463,8 @@ checkModule m = do
 -- '-fdefer-type-errors' again if it has not been set before.
 deferredLoad :: Bool -> InputT GHCi SuccessFlag -> InputT GHCi ()
 deferredLoad defer load = do
-  originalFlags <- getDynFlags
+  -- Force originalFlags to avoid leaking the associated HscEnv
+  !originalFlags <- getDynFlags
   when defer $ Monad.void $
     GHC.setProgramDynFlags $ setGeneralFlag' Opt_DeferTypeErrors originalFlags
   Monad.void $ load
@@ -3483,7 +3484,8 @@ showException se =
 
 ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
 ghciHandle h m = gmask $ \restore -> do
-                 dflags <- getDynFlags
+                 -- Force dflags to avoid leaking the associated HscEnv
+                 !dflags <- getDynFlags
                  gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
 
 ghciTry :: GHCi a -> GHCi (Either SomeException a)
diff --git a/testsuite/tests/perf/space_leaks/T4029.script b/testsuite/tests/perf/space_leaks/T4029.script
new file mode 100644
index 0000000000..91135c9477
--- /dev/null
+++ b/testsuite/tests/perf/space_leaks/T4029.script
@@ -0,0 +1,335 @@
+-- Load a minimalist module 100 times
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+:load T4029a
+
+-- Load a minimalist module and reload it 99 times
+:load T4029a
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+:! touch T4029a.hs
+:reload
+
+-- Load a more complex module 10 times
+:load T4029b
+:load T4029b
+:load T4029b
+:load T4029b
+:load T4029b
+:load T4029b
+:load T4029b
+:load T4029b
+:load T4029b
+:load T4029b
+
+-- Load a more complex module and reload it 9 times
+:load T4029b
+:! touch T4029b.hs
+:reload
+:! touch T4029b.hs
+:reload
+:! touch T4029b.hs
+:reload
+:! touch T4029b.hs
+:reload
+:! touch T4029b.hs
+:reload
+:! touch T4029b.hs
+:reload
+:! touch T4029b.hs
+:reload
+:! touch T4029b.hs
+:reload
+:! touch T4029b.hs
+:reload
diff --git a/testsuite/tests/perf/space_leaks/T4029a.hs b/testsuite/tests/perf/space_leaks/T4029a.hs
new file mode 100644
index 0000000000..7c23a341f2
--- /dev/null
+++ b/testsuite/tests/perf/space_leaks/T4029a.hs
@@ -0,0 +1,3 @@
+module T4029a where
+
+data A = A
diff --git a/testsuite/tests/perf/space_leaks/T4029b.hs b/testsuite/tests/perf/space_leaks/T4029b.hs
new file mode 100644
index 0000000000..c473685687
--- /dev/null
+++ b/testsuite/tests/perf/space_leaks/T4029b.hs
@@ -0,0 +1,23 @@
+module T4029b where
+
+
+data A01 = A01 deriving (Eq,Ord,Show,Read)
+data A02 = A02 deriving (Eq,Ord,Show,Read)
+data A03 = A03 deriving (Eq,Ord,Show,Read)
+data A04 = A04 deriving (Eq,Ord,Show,Read)
+data A05 = A05 deriving (Eq,Ord,Show,Read)
+data A06 = A06 deriving (Eq,Ord,Show,Read)
+data A07 = A07 deriving (Eq,Ord,Show,Read)
+data A08 = A08 deriving (Eq,Ord,Show,Read)
+data A09 = A09 deriving (Eq,Ord,Show,Read)
+data A10 = A10 deriving (Eq,Ord,Show,Read)
+data A11 = A11 deriving (Eq,Ord,Show,Read)
+data A12 = A12 deriving (Eq,Ord,Show,Read)
+data A13 = A13 deriving (Eq,Ord,Show,Read)
+data A14 = A14 deriving (Eq,Ord,Show,Read)
+data A15 = A15 deriving (Eq,Ord,Show,Read)
+data A16 = A16 deriving (Eq,Ord,Show,Read)
+data A17 = A17 deriving (Eq,Ord,Show,Read)
+data A18 = A18 deriving (Eq,Ord,Show,Read)
+data A19 = A19 deriving (Eq,Ord,Show,Read)
+data A20 = A20 deriving (Eq,Ord,Show,Read)
diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T
index 722c316e70..2504bdac19 100644
--- a/testsuite/tests/perf/space_leaks/all.T
+++ b/testsuite/tests/perf/space_leaks/all.T
@@ -53,3 +53,14 @@ test('T2762',
 test('T4018',
      [ only_ways(['optasm']), extra_run_opts('+RTS -M10m -RTS') ],
      compile_and_run, ['-fno-state-hack'])
+
+test('T4029',
+     [stats_num_field('peak_megabytes_allocated',
+          [(wordsize(64), 66, 10)]),
+            # 2016-02-26: 66 (amd64/Linux)           INITIAL
+      stats_num_field('max_bytes_used',
+          [(wordsize(64), 24071720, 5)])
+            # 2016-02-26: 24071720 (amd64/Linux)     INITIAL
+      ],
+     ghci_script,
+     ['T4029.script'])
diff --git a/testsuite/tests/rename/should_fail/T11071.stderr b/testsuite/tests/rename/should_fail/T11071.stderr
index e3d5e30377..2feeadd040 100644
--- a/testsuite/tests/rename/should_fail/T11071.stderr
+++ b/testsuite/tests/rename/should_fail/T11071.stderr
@@ -9,11 +9,11 @@ T11071.hs:20:12: error:
 
 T11071.hs:21:12: error:
     Not in scope: ‘M.foobar’
-    Neither ‘Data.Map’ nor ‘Data.IntMap’ exports ‘foobar’.
+    Neither ‘Data.IntMap’ nor ‘Data.Map’ exports ‘foobar’.
 
 T11071.hs:22:12: error:
     Not in scope: ‘M'.foobar’
-    Neither ‘Data.Map’, ‘Data.IntMap’ nor ‘System.IO’ exports ‘foobar’.
+    Neither ‘Data.IntMap’, ‘Data.Map’ nor ‘System.IO’ exports ‘foobar’.
 
 T11071.hs:23:12: error:
     Not in scope: ‘Data.List.sort’
@@ -29,8 +29,8 @@ T11071.hs:24:12: error:
 T11071.hs:25:12: error:
     Not in scope: ‘M.size’
     Perhaps you want to add ‘size’ to one of these import lists:
-      ‘Data.Map’ (T11071.hs:4:1-33)
       ‘Data.IntMap’ (T11071.hs:5:1-36)
+      ‘Data.Map’ (T11071.hs:4:1-33)
 
 T11071.hs:26:12: error:
     Not in scope: ‘M.valid’
@@ -49,5 +49,5 @@ T11071.hs:28:12: error:
     Not in scope: ‘M'.size’
     Perhaps you want to remove ‘size’ from the hiding clauses
     in one of these imports:
-      ‘Data.Map’ (T11071.hs:10:1-53)
       ‘Data.IntMap’ (T11071.hs:12:1-48)
+      ‘Data.Map’ (T11071.hs:10:1-53)