diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-10-08 09:59:02 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-10-12 19:17:15 -0400 |
commit | 0d7117916541d6bb0041200e128ce4088086a973 (patch) | |
tree | 6dcda6104b966e0a89ccf82196c26d2b965718e3 /compiler | |
parent | 053d9deb3c107db0d292a6a8dc4ba8cf2d432743 (diff) | |
download | haskell-0d7117916541d6bb0041200e128ce4088086a973.tar.gz |
More strictness around HomePackageTable
This patch makes some operations to do with HomePackageTable stricter
* Adding a new entry into the HPT would not allow the old HomeModInfo to be
collected because the function used by insertWith wouldn't be forced.
* We're careful to force the new MVar value before it's inserted into
the global MVar as otherwise we retain references to old entries.
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Types/Unique/DFM.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Unit/Home/ModInfo.hs | 4 |
3 files changed, 20 insertions, 10 deletions
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 1482bdb539..7f740f0123 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -738,11 +738,11 @@ pruneHomePackageTable hpt summ where prune hmi = hmi'{ hm_details = emptyModDetails } where modl = moduleName (mi_module (hm_iface hmi)) - hmi' | mi_src_hash (hm_iface hmi) /= ms_hs_hash ms + hmi' | Just ms <- lookupUFM ms_map modl + , mi_src_hash (hm_iface hmi) /= ms_hs_hash ms = hmi{ hm_linkable = Nothing } | otherwise = hmi - where ms = expectJust "prune" (lookupUFM ms_map modl) ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] @@ -990,7 +990,7 @@ interpretBuildPlan deps_map plan = do hmi <- executeCompileNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) knot_var (emsModSummary ms) -- This global MVar is incrementally modified in order to avoid having to -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hpt_var (return . addHomeModInfoToHpt hmi) + liftIO $ modifyMVar_ hpt_var (\hpt -> return $! addHomeModInfoToHpt hmi hpt) return (Just hmi) res_var <- liftIO newEmptyMVar @@ -1009,8 +1009,8 @@ interpretBuildPlan deps_map plan = do hpt_var <- gets hpt_var res_var <- liftIO newEmptyMVar let loop_action = do - hmis <- executeTypecheckLoop (readMVar hpt_var) (wait_deps wait_modules) - liftIO $ modifyMVar_ hpt_var (\hpt -> return $ foldl' (flip addHomeModInfoToHpt) hpt hmis) + !hmis <- executeTypecheckLoop (readMVar hpt_var) (wait_deps wait_modules) + liftIO $ modifyMVar_ hpt_var (\hpt -> return $! foldl' (flip addHomeModInfoToHpt) hpt hmis) return hmis diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs index f143af2b58..4b0f5e545d 100644 --- a/compiler/GHC/Types/Unique/DFM.hs +++ b/compiler/GHC/Types/Unique/DFM.hs @@ -72,6 +72,7 @@ import GHC.Prelude import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) import GHC.Utils.Outputable +import qualified Data.IntMap.Strict as MS import qualified Data.IntMap as M import Data.Data import Data.Functor.Classes (Eq1 (..)) @@ -121,7 +122,7 @@ import Unsafe.Coerce -- | A type of values tagged with insertion time data TaggedVal val = TaggedVal - val + !val {-# UNPACK #-} !Int -- ^ insertion time deriving stock (Data, Functor, Foldable, Traversable) @@ -174,20 +175,24 @@ addToUDFM m k v = addToUDFM_Directly m (getUnique k) v -- The new binding always goes to the right of existing ones addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt addToUDFM_Directly (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i -- Keep the old tag, but insert the new value -- This means that udfmToList typically returns elements -- in the order of insertion, rather than the reverse + -- It is quite critical that the strict insertWith is used as otherwise + -- the combination function 'tf' is not forced and both old values are retained + -- in the map. + addToUDFM_C_Directly :: (elt -> elt -> elt) -- old -> new -> result -> UniqDFM key elt -> Unique -> elt -> UniqDFM key elt addToUDFM_C_Directly f (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where tf (TaggedVal new_v _) (TaggedVal old_v old_i) = TaggedVal (f old_v new_v) old_i @@ -399,7 +404,10 @@ alterUDFM f (UDFM m i) k = -- | Map a function over every value in a UniqDFM mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 -mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i +mapUDFM f (UDFM m i) = UDFM (MS.map (fmap f) m) i +-- Critical this is strict map, otherwise you get a big space leak when reloading +-- in GHCi because all old ModDetails are retained (see pruneHomePackageTable). +-- Modify with care. mapMaybeUDFM :: forall elt1 elt2 key. (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs index d41bc0c9f6..b5960a5223 100644 --- a/compiler/GHC/Unit/Home/ModInfo.hs +++ b/compiler/GHC/Unit/Home/ModInfo.hs @@ -41,10 +41,12 @@ data HomeModInfo = HomeModInfo -- ^ The basic loaded interface file: every loaded module has one of -- these, even if it is imported from another package - , hm_details :: !ModDetails + , hm_details :: ModDetails -- ^ Extra information that has been created from the 'ModIface' for -- the module, typically during typechecking + -- This field is LAZY because a ModDetails is constructed by knot tying. + , hm_linkable :: !(Maybe Linkable) -- ^ The actual artifact we would like to link to access things in -- this module. |