Commit 71f6b18b authored by Simon Marlow's avatar Simon Marlow
Browse files

Fix space leaks

Summary:
All these were detected by -fghci-leak-check when GHC was
compiled *without* optimisation (e.g. using the "quick" build flavour).

Unfortunately I don't know of a good way to keep this working.  I'd like
to just disable the -fghci-leak-check flag when the compiler is built
without optimisation, but it doesn't look like we have an easy way to do
that. And even if we could, it would be fragile anyway,

Test Plan: `cd testsuite/tests/ghci; make`

Reviewers: bgamari, hvr, erikd, tdammers

Subscribers: tdammers, rwbarton, thomie, carter

GHC Trac Issues: #15246

Differential Revision: https://phabricator.haskell.org/D4872
parent 8b6a9e55
{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
......@@ -169,10 +170,10 @@ extendLoadedPkgs pkgs =
extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
extendLinkEnv new_bindings =
modifyPLS_ $ \pls -> do
let ce = closure_env pls
let new_ce = extendClosureEnv ce new_bindings
return pls{ closure_env = new_ce }
modifyPLS_ $ \pls@PersistentLinkerState{..} -> do
let new_ce = extendClosureEnv closure_env new_bindings
return $! pls{ closure_env = new_ce }
-- strictness is important for not retaining old copies of the pls
deleteFromLinkEnv :: [Name] -> IO ()
deleteFromLinkEnv to_remove =
......@@ -1095,15 +1096,19 @@ unload_wkr :: HscEnv
-- Does the core unload business
-- (the wrapper blocks exceptions and deals with the PLS get and put)
unload_wkr hsc_env keep_linkables pls = do
unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..} = do
-- NB. careful strictness here to avoid keeping the old PLS when
-- we're unloading some code. -fghci-leak-check with the tests in
-- testsuite/ghci can detect space leaks here.
let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
discard keep l = not (linkableInSet l keep)
(objs_to_unload, remaining_objs_loaded) =
partition (discard objs_to_keep) (objs_loaded pls)
partition (discard objs_to_keep) objs_loaded
(bcos_to_unload, remaining_bcos_loaded) =
partition (discard bcos_to_keep) (bcos_loaded pls)
partition (discard bcos_to_keep) bcos_loaded
mapM_ unloadObjs objs_to_unload
mapM_ unloadObjs bcos_to_unload
......@@ -1114,7 +1119,7 @@ unload_wkr hsc_env keep_linkables pls = do
filter (not . null . linkableObjs) bcos_to_unload))) $
purgeLookupSymbolCache hsc_env
let bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
-- Note that we want to remove all *local*
-- (i.e. non-isExternal) names too (these are the
......@@ -1122,13 +1127,13 @@ unload_wkr hsc_env keep_linkables pls = do
keep_name (n,_) = isExternalName n &&
nameModule n `elemModuleSet` bcos_retained
itbl_env' = filterNameEnv keep_name (itbl_env pls)
closure_env' = filterNameEnv keep_name (closure_env pls)
itbl_env' = filterNameEnv keep_name itbl_env
closure_env' = filterNameEnv keep_name closure_env
new_pls = pls { itbl_env = itbl_env',
closure_env = closure_env',
bcos_loaded = remaining_bcos_loaded,
objs_loaded = remaining_objs_loaded }
!new_pls = pls { itbl_env = itbl_env',
closure_env = closure_env',
bcos_loaded = remaining_bcos_loaded,
objs_loaded = remaining_objs_loaded }
return new_pls
where
......
-- (c) The University of Glasgow 2002-2006
{-# LANGUAGE CPP, RankNTypes #-}
{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}
module IfaceEnv (
newGlobalBinder, newInteractiveBinder,
......@@ -129,7 +129,8 @@ newtype NameCacheUpdater
mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do { hsc_env <- getTopEnv
; return (NCU (updNameCache hsc_env)) }
; let !ncRef = hsc_NC hsc_env
; return (NCU (updNameCache ncRef)) }
updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
-> TcRnIf a b c
......@@ -151,7 +152,7 @@ updNameCacheIO hsc_env mod occ upd_fn = do {
-- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
mod `seq` occ `seq` return ()
; updNameCache hsc_env upd_fn }
; updNameCache (hsc_NC hsc_env) upd_fn }
{-
......
{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation #-}
{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns #-}
{-# OPTIONS_GHC -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
......@@ -263,7 +263,7 @@ compileOne' m_tc_result mHscMessage
-- imports a _stub.h file that we created here.
current_dir = takeDirectory basename
old_paths = includePaths dflags1
prevailing_dflags = hsc_dflags hsc_env0
!prevailing_dflags = hsc_dflags hsc_env0
dflags =
dflags1 { includePaths = addQuoteInclude old_paths [current_dir]
, log_action = log_action prevailing_dflags }
......
......@@ -2620,11 +2620,11 @@ interface file); so we give it 'noSrcLoc' then. Later, when we find
its binding site, we fix it up.
-}
updNameCache :: HscEnv
updNameCache :: IORef NameCache
-> (NameCache -> (NameCache, c)) -- The updating function
-> IO c
updNameCache hsc_env upd_fn
= atomicModifyIORef' (hsc_NC hsc_env) upd_fn
updNameCache ncRef upd_fn
= atomicModifyIORef' ncRef upd_fn
mkSOName :: Platform -> FilePath -> FilePath
mkSOName platform root
......
......@@ -5,7 +5,8 @@
Functions for working with the typechecker environment (setters, getters...).
-}
{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}
{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TcRnMonad(
......@@ -432,7 +433,7 @@ updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = upd top })
getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv = do { env <- getEnv; return (env_gbl env) }
getGblEnv = do { Env{..} <- getEnv; return env_gbl }
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
......@@ -442,7 +443,7 @@ setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv = do { env <- getEnv; return (env_lcl env) }
getLclEnv = do { Env{..} <- getEnv; return env_lcl }
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
......@@ -1762,7 +1763,7 @@ initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
; dflags <- getDynFlags
; let mod = tcg_semantic_mod tcg_env
; let !mod = tcg_semantic_mod tcg_env
-- When we are instantiating a signature, we DEFINITELY
-- do not want to knot tie.
is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
......
......@@ -106,7 +106,7 @@ instance ExceptionMonad (IOEnv a) where
instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
getDynFlags = do env <- getEnv
return $ extractDynFlags env
return $! extractDynFlags env
instance ContainsModule env => HasModule (IOEnv env) where
getModule = do env <- getEnv
......
......@@ -1688,7 +1688,8 @@ loadModule' files = do
-- Grab references to the currently loaded modules so that we can
-- see if they leak.
leak_indicators <- if gopt Opt_GhciLeakCheck (hsc_dflags hsc_env)
let !dflags = hsc_dflags hsc_env
leak_indicators <- if gopt Opt_GhciLeakCheck dflags
then liftIO $ getLeakIndicators hsc_env
else return (panic "no leak indicators")
......@@ -1700,8 +1701,8 @@ loadModule' files = do
GHC.setTargets targets
success <- doLoadAndCollectInfo False LoadAllTargets
when (gopt Opt_GhciLeakCheck (hsc_dflags hsc_env)) $
liftIO $ checkLeakIndicators (hsc_dflags hsc_env) leak_indicators
when (gopt Opt_GhciLeakCheck dflags) $
liftIO $ checkLeakIndicators dflags leak_indicators
return success
-- | @:add@ command
......
......@@ -39,7 +39,7 @@ test('T1969',
# 2013-11-13 17 (x86/Windows, 64bit machine)
# 2015-07-11 21 (x86/Linux, 64bit machine) use +RTS -G1
# 2016-04-06 30 (x86/Linux, 64bit machine)
(wordsize(64), 78, 20)]),
(wordsize(64), 73, 20)]),
# 28 (amd64/Linux)
# 34 (amd64/Linux)
# 2012-09-20 23 (amd64/Linux)
......@@ -56,6 +56,7 @@ test('T1969',
# 2017-02-17 83 (amd64/Linux) Type-indexed Typeable
# 2017-03-31 61 (amd64/Linux) Fix memory leak in simplifier
# 2018-01-25 78 (amd64/Linux) Use CoreExpr for EvTerm
# 2018-07-10 73 (amd64/Linux) Fix space leaks
compiler_stats_num_field('max_bytes_used',
[(platform('i386-unknown-mingw32'), 5719436, 20),
# 2010-05-17 5717704 (x86/Windows)
......@@ -73,7 +74,7 @@ test('T1969',
# 2017-03-24 9261052 (x86/Linux, 64-bit machine)
# 2017-04-06 9418680 (x86/Linux, 64-bit machine)
(wordsize(64), 22311600, 15)]),
(wordsize(64), 19738608, 15)]),
# 2014-09-10 10463640, 10 # post-AMP-update (somewhat stabelish)
# looks like the peak is around ~10M, but we're
# unlikely to GC exactly on the peak.
......@@ -90,6 +91,7 @@ test('T1969',
# 2017-03-31 16679176 Fix memory leak in simplifier
# 2017-08-25 19199872 Refactor the Mighty Simplifier
# 2018-02-19 22311600 (amd64/Linux) Unknown
# 2018-07-10 19738608 (amd64/Linux) Fix space leaks
compiler_stats_num_field('bytes allocated',
[(platform('i386-unknown-mingw32'), 301784492, 5),
......@@ -108,7 +110,7 @@ test('T1969',
# 2015-07-11 288699104 (x86/Linux, 64-bit machine) use +RTS -G1
# 2016-04-06 344730660 (x86/Linux, 64-bit machine)
# 2017-03-24 324586096 (x86/Linux, 64-bit machine)
(wordsize(64), 659863176, 5)]),
(wordsize(64), 670839456, 5)]),
# 2009-11-17 434845560 (amd64/Linux)
# 2009-12-08 459776680 (amd64/Linux)
# 2010-05-17 519377728 (amd64/Linux)
......@@ -132,6 +134,7 @@ test('T1969',
# 2017-02-17 831733376 (x86_64/Linux) Type-indexed Typeable
# 2017-02-25 695354904 (x86_64/Linux) Early inlining patch
# 2017-04-21 659863176 (x86_64/Linux) Unknown
# 2018-07-10 670839456 (x86_64/Linux) Unknown (just updating)
only_ways(['normal']),
extra_hc_opts('-dcore-lint -static'),
......
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