Commit 6ca9b15f authored by Jason Eisenberg's avatar Jason Eisenberg Committed by Ben Gamari

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
parent 120b9cdb
......@@ -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
......
......@@ -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 }}}}
......
-- (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
......
......@@ -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)
......
-- 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
module T4029a where
data A = A
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)
......@@ -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'])
......@@ -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)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment