Commit 6a243e9d authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Cache HomeUnit in HscEnv (#17957)

Instead of recreating the HomeUnit from the DynFlags every time we need
it, we store it in the HscEnv.
parent db236ffc
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
, ds_if_env = (if_genv, if_lenv)
, ds_unqual = mkPrintUnqualified
(unitState dflags)
(mkHomeUnitFromFlags dflags)
rdr_env
, ds_unqual = mkPrintUnqualified unit_state home_unit rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
......
......@@ -253,7 +253,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
where
hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
home_unit = mkHomeUnitFromFlags dflags
home_unit = hsc_home_unit hsc_env
used_mods = moduleEnvKeys ent_map
dir_imp_mods = moduleEnvKeys direct_imports
......
......@@ -121,7 +121,7 @@ tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
-- Returns (Failed err) if we can't find the interface file for the thing
tcLookupImported_maybe name
= do { hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
; mb_thing <- liftIO (lookupType hsc_env name)
; case mb_thing of
Just thing -> return (Succeeded thing)