Move HPT in UnitEnv

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