diff options
Diffstat (limited to 'compiler')
| -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 |
6 files changed, 34 insertions, 27 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 |