From 7acfb61777caa5f44f5c34c79ef983c9b303191f Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Mon, 29 Mar 2021 18:15:03 +0200 Subject: Move HPT in UnitEnv --- compiler/GHC.hs | 11 +++++++---- compiler/GHC/Driver/Backpack.hs | 4 +++- compiler/GHC/Driver/Env.hs | 8 ++++++++ compiler/GHC/Driver/Env/Types.hs | 21 --------------------- compiler/GHC/Driver/Main.hs | 12 +++--------- compiler/GHC/Driver/Make.hs | 25 +++++++++++++------------ compiler/GHC/Driver/Pipeline.hs | 1 + compiler/GHC/Iface/Load.hs | 24 +++++++++++++++--------- compiler/GHC/Unit/Env.hs | 26 ++++++++++++++++++++++++++ ghc/GHCi/Leak.hs | 4 ++-- 10 files changed, 78 insertions(+), 58 deletions(-) diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 65716d0e95..23e74fb35a 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -641,7 +641,8 @@ setSessionDynFlags dflags0 = do logger <- getLogger dflags <- checkNewDynFlags logger dflags0 hsc_env <- getSession - let cached_unit_dbs = ue_unit_dbs (hsc_unit_env hsc_env) + let old_unit_env = hsc_unit_env hsc_env + let cached_unit_dbs = ue_unit_dbs old_unit_env (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags cached_unit_dbs -- Interpreter @@ -684,6 +685,7 @@ setSessionDynFlags dflags0 = do { ue_platform = targetPlatform dflags , ue_namever = ghcNameVersion dflags , ue_home_unit = Just home_unit + , ue_hpt = ue_hpt old_unit_env , ue_units = unit_state , ue_unit_dbs = Just dbs } @@ -713,13 +715,14 @@ setProgramDynFlags_ invalidate_needed dflags = do let changed = packageFlagsChanged dflags_prev dflags' if changed then do - hsc_env <- getSession - let cached_unit_dbs = ue_unit_dbs (hsc_unit_env hsc_env) + old_unit_env <- hsc_unit_env <$> getSession + let cached_unit_dbs = ue_unit_dbs old_unit_env (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags' cached_unit_dbs let unit_env = UnitEnv { ue_platform = targetPlatform dflags' , ue_namever = ghcNameVersion dflags' , ue_home_unit = Just home_unit + , ue_hpt = ue_hpt old_unit_env , ue_units = unit_state , ue_unit_dbs = Just dbs } @@ -1211,7 +1214,7 @@ loadModule tcm = do hsc_env ms 1 1 Nothing mb_linkable source_modified - modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info } + modifySession $ hscUpdateHPT (\hpt -> addToHpt hpt mod mod_info) return tcm diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 205ecccc40..fce04654c0 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -417,7 +417,8 @@ addUnit :: GhcMonad m => UnitInfo -> m () addUnit u = do hsc_env <- getSession logger <- getLogger - newdbs <- case ue_unit_dbs (hsc_unit_env hsc_env) of + let old_unit_env = hsc_unit_env hsc_env + newdbs <- case ue_unit_dbs old_unit_env of Nothing -> panic "addUnit: called too early" Just dbs -> let newdb = UnitDatabase @@ -430,6 +431,7 @@ addUnit u = do { ue_platform = targetPlatform (hsc_dflags hsc_env) , ue_namever = ghcNameVersion (hsc_dflags hsc_env) , ue_home_unit = Just home_unit + , ue_hpt = ue_hpt old_unit_env , ue_units = unit_state , ue_unit_dbs = Just dbs } diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 105c0a64a0..fb077829c9 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -5,6 +5,8 @@ module GHC.Driver.Env , HscEnv (..) , hsc_home_unit , hsc_units + , hsc_HPT + , hscUpdateHPT , runHsc , mkInteractiveHscEnv , runInteractiveHsc @@ -90,6 +92,12 @@ hsc_home_unit = unsafeGetHomeUnit . hsc_unit_env hsc_units :: HscEnv -> UnitState hsc_units = ue_units . hsc_unit_env +hsc_HPT :: HscEnv -> HomePackageTable +hsc_HPT = ue_hpt . hsc_unit_env + +hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv +hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHpt f (hsc_unit_env hsc_env) } + {- Note [Target code interpreter] diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs index ff387f1d1e..d926b27ac8 100644 --- a/compiler/GHC/Driver/Env/Types.hs +++ b/compiler/GHC/Driver/Env/Types.hs @@ -15,7 +15,6 @@ import GHC.Types.Target import GHC.Types.TypeEnv import GHC.Unit.External import GHC.Unit.Finder.Types -import GHC.Unit.Home.ModInfo import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Unit.Types @@ -76,26 +75,6 @@ data HscEnv hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements - hsc_HPT :: HomePackageTable, - -- ^ The home package table describes already-compiled - -- home-package modules, /excluding/ the module we - -- are compiling right now. - -- (In one-shot mode the current module is the only - -- home-package module, so hsc_HPT is empty. All other - -- modules count as \"external-package\" modules. - -- However, even in GHCi mode, hi-boot interfaces are - -- demand-loaded into the external-package table.) - -- - -- 'hsc_HPT' is not mutable because we only demand-load - -- external packages; the home package is eagerly - -- loaded, module by module, by the compilation manager. - -- - -- The HPT may contain modules compiled earlier by @--make@ - -- but not actually below the current module in the dependency - -- graph. - -- - -- (This changes a previous invariant: changed Jan 05.) - hsc_EPS :: {-# UNPACK #-} !ExternalUnitCache, -- ^ Information about the currently loaded external packages. -- This is mutable because packages will be demand-loaded during diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 7ea0cd6ae0..ae4fd216a8 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -249,15 +249,11 @@ newHscEnv dflags = do logger <- initLogger tmpfs <- initTmpFs unit_env <- initUnitEnv (ghcNameVersion dflags) (targetPlatform dflags) - -- FIXME: it's sad that we have so many "unitialized" fields filled with - -- empty stuff or lazy panics. We should have two kinds of HscEnv - -- (initialized or not) instead and less fields that are mutable over time. return HscEnv { hsc_dflags = dflags , hsc_logger = logger , hsc_targets = [] , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags - , hsc_HPT = emptyHomePackageTable , hsc_EPS = eps_var , hsc_NC = nc_var , hsc_FC = fc_var @@ -813,11 +809,9 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result Left iface -> do -- Knot tying! See Note [Knot-tying typecheckIface] details <- liftIO . fixIO $ \details' -> do - let hsc_env' = - hsc_env { - hsc_HPT = addToHpt (hsc_HPT hsc_env) - (ms_mod_name mod_summary) (HomeModInfo iface details' Nothing) - } + let act hpt = addToHpt hpt (ms_mod_name mod_summary) + (HomeModInfo iface details' Nothing) + let hsc_env' = hscUpdateHPT act hsc_env -- NB: This result is actually not that useful -- in one-shot mode, since we're not going to do -- any further typechecking. It's much more useful diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index a83597deb1..4036208954 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -493,7 +493,7 @@ load' how_much mHscMessage mod_graph = do -- before we unload anything, make sure we don't leave an old -- interactive context around pointing to dead bindings. Also, -- write the pruned HPT to allow the old HPT to be GC'd. - setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt } + setSession $ discardIC $ hscUpdateHPT (const pruned_hpt) hsc_env liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco) @@ -578,7 +578,7 @@ load' how_much mHscMessage mod_graph = do let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs | otherwise = upsweep - setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $ upsweep_fn mHscMessage pruned_hpt stable_mods mg @@ -693,7 +693,7 @@ load' how_much mHscMessage mod_graph = do False hpt5 - modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 } + modifySession $ hscUpdateHPT (const hpt5) loadFinish Failed linkresult partitionNodes @@ -726,8 +726,9 @@ loadFinish all_ok Succeeded -- | Forget the current program, but retain the persistent info in HscEnv discardProg :: HscEnv -> HscEnv discardProg hsc_env - = discardIC $ hsc_env { hsc_mod_graph = emptyMG - , hsc_HPT = emptyHomePackageTable } + = discardIC + $ hscUpdateHPT (const emptyHomePackageTable) + $ hsc_env { hsc_mod_graph = emptyMG } -- | Discard the contents of the InteractiveContext, but keep the DynFlags. -- It will also keep ic_int_print and ic_monad if their names are from @@ -1461,9 +1462,9 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags -- Update and fetch the global HscEnv. lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do - let hsc_env' = hsc_env - { hsc_HPT = addToHpt (hsc_HPT hsc_env) - this_mod mod_info } + let hsc_env' = hscUpdateHPT (\hpt -> addToHpt hpt this_mod mod_info) + hsc_env + -- We've finished typechecking the module, now we must -- retypecheck the loop AGAIN to ensure unfoldings are -- updated. This time, however, we include the loop @@ -1613,8 +1614,8 @@ upsweep mHscMessage old_hpt stable_mods sccs = do let this_mod = ms_mod_name mod -- Add new info to hsc_env - hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info - hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing } + hsc_env3 = (hscUpdateHPT (\hpt -> addToHpt hpt this_mod mod_info) hsc_env2) + { hsc_type_env_var = Nothing } -- Space-saving: delete the old HPT entry -- for mod BUT if mod is a hs-boot @@ -2024,14 +2025,14 @@ typecheckLoop dflags hsc_env mods = do text "Re-typechecking loop: " <> ppr mods new_hpt <- fixIO $ \new_hpt -> do - let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $ mapM (typecheckIface . hm_iface) hmis let new_hpt = addListToHpt old_hpt (zip mods [ hmi{ hm_details = details } | (hmi,details) <- zip hmis mds ]) return new_hpt - return hsc_env{ hsc_HPT = new_hpt } + return (hscUpdateHPT (const new_hpt) hsc_env) where logger = hsc_logger hsc_env old_hpt = hsc_HPT hsc_env diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 191e802e02..16d43017c6 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -825,6 +825,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) , ue_home_unit = Just home_unit , ue_units = unit_state , ue_unit_dbs = Just dbs + , ue_hpt = emptyHomePackageTable } let hsc_env'' = hsc_env' { hsc_unit_env = unit_env diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 2cd2e15819..d2d3e858e9 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -4,7 +4,7 @@ -} -{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} +{-# LANGUAGE CPP, BangPatterns, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} @@ -631,7 +631,7 @@ home-package modules however, so it's safe for the HPT to be empty. dontLeakTheHPT :: IfL a -> IfL a dontLeakTheHPT thing_inside = do let - cleanTopEnv HscEnv{..} = + cleanTopEnv hsc_env = let -- wrinkle: when we're typechecking in --backpack mode, the -- instantiation of a signature might reside in the HPT, so @@ -642,14 +642,20 @@ dontLeakTheHPT thing_inside = do -- a bit of a hack, better suggestions welcome). A number of -- tests in testsuite/tests/backpack break without this -- tweak. - !hpt | backend hsc_dflags == NoBackend = hsc_HPT - | otherwise = emptyHomePackageTable + old_unit_env = hsc_unit_env hsc_env + !unit_env + | NoBackend <- backend (hsc_dflags hsc_env) + = old_unit_env + | otherwise + = old_unit_env + { ue_hpt = emptyHomePackageTable + } in - HscEnv { hsc_targets = panic "cleanTopEnv: hsc_targets" - , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph" - , hsc_IC = panic "cleanTopEnv: hsc_IC" - , hsc_HPT = hpt - , .. } + hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets" + , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph" + , hsc_IC = panic "cleanTopEnv: hsc_IC" + , hsc_unit_env = unit_env + } updTopEnv cleanTopEnv $ do !_ <- getTopEnv -- force the updTopEnv diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs index 89e8d77586..8ba341cb6f 100644 --- a/compiler/GHC/Unit/Env.hs +++ b/compiler/GHC/Unit/Env.hs @@ -2,6 +2,7 @@ module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv , unsafeGetHomeUnit + , updateHpt , preloadUnitsInfo , preloadUnitsInfo' ) @@ -12,6 +13,7 @@ import GHC.Prelude import GHC.Unit.State import GHC.Unit.Home import GHC.Unit.Types +import GHC.Unit.Home.ModInfo import GHC.Platform import GHC.Settings @@ -35,6 +37,26 @@ data UnitEnv = UnitEnv , ue_home_unit :: !(Maybe HomeUnit) -- ^ Home unit + , ue_hpt :: !HomePackageTable + -- ^ The home package table describes already-compiled + -- home-package modules, /excluding/ the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as \"external-package\" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loaded into the external-package table.) + -- + -- 'hsc_HPT' is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by @--make@ + -- but not actually below the current module in the dependency + -- graph. + -- + -- (This changes a previous invariant: changed Jan 05.) + , ue_platform :: !Platform -- ^ Platform @@ -48,6 +70,7 @@ initUnitEnv namever platform = do { ue_units = emptyUnitState , ue_unit_dbs = Nothing , ue_home_unit = Nothing + , ue_hpt = emptyHomePackageTable , ue_platform = platform , ue_namever = namever } @@ -60,6 +83,9 @@ unsafeGetHomeUnit ue = case ue_home_unit ue of Nothing -> panic "unsafeGetHomeUnit: No home unit" Just h -> h +updateHpt :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv +updateHpt f ue = ue { ue_hpt = f (ue_hpt ue) } + -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs index e973390e3e..6102df9e04 100644 --- a/ghc/GHCi/Leak.hs +++ b/ghc/GHCi/Leak.hs @@ -38,9 +38,9 @@ data LeakModIndicators = LeakModIndicators -- | Grab weak references to some of the data structures representing -- the currently loaded modules. getLeakIndicators :: HscEnv -> IO LeakIndicators -getLeakIndicators HscEnv{..} = +getLeakIndicators hsc_env = fmap LeakIndicators $ - forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do + forM (eltsUDFM (hsc_HPT hsc_env)) $ \hmi@HomeModInfo{..} -> do leakMod <- mkWeakPtr hmi Nothing leakIface <- mkWeakPtr hm_iface Nothing leakDetails <- mkWeakPtr hm_details Nothing -- cgit v1.2.1