Cache HomeUnit in HscEnv (#17957)

Instead of recreating the HomeUnit from the DynFlags every time we need
it, we store it in the HscEnv.

compiler/GHC.hs

@@ -600,9 +600,9 @@ checkBrokenTablesNextToCode' dflags
 -- can ignore the list of packages returned.
 --
 setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
-setSessionDynFlags dflags = do
-  dflags' <- checkNewDynFlags dflags
-  dflags''' <- liftIO $ initUnits dflags'
+setSessionDynFlags dflags0 = do
+  dflags1 <- checkNewDynFlags dflags0
+  dflags <- liftIO $ initUnits dflags1
 
   -- Interpreter
   interp  <- if gopt Opt_ExternalInterpreter dflags
@@ -637,11 +637,12 @@ setSessionDynFlags dflags = do
       return Nothing
 #endif
 
-  modifySession $ \h -> h{ hsc_dflags = dflags'''
-                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' }
+  modifySession $ \h -> h{ hsc_dflags = dflags
+                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags }
                          , hsc_interp = hsc_interp h <|> interp
                            -- we only update the interpreter if there wasn't
                            -- already one set up
+                         , hsc_home_unit = mkHomeUnitFromFlags dflags
                          }
   invalidateModSummaryCache
 
@@ -1171,7 +1172,7 @@ getPrintUnqual = withSession $ \hsc_env -> do
   let dflags = hsc_dflags hsc_env
   return $ icPrintUnqual
                (unitState dflags)
-               (mkHomeUnitFromFlags dflags)
+               (hsc_home_unit hsc_env)
                (hsc_IC hsc_env)
 
 -- | Container for information about a 'Module'.
@@ -1270,7 +1271,7 @@ mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
   let dflags          = hsc_dflags hsc_env
       mk_print_unqual = mkPrintUnqualified
                            (unitState dflags)
-                           (mkHomeUnitFromFlags dflags)
+                           (hsc_home_unit hsc_env)
   return (fmap mk_print_unqual (minf_rdr_env minf))
 
 modInfoLookupName :: GhcMonad m =>
@@ -1279,10 +1280,7 @@ modInfoLookupName :: GhcMonad m =>
 modInfoLookupName minf name = withSession $ \hsc_env -> do
    case lookupTypeEnv (minf_type_env minf) name of
      Just tyThing -> return (Just tyThing)
-     Nothing      -> do
-       eps <- liftIO $ readIORef (hsc_EPS hsc_env)
-       return $! lookupType (hsc_dflags hsc_env)
-                            (hsc_HPT hsc_env) (eps_PTE eps) name
+     Nothing      -> liftIO (lookupType hsc_env name)
 
 modInfoIface :: ModuleInfo -> Maybe ModIface
 modInfoIface = minf_iface
@@ -1308,7 +1306,7 @@ isDictonaryId id
 -- 'setContext'.
 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
 lookupGlobalName name = withSession $ \hsc_env -> do
-   liftIO $ lookupTypeHscEnv hsc_env name
+   liftIO $ lookupType hsc_env name
 
 findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
 findGlobalAnns deserialize target = withSession $ \hsc_env -> do
@@ -1501,7 +1499,7 @@ showRichTokenStream ts = go startLoc ts ""
 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
 findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
   let dflags = hsc_dflags hsc_env
-      home_unit = mkHomeUnitFromFlags dflags
+      home_unit = hsc_home_unit hsc_env
   case maybe_pkg of
     Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do
       res <- findImportedModule hsc_env mod_name maybe_pkg

compiler/GHC/Core/Opt/Pipeline.hs

@@ -103,7 +103,7 @@ core2core hsc_env guts@(ModGuts { mg_module  = mod
     hpt_rule_base  = mkRuleBase home_pkg_rules
     print_unqual   = mkPrintUnqualified
                         (unitState dflags)
-                        (mkHomeUnitFromFlags dflags)
+                        (hsc_home_unit hsc_env)
                         rdr_env
     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
     -- This is very convienent for the users of the monad (e.g. plugins do not have to
@@ -696,7 +696,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
     }
   where
     dflags       = hsc_dflags hsc_env
-    print_unqual = mkPrintUnqualified (unitState dflags) (mkHomeUnitFromFlags dflags) rdr_env
+    print_unqual = mkPrintUnqualified (unitState dflags) (hsc_home_unit hsc_env) rdr_env
     simpl_env    = mkSimplEnv mode
     active_rule  = activeRule mode
     active_unf   = activeUnfolding mode

compiler/GHC/CoreToStg/Prep.hs

@@ -1556,7 +1556,7 @@ mkConvertNumLiteral hsc_env = do
    let
       dflags   = hsc_dflags hsc_env
       platform = targetPlatform dflags
-      home_unit = mkHomeUnitFromFlags dflags
+      home_unit = hsc_home_unit hsc_env
       guardBignum act
          | isHomeUnitInstanceOf home_unit primUnitId
          = return $ panic "Bignum literals are not supported in ghc-prim"

compiler/GHC/Driver/Backpack.hs

@@ -288,7 +288,7 @@ buildUnit session cid insts lunit = do
     conf <- withBkpSession cid insts deps_w_rns session $ do
 
         dflags <- getDynFlags
-        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+        mod_graph <- hsunitModuleGraph (unLoc lunit)
 
         msg <- mkBackpackMsg
         ok <- load' LoadAllTargets (Just msg) mod_graph
@@ -312,7 +312,7 @@ buildUnit session cid insts lunit = do
 
         let compat_fs = unitIdFS (indefUnit cid)
             compat_pn = PackageName compat_fs
-            unit_id   = homeUnitId (mkHomeUnitFromFlags (hsc_dflags hsc_env))
+            unit_id   = homeUnitId (hsc_home_unit hsc_env)
 
         return GenericUnitInfo {
             -- Stub data
@@ -378,8 +378,7 @@ compileExe lunit = do
     forM_ (zip [1..] deps) $ \(i, dep) ->
         compileInclude (length deps) (i, dep)
     withBkpExeSession deps_w_rns $ do
-        dflags <- getDynFlags
-        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+        mod_graph <- hsunitModuleGraph (unLoc lunit)
         msg <- mkBackpackMsg
         ok <- load' LoadAllTargets (Just msg) mod_graph
         when (failed ok) (liftIO $ exitWith (ExitFailure 1))
@@ -645,11 +644,12 @@ convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsCo
 --
 -- We don't bother trying to support GHC.Driver.Make for now, it's more trouble
 -- than it's worth for inline modules.
-hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
-hsunitModuleGraph dflags unit = do
+hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph
+hsunitModuleGraph unit = do
+    hsc_env <- getSession
     let decls = hsunitBody unit
         pn = hsPackageName (unLoc (hsunitName unit))
-        home_unit = mkHomeUnitFromFlags dflags
+        home_unit = hsc_home_unit hsc_env
 
     --  1. Create a HsSrcFile/HsigFile summary for every
     --  explicitly mentioned module/signature.

compiler/GHC/Driver/Finder.hs

@@ -81,7 +81,7 @@ flushFinderCaches hsc_env =
   atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
  where
         fc_ref       = hsc_FC hsc_env
-        home_unit    = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+        home_unit    = hsc_home_unit hsc_env
         is_ext mod _ = not (isHomeInstalledModule home_unit mod)
 
 addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
@@ -139,7 +139,7 @@ findPluginModule hsc_env mod_name =
 
 findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
 findExactModule hsc_env mod =
-    let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+    let home_unit = hsc_home_unit hsc_env
     in if isHomeInstalledModule home_unit mod
        then findInstalledHomeModule hsc_env (moduleName mod)
        else findPackageModule hsc_env mod
@@ -179,7 +179,7 @@ orIfNotFound this or_this = do
 -- was successful.)
 homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
 homeSearchCache hsc_env mod_name do_this = do
-  let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+  let home_unit = hsc_home_unit hsc_env
       mod = mkHomeInstalledModule home_unit mod_name
   modLocationCache hsc_env mod do_this
 
@@ -255,14 +255,14 @@ modLocationCache hsc_env mod do_this = do
 -- This returns a module because it's more convenient for users
 addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
 addHomeModuleToFinder hsc_env mod_name loc = do
-  let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+  let home_unit = hsc_home_unit hsc_env
       mod = mkHomeInstalledModule home_unit mod_name
   addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)
   return (mkHomeModule home_unit mod_name)
 
 uncacheModule :: HscEnv -> ModuleName -> IO ()
 uncacheModule hsc_env mod_name = do
-  let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+  let home_unit = hsc_home_unit hsc_env
       mod = mkHomeInstalledModule home_unit mod_name
   removeFromFinderCache (hsc_FC hsc_env) mod
 
@@ -284,9 +284,8 @@ findHomeModule hsc_env mod_name = do
         fr_suggestions = []
       }
  where
-  dflags    = hsc_dflags hsc_env
-  home_unit = mkHomeUnitFromFlags dflags
-  uid       = homeUnitAsUnit (mkHomeUnitFromFlags dflags)
+  home_unit = hsc_home_unit hsc_env
+  uid       = homeUnitAsUnit home_unit
 
 -- | Implements the search for a module name in the home package only.  Calling
 -- this function directly is usually *not* what you want; currently, it's used
@@ -309,7 +308,7 @@ findInstalledHomeModule hsc_env mod_name =
    homeSearchCache hsc_env mod_name $
    let
      dflags = hsc_dflags hsc_env
-     home_unit = mkHomeUnitFromFlags dflags
+     home_unit = hsc_home_unit hsc_env
      home_path = importPaths dflags
      hisuf = hiSuf dflags
      mod = mkHomeInstalledModule home_unit mod_name

compiler/GHC/Driver/Main.hs

@@ -214,6 +214,7 @@ newHscEnv dflags = do
                   ,  hsc_type_env_var = Nothing
                   ,  hsc_interp       = Nothing
                   ,  hsc_dynLinker    = emptyDynLinker
+                  ,  hsc_home_unit    = home_unit
                   }
 
 -- -----------------------------------------------------------------------------
@@ -477,7 +478,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
     hsc_env <- getHscEnv
     let hsc_src = ms_hsc_src mod_summary
         dflags = hsc_dflags hsc_env
-        home_unit = mkHomeUnitFromFlags dflags
+        home_unit = hsc_home_unit hsc_env
         outer_mod = ms_mod mod_summary
         mod_name = moduleName outer_mod
         outer_mod' = mkHomeModule home_unit mod_name
@@ -1123,9 +1124,9 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do
 hscCheckSafe' :: Module -> SrcSpan
   -> Hsc (Maybe UnitId, Set UnitId)
 hscCheckSafe' m l = do
-    dflags <- getDynFlags
-    let home_unit = mkHomeUnitFromFlags dflags
-    (tw, pkgs) <- isModSafe m l
+    hsc_env <- getHscEnv
+    let home_unit = hsc_home_unit hsc_env
+    (tw, pkgs) <- isModSafe home_unit m l
     case tw of
         False                           -> return (Nothing, pkgs)
         True | isHomeModule home_unit m -> return (Nothing, pkgs)
@@ -1133,8 +1134,8 @@ hscCheckSafe' m l = do
              -- Not necessary if that is reflected in dependencies
              | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)
   where
-    isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set UnitId)
-    isModSafe m l = do
+    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
+    isModSafe home_unit m l = do
         dflags <- getDynFlags
         iface <- lookup' m
         case iface of
@@ -1150,7 +1151,7 @@ hscCheckSafe' m l = do
                     -- check module is trusted
                     safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]
                     -- check package is trusted
-                    safeP = packageTrusted dflags trust trust_own_pkg m
+                    safeP = packageTrusted dflags home_unit trust trust_own_pkg m
                     -- pkg trust reqs
                     pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'
                     -- warn if Safe module imports Safe-Inferred module.
@@ -1195,16 +1196,16 @@ hscCheckSafe' m l = do
     -- modules are trusted without requiring that their package is trusted. For
     -- trustworthy modules, modules in the home package are trusted but
     -- otherwise we check the package trust flag.
-    packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
-    packageTrusted _ Sf_None      _ _ = False -- shouldn't hit these cases
-    packageTrusted _ Sf_Ignore    _ _ = False -- shouldn't hit these cases
-    packageTrusted _ Sf_Unsafe    _ _ = False -- prefer for completeness.
-    packageTrusted dflags _ _ _
+    packageTrusted :: DynFlags -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool
+    packageTrusted _ _ Sf_None      _ _ = False -- shouldn't hit these cases
+    packageTrusted _ _ Sf_Ignore    _ _ = False -- shouldn't hit these cases
+    packageTrusted _ _ Sf_Unsafe    _ _ = False -- prefer for completeness.
+    packageTrusted dflags _ _ _ _
         | not (packageTrustOn dflags) = True
-    packageTrusted _ Sf_Safe  False _ = True
-    packageTrusted _ Sf_SafeInferred False _ = True
-    packageTrusted dflags _ _ m
-        | isHomeModule (mkHomeUnitFromFlags dflags) m = True
+    packageTrusted _ _ Sf_Safe  False _ = True
+    packageTrusted _ _ Sf_SafeInferred False _ = True
+    packageTrusted dflags home_unit _ _ m
+        | isHomeModule home_unit m = True
         | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m)
 
     lookup' :: Module -> Hsc (Maybe ModIface)
@@ -1500,7 +1501,7 @@ hscInteractive hsc_env cgguts location = do
 hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
 hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
     let dflags   = hsc_dflags hsc_env
-        home_unit = mkHomeUnitFromFlags dflags
+        home_unit = hsc_home_unit hsc_env
         platform  = targetPlatform dflags
     cmm <- ioMsgMaybe
                $ do

compiler/GHC/Driver/Make.hs

@@ -661,7 +661,7 @@ discardIC hsc_env
     | nameIsFromExternalPackage home_unit old_name = old_name
     | otherwise = ic_name empty_ic
     where
-    home_unit = mkHomeUnitFromFlags dflags
+    home_unit = hsc_home_unit hsc_env
     old_name = ic_name old_ic
 
 -- | If there is no -o option, guess the name of target executable
@@ -1078,7 +1078,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
                 -- work to compile the module (see parUpsweep_one).
                 m_res <- MC.try $ unmask $ prettyPrintGhcErrors lcl_dflags $
                         parUpsweep_one mod home_mod_map comp_graph_loops
-                                       lcl_dflags mHscMessage cleanup
+                                       lcl_dflags (hsc_home_unit hsc_env)
+                                       mHscMessage cleanup
                                        par_sem hsc_env_var old_hpt_var
                                        stable_mods mod_idx (length sccs)
 
@@ -1180,6 +1181,8 @@ parUpsweep_one
     -- ^ The list of all module loops within the compilation graph.
     -> DynFlags
     -- ^ The thread-local DynFlags
+    -> HomeUnit
+    -- ^ The home-unit
     -> Maybe Messager
     -- ^ The messager
     -> (HscEnv -> IO ())
@@ -1198,14 +1201,13 @@ parUpsweep_one
     -- ^ The total number of modules
     -> IO SuccessFlag
     -- ^ The result of this compile
-parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem
+parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessage cleanup par_sem
                hsc_env_var old_hpt_var stable_mods mod_index num_mods = do
 
     let this_build_mod = mkBuildModule mod
 
     let home_imps     = map unLoc $ ms_home_imps mod
     let home_src_imps = map unLoc $ ms_home_srcimps mod
-    let home_unit     = mkHomeUnitFromFlags lcl_dflags
 
     -- All the textual imports of this module.
     let textual_deps = Set.fromList $
@@ -2117,8 +2119,9 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
        -- otherwise those modules will fail to compile.
        -- See Note [-fno-code mode] #8025
        let default_backend = platformDefaultBackend (targetPlatform dflags)
+           home_unit       = hsc_home_unit hsc_env
        map1 <- case backend dflags of
-         NoBackend   -> enableCodeGenForTH default_backend map0
+         NoBackend   -> enableCodeGenForTH home_unit default_backend map0
          Interpreter -> enableCodeGenForUnboxedTuplesOrSums default_backend map0
          _           -> return map0
        if null errs
@@ -2203,10 +2206,10 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
 -- the specified target, disable optimization and change the .hi
 -- and .o file locations to be temporary files.
 -- See Note [-fno-code mode]
-enableCodeGenForTH :: Backend
+enableCodeGenForTH :: HomeUnit -> Backend
   -> NodeMap [Either ErrorMessages ModSummary]
   -> IO (NodeMap [Either ErrorMessages ModSummary])
-enableCodeGenForTH =
+enableCodeGenForTH home_unit =
   enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession
   where
     condition = isTemplateHaskellOrQQNonBoot
@@ -2214,7 +2217,7 @@ enableCodeGenForTH =
       backend dflags == NoBackend &&
       -- Don't enable codegen for TH on indefinite packages; we
       -- can't compile anything anyway! See #16219.
-      isHomeUnitDefinite (mkHomeUnitFromFlags dflags)
+      isHomeUnitDefinite home_unit
 
 -- | Update the every ModSummary that is depended on
 -- by a module that needs unboxed tuples. We enable codegen to
@@ -2503,7 +2506,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
   | otherwise  = find_it
   where
     dflags = hsc_dflags hsc_env
-    home_unit = mkHomeUnitFromFlags dflags
+    home_unit = hsc_home_unit hsc_env
 
     check_timestamp old_summary location src_fn =
         checkSummaryTimestamp

compiler/GHC/Driver/Pipeline.hs

@@ -384,7 +384,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
   -- https://gitlab.haskell.org/ghc/ghc/issues/12673
   -- and https://github.com/haskell/cabal/issues/2257
   empty_stub <- newTempName dflags TFL_CurrentModule "c"
-  let home_unit = mkHomeUnitFromFlags dflags
+  let home_unit = hsc_home_unit hsc_env
       src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
   writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
   _ <- runPipeline StopLn hsc_env
@@ -1297,7 +1297,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
         pkg_include_dirs <- liftIO $ getUnitIncludePath
                                        (initSDocContext dflags defaultUserStyle)
                                        (unitState dflags)
-                                       (mkHomeUnitFromFlags dflags)
+                                       home_unit
                                        pkgs
         let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
               (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
@@ -1329,7 +1329,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
              else getUnitExtraCcOpts
                      (initSDocContext dflags defaultUserStyle)
                      (unitState dflags)
-                     (mkHomeUnitFromFlags dflags)
+                     home_unit
                      pkgs
 
         framework_paths <-
@@ -1337,7 +1337,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
             then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath
                                                    (initSDocContext dflags defaultUserStyle)
                                                    (unitState dflags)
-                                                   (mkHomeUnitFromFlags dflags)
+                                                   home_unit
                                                    pkgs
                     let cmdlineFrameworkPaths = frameworkPaths dflags
                     return $ map ("-F"++)
@@ -1732,6 +1732,7 @@ linkBinary' staticLink dflags o_files dep_units = do
         toolSettings' = toolSettings dflags
         verbFlags = getVerbFlags dflags
         output_fn = exeFileName staticLink dflags
+        home_unit = mkHomeUnitFromFlags dflags
 
     -- get the full list of packages to link with, by combining the
     -- explicit packages with the auto packages and all of their
@@ -1744,7 +1745,7 @@ linkBinary' staticLink dflags o_files dep_units = do
     pkg_lib_paths <- getUnitLibraryPath
                         (initSDocContext dflags defaultUserStyle)
                         (unitState dflags)
-                        (mkHomeUnitFromFlags dflags)
+                        home_unit
                         (ways dflags)
                         dep_units
     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
@@ -2016,6 +2017,7 @@ linkStaticLib dflags o_files dep_units = do
   let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
       modules = o_files ++ extra_ld_inputs
       output_fn = exeFileName True dflags
+      home_unit = mkHomeUnitFromFlags dflags
 
   full_output_fn <- if isAbsolute output_fn
                     then return output_fn
@@ -2027,7 +2029,7 @@ linkStaticLib dflags o_files dep_units = do
   pkg_cfgs_init <- getPreloadUnitsAnd
                      (initSDocContext dflags defaultUserStyle)
                      (unitState dflags)
-                     (mkHomeUnitFromFlags dflags)
+                     home_unit
                      dep_units
 
   let pkg_cfgs
@@ -2056,11 +2058,12 @@ doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
 doCpp dflags raw input_fn output_fn = do
     let hscpp_opts = picPOpts dflags
     let cmdline_include_paths = includePaths dflags
+    let home_unit = mkHomeUnitFromFlags dflags
 
     pkg_include_dirs <- getUnitIncludePath
                            (initSDocContext dflags defaultUserStyle)
                            (unitState dflags)
-                           (mkHomeUnitFromFlags dflags)
+                           home_unit
                            []
     let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
           (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)

compiler/GHC/Driver/Types.hs

@@ -102,7 +102,7 @@ module GHC.Driver.Types (
         implicitTyThings, implicitTyConThings, implicitClassThings,
         isImplicitTyThing,
 
-        TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
+        TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
         typeEnvFromEntities, mkTypeEnvWithImplicits,
         extendTypeEnv, extendTypeEnvList,
         extendTypeEnvWithIds, plusTypeEnv,
@@ -490,6 +490,9 @@ data HscEnv
         , hsc_dynLinker :: DynLinker
                 -- ^ dynamic linker.
 
+        , hsc_home_unit :: !HomeUnit
+                -- ^ Home-unit
+
  }
 
 {-
@@ -2286,34 +2289,24 @@ plusTypeEnv env1 env2 = plusNameEnv env1 env2
 -- compiled modules in other packages that live in 'PackageTypeEnv'. Note
 -- that this does NOT look up the 'TyThing' in the module being compiled: you
 -- have to do that yourself, if desired
-lookupType :: DynFlags
-           -> HomePackageTable
-           -> PackageTypeEnv
-           -> Name
-           -> Maybe TyThing
-
-lookupType dflags hpt pte name
-  | isOneShot (ghcMode dflags)  -- in one-shot, we don't use the HPT
-  = lookupNameEnv pte name
-  | otherwise
-  = case lookupHptByModule hpt mod of
-       Just hm -> lookupNameEnv (md_types (hm_details hm)) name
-       Nothing -> lookupNameEnv pte name
-  where
-    mod = ASSERT2( isExternalName name, ppr name )
-          if isHoleName name
-            then mkHomeModule (mkHomeUnitFromFlags dflags) (moduleName (nameModule name))
-            else nameModule name
-
--- | As 'lookupType', but with a marginally easier-to-use interface
--- if you have a 'HscEnv'
-lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing)
-lookupTypeHscEnv hsc_env name = do
-    eps <- readIORef (hsc_EPS hsc_env)
-    return $! lookupType dflags hpt (eps_PTE eps) name
-  where
-    dflags = hsc_dflags hsc_env
-    hpt = hsc_HPT hsc_env
+lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
+lookupType hsc_env name = do
+   eps <- liftIO $ readIORef (hsc_EPS hsc_env)
+   let pte = eps_PTE eps
+       hpt = hsc_HPT hsc_env
+
+       mod = ASSERT2( isExternalName name, ppr name )
+             if isHoleName name
+               then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))
+               else nameModule name
+
+       !ty = if isOneShot (ghcMode (hsc_dflags hsc_env))
+               -- in one-shot, we don't use the HPT
+               then lookupNameEnv pte name
+               else case lookupHptByModule hpt mod of
+                Just hm -> lookupNameEnv (md_types (hm_details hm)) name
+                Nothing -> lookupNameEnv pte name
+   pure ty
 
 -- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise
 tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon

compiler/GHC/HsToCore.hs

@@ -120,7 +120,7 @@ deSugar hsc_env
                             })
 
   = do { let dflags = hsc_dflags hsc_env
-             home_unit = mkHomeUnitFromFlags dflags
+             home_unit = hsc_home_unit hsc_env
              print_unqual = mkPrintUnqualified
                               (unitState dflags)
                               home_unit
@@ -183,7 +183,7 @@ deSugar hsc_env
 
         ; let used_names = mkUsedNames tcg_env
               pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))
-              home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+              home_unit = hsc_home_unit hsc_env
         ; deps <- mkDependencies (homeUnitId home_unit)
                                  (map mi_module pluginModules) tcg_env
 

compiler/GHC/HsToCore/Monad.hs

@@ -78,6 +78,8 @@ import GHC.HsToCore.Types
 import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)
 import GHC.Types.Id
 import GHC.Unit.Module
+import GHC.Unit.Home
+import GHC.Unit.State
 import GHC.Utils.Outputable
 import GHC.Types.SrcLoc
 import GHC.Core.Type
@@ -213,6 +215,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
   = do { cc_st_var   <- liftIO $ newIORef newCostCentreState
        ; eps <- liftIO $ hscEPS hsc_env
        ; let dflags   = hsc_dflags hsc_env
+             home_unit = hsc_home_unit hsc_env
+             unit_state = unitState dflags
              this_mod = tcg_mod tcg_env
              type_env = tcg_type_env tcg_env
              rdr_env  = tcg_rdr_env tcg_env
@@ -220,7 +224,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
              complete_matches = hptCompleteSigs hsc_env         -- from the home package
                                 ++ tcg_complete_matches tcg_env -- from the current module
                                 ++ eps_complete_matches eps     -- from imports
-       ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
+       ; return $ mkDsEnvs unit_state home_unit this_mod rdr_env type_env fam_inst_env
                            msg_var cc_st_var complete_matches
        }
 
@@ -244,6 +248,8 @@ initDsWithModGuts hsc_env guts thing_inside
        ; msg_var <- newIORef emptyMessages
        ; eps <- liftIO $ hscEPS hsc_env
        ; let dflags   = hsc_dflags hsc_env
+             home_unit = hsc_home_unit hsc_env
+             unit_state = unitState dflags
              type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
              rdr_env  = mg_rdr_env guts
              fam_inst_env = mg_fam_inst_env guts
@@ -256,7 +262,7 @@ initDsWithModGuts hsc_env guts thing_inside
              bindsToIds (Rec    binds) = map fst binds
              ids = concatMap bindsToIds (mg_binds guts)
 
-             envs  = mkDsEnvs dflags this_mod rdr_env type_env
+             envs  = mkDsEnvs unit_state home_unit this_mod rdr_env type_env
                               fam_inst_env msg_var cc_st_var
                               complete_matches
        ; runDs hsc_env envs thing_inside
@@ -285,10 +291,10 @@ initTcDsForSolver thing_inside
          updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
          thing_inside }
 
-mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitState -> HomeUnit -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
          -> IORef Messages -> IORef CostCentreState -> CompleteMatches
          -> (DsGblEnv, DsLclEnv)
-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
+mkDsEnvs unit_state home_unit mod rdr_env type_env fam_inst_env msg_var cc_st_var
          complete_matches
   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
                              if_rec_types = Just (mod, return type_env) }
@@ -298,10 +304,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
         gbl_env = DsGblEnv { ds_mod     = mod
                            , ds_fam_inst_env = fam_inst_env