summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2021-03-29 18:15:03 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-04-01 00:40:07 -0400
commit7acfb61777caa5f44f5c34c79ef983c9b303191f (patch)
tree3d8a6b63b08bc8b0f672205005cbdd3c9cc1c7b0
parent0219297c874659169507fa67c469d65bb9fabb1b (diff)
downloadhaskell-7acfb61777caa5f44f5c34c79ef983c9b303191f.tar.gz
Move HPT in UnitEnv
-rw-r--r--compiler/GHC.hs11
-rw-r--r--compiler/GHC/Driver/Backpack.hs4
-rw-r--r--compiler/GHC/Driver/Env.hs8
-rw-r--r--compiler/GHC/Driver/Env/Types.hs21
-rw-r--r--compiler/GHC/Driver/Main.hs12
-rw-r--r--compiler/GHC/Driver/Make.hs25
-rw-r--r--compiler/GHC/Driver/Pipeline.hs1
-rw-r--r--compiler/GHC/Iface/Load.hs24
-rw-r--r--compiler/GHC/Unit/Env.hs26
-rw-r--r--ghc/GHCi/Leak.hs4
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