diff options
| -rw-r--r-- | compiler/ghci/Linker.hs | 33 | ||||
| -rw-r--r-- | compiler/iface/IfaceEnv.hs | 7 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 4 | ||||
| -rw-r--r-- | compiler/main/HscTypes.hs | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 9 | ||||
| -rw-r--r-- | compiler/utils/IOEnv.hs | 2 | ||||
| -rw-r--r-- | ghc/GHCi/UI.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/all.T | 9 |
8 files changed, 44 insertions, 33 deletions
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 8d0338a9dd..2af03ddde8 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -1,4 +1,5 @@ {-# 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 diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs index 00bcaa77f1..864c09ce2e 100644 --- a/compiler/iface/IfaceEnv.hs +++ b/compiler/iface/IfaceEnv.hs @@ -1,6 +1,6 @@ -- (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 } {- diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 92e3455521..94a0a31887 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1,4 +1,4 @@ -{-# 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 } diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 0ef1487312..0c375f074c 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -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 diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 26f549b3fc..4382467100 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -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) && diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index b9210702fa..4640b2b7c2 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -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 diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 15cfcf3362..bcb6d6e38c 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -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 diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 6632231999..eed616b7e9 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -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'), |