[Git][ghc/ghc][master] Cache HomeUnit in HscEnv (#17957)
Marge Bot
gitlab at gitlab.haskell.org
Fri Oct 9 12:55:32 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6a243e9d by Sylvain Henry at 2020-10-09T08:55:21-04:00
Cache HomeUnit in HscEnv (#17957)
Instead of recreating the HomeUnit from the DynFlags every time we need
it, we store it in the HscEnv.
- - - - -
29 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Finder.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Types.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Linker.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
Changes:
=====================================
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
, 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
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -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
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -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)
Nothing -> tcImportDecl_maybe name }
@@ -402,8 +402,8 @@ loadInterface :: SDoc -> Module -> WhereFrom
loadInterface doc_str mod from
| isHoleModule mod
-- Hole modules get special treatment
- = do dflags <- getDynFlags
- let home_unit = mkHomeUnitFromFlags dflags
+ = do hsc_env <- getTopEnv
+ let home_unit = hsc_home_unit hsc_env
-- Redo search for our local hole module
loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from
| otherwise
@@ -416,7 +416,8 @@ loadInterface doc_str mod from
-- Check whether we have the interface already
; dflags <- getDynFlags
- ; let home_unit = mkHomeUnitFromFlags dflags
+ ; hsc_env <- getTopEnv
+ ; let home_unit = hsc_home_unit hsc_env
; case lookupIfaceByModule hpt (eps_PIT eps) mod of {
Just iface
-> return (Succeeded iface) ; -- Already loaded
@@ -643,8 +644,8 @@ computeInterface ::
-> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
computeInterface doc_str hi_boot_file mod0 = do
MASSERT( not (isHoleModule mod0) )
- dflags <- getDynFlags
- let home_unit = mkHomeUnitFromFlags dflags
+ hsc_env <- getTopEnv
+ let home_unit = hsc_home_unit hsc_env
case getModuleInstantiation mod0 of
(imod, Just indef) | isHomeUnitIndefinite home_unit -> do
r <- findAndReadIface doc_str imod mod0 hi_boot_file
@@ -925,7 +926,7 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
-- Look for the file
hsc_env <- getTopEnv
mb_found <- liftIO (findExactModule hsc_env mod)
- let home_unit = mkHomeUnitFromFlags dflags
+ let home_unit = hsc_home_unit hsc_env
case mb_found of
InstalledFound loc mod -> do
-- Found file, so read it
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -172,7 +172,7 @@ mkIfaceTc hsc_env safe_mode mod_details
= do
let used_names = mkUsedNames tc_result
let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env))
- let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+ let home_unit = hsc_home_unit hsc_env
deps <- mkDependencies (homeUnitId home_unit)
(map mi_module pluginModules) tc_result
let hpc_info = emptyHpcInfo other_hpc_info
@@ -228,7 +228,7 @@ mkIface_ hsc_env
-- to expose in the interface
= do
- let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+ let home_unit = hsc_home_unit hsc_env
semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod)
entities = typeEnvElts type_env
show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env)
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -256,7 +256,7 @@ checkVersions hsc_env mod_summary iface
; return (recomp, Just iface)
}}}}}}}}}}
where
- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+ home_unit = hsc_home_unit hsc_env
-- This is a bit of a hack really
mod_deps :: ModuleNameEnv ModuleNameWithIsBoot
mod_deps = mkModDeps (dep_mods (mi_deps iface))
@@ -335,8 +335,8 @@ pluginRecompileToRecompileRequired old_fp new_fp pr
-- implementing module has changed.
checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
checkHsig mod_summary iface = do
- dflags <- getDynFlags
- let home_unit = mkHomeUnitFromFlags dflags
+ hsc_env <- getTopEnv
+ let home_unit = hsc_home_unit hsc_env
outer_mod = ms_mod mod_summary
inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)
MASSERT( isHomeModule home_unit outer_mod )
@@ -453,7 +453,7 @@ checkDependencies hsc_env summary iface
prev_dep_mods = dep_mods (mi_deps iface)
prev_dep_plgn = dep_plgins (mi_deps iface)
prev_dep_pkgs = dep_pkgs (mi_deps iface)
- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+ home_unit = hsc_home_unit hsc_env
dep_missing (mb_pkg, L _ mod) = do
find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
@@ -486,7 +486,6 @@ checkDependencies hsc_env summary iface
isOldHomeDeps = flip Set.member old_deps
checkForNewHomeDependency (L _ mname) = do
let
- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
mod = mkHomeModule home_unit mname
str_mname = moduleNameString mname
reason = str_mname ++ " changed"
@@ -1359,8 +1358,7 @@ mkHashFun hsc_env eps name
| otherwise
= lookup orig_mod
where
- dflags = hsc_dflags hsc_env
- home_unit = mkHomeUnitFromFlags dflags
+ home_unit = hsc_home_unit hsc_env
hpt = hsc_HPT hsc_env
pit = eps_PIT eps
occ = nameOccName name
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -300,7 +300,7 @@ rnIfaceGlobal :: Name -> ShIfM Name
rnIfaceGlobal n = do
hsc_env <- getTopEnv
let dflags = hsc_dflags hsc_env
- home_unit = mkHomeUnitFromFlags dflags
+ home_unit = hsc_home_unit hsc_env
iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
mb_nsubst <- fmap sh_if_shape getGblEnv
hmap <- getHoleSubst
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -371,7 +371,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; expose_all = gopt Opt_ExposeAllUnfoldings dflags
; print_unqual = mkPrintUnqualified
(unitState dflags)
- (mkHomeUnitFromFlags dflags)
+ (hsc_home_unit hsc_env)
rdr_env
; implicit_binds = concatMap getImplicitBinds tcs
}
=====================================
compiler/GHC/Iface/Tidy/StaticPtrTable.hs
=====================================
@@ -241,11 +241,11 @@ sptCreateStaticBinds hsc_env this_mod binds
PW8 -> mkWordLit platform . toInteger
lookupIdHscEnv :: Name -> IO Id
- lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
+ lookupIdHscEnv n = lookupType hsc_env n >>=
maybe (getError n) (return . tyThingId)
lookupDataConHscEnv :: Name -> IO DataCon
- lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=
+ lookupDataConHscEnv n = lookupType hsc_env n >>=
maybe (getError n) (return . tyThingDataCon)
getError n = pprPanic "sptCreateStaticBinds.get: not found" $
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1669,7 +1669,7 @@ tcIfaceGlobal name
where
via_external = 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 thing ;
Nothing -> do
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -43,7 +43,6 @@ import GHC.Tc.Utils.Monad
import GHC.Types.ForeignCall ( CCallTarget(..) )
import GHC.Unit
-import GHC.Driver.Types ( Warnings(..), plusWarns )
import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName
, monadClassName, returnMName, thenMName
, semigroupClassName, sappendName
@@ -61,7 +60,7 @@ import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
import GHC.Utils.Misc ( debugIsOn, lengthExceeds, partitionWith )
import GHC.Utils.Panic
-import GHC.Driver.Types ( HscEnv, hsc_dflags )
+import GHC.Driver.Types ( Warnings(..), plusWarns, HscEnv(..))
import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )
import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
, stronglyConnCompFromEdgedVerticesUniq )
@@ -350,7 +349,7 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
-- Mark any PackageTarget style imports as coming from the current package
- ; let home_unit = mkHomeUnitFromFlags (hsc_dflags topEnv)
+ ; let home_unit = hsc_home_unit topEnv
spec' = patchForeignImport (homeUnitAsUnit home_unit) spec
; return (ForeignImport { fd_i_ext = noExtField
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -365,7 +365,9 @@ rnImportDecl this_mod
|| (not implicit && safeDirectImpsReq dflags)
|| (implicit && safeImplicitImpsReq dflags)
- let imv = ImportedModsVal
+ hsc_env <- getTopEnv
+ let home_unit = hsc_home_unit hsc_env
+ imv = ImportedModsVal
{ imv_name = qual_mod_name
, imv_span = loc
, imv_is_safe = mod_safe'
@@ -373,7 +375,7 @@ rnImportDecl this_mod
, imv_all_exports = potential_gres
, imv_qualified = qual_only
}
- imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv)
+ imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv)
-- Complain if we import a deprecated module
whenWOptM Opt_WarnWarningsDeprecations (
@@ -395,13 +397,13 @@ rnImportDecl this_mod
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
-calculateAvails :: DynFlags
+calculateAvails :: HomeUnit
-> ModIface
-> IsSafeImport
-> IsBootInterface
-> ImportedBy
-> ImportAvails
-calculateAvails dflags iface mod_safe' want_boot imported_by =
+calculateAvails home_unit iface mod_safe' want_boot imported_by =
let imp_mod = mi_module iface
imp_sem_mod= mi_semantic_module iface
orph_iface = mi_orphan (mi_final_exts iface)
@@ -451,8 +453,6 @@ calculateAvails dflags iface mod_safe' want_boot imported_by =
-- to be trusted? See Note [Trust Own Package]
ptrust = trust == Sf_Trustworthy || trust_pkg
- home_unit = mkHomeUnitFromFlags dflags
-
(dependent_mods, dependent_pkgs, pkg_trust_req)
| isHomeUnit home_unit pkg =
-- Imported module is from the home package
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -811,7 +811,7 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
-- its full top-level scope available.
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
- if notHomeModule (mkHomeUnitFromFlags (hsc_dflags h)) modl
+ if notHomeModule (hsc_home_unit h) modl
then return False
else case lookupHpt (hsc_HPT h) (moduleName modl) of
Just details -> return (isJust (mi_globals (hm_iface details)))
=====================================
compiler/GHC/Runtime/Linker.hs
=====================================
@@ -682,7 +682,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
let
pkg = moduleUnit mod
deps = mi_deps iface
- home_unit = mkHomeUnitFromFlags dflags
+ home_unit = hsc_home_unit hsc_env
pkg_deps = dep_pkgs deps
(boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -161,7 +161,7 @@ forceLoadTyCon :: HscEnv -> Name -> IO TyCon
forceLoadTyCon hsc_env con_name = do
forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name
- mb_con_thing <- lookupTypeHscEnv hsc_env con_name
+ mb_con_thing <- lookupType hsc_env con_name
case mb_con_thing of
Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
Just (ATyCon tycon) -> return tycon
@@ -193,7 +193,7 @@ getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
getHValueSafely hsc_env val_name expected_type = do
forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
-- Now look up the names for the value and type constructor in the type environment
- mb_val_thing <- lookupTypeHscEnv hsc_env val_name
+ mb_val_thing <- lookupType hsc_env val_name
case mb_val_thing of
Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
Just (AnId id) -> do
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -184,7 +184,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax
where
hsc_src = ms_hsc_src mod_sum
dflags = hsc_dflags hsc_env
- home_unit = mkHomeUnitFromFlags dflags
+ home_unit = hsc_home_unit hsc_env
err_msg = mkPlainErrMsg dflags loc $
text "Module does not have a RealSrcSpan:" <+> ppr this_mod
@@ -2832,7 +2832,7 @@ loadUnqualIfaces hsc_env ictxt
= initIfaceTcRn $ do
mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
where
- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+ home_unit = hsc_home_unit hsc_env
unqual_mods = [ nameModule name
| gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -7,6 +7,7 @@
{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -173,7 +174,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
-- Step 1.5: Make sure we don't have any type synonym cycles
; traceTc "Starting synonym cycle check" (ppr tyclss)
- ; home_unit <- mkHomeUnitFromFlags <$> getDynFlags
+ ; home_unit <- hsc_home_unit <$> getTopEnv
; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds
; traceTc "Done synonym cycle check" (ppr tyclss)
@@ -4094,6 +4095,36 @@ checkValidDataCon dflags existential_ok tc con
-- Check that UNPACK pragmas and bangs work out
-- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!"
-- data T = MkT {-# UNPACK #-} !a -- Can't unpack
+ ; hsc_env <- getTopEnv
+ ; let check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()
+ check_bang bang rep_bang n
+ | HsSrcBang _ _ SrcLazy <- bang
+ , not (xopt LangExt.StrictData dflags)
+ = addErrTc (bad_bang n (text "Lazy annotation (~) without StrictData"))
+
+ | HsSrcBang _ want_unpack strict_mark <- bang
+ , isSrcUnpacked want_unpack, not (is_strict strict_mark)
+ = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))
+
+ | HsSrcBang _ want_unpack _ <- bang
+ , isSrcUnpacked want_unpack
+ , case rep_bang of { HsUnpack {} -> False; _ -> True }
+ -- If not optimising, we don't unpack (rep_bang is never
+ -- HsUnpack), so don't complain! This happens, e.g., in Haddock.
+ -- See dataConSrcToImplBang.
+ , not (gopt Opt_OmitInterfacePragmas dflags)
+ -- When typechecking an indefinite package in Backpack, we
+ -- may attempt to UNPACK an abstract type. The test here will
+ -- conclude that this is unusable, but it might become usable
+ -- when we actually fill in the abstract type. As such, don't
+ -- warn in this case (it gives users the wrong idea about whether
+ -- or not UNPACK on abstract types is supported; it is!)
+ , isHomeUnitDefinite (hsc_home_unit hsc_env)
+ = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))
+
+ | otherwise
+ = return ()
+
; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]
-- Check the dcUserTyVarBinders invariant
@@ -4125,36 +4156,9 @@ checkValidDataCon dflags existential_ok tc con
}
where
ctxt = ConArgCtxt (dataConName con)
-
- check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()
- check_bang (HsSrcBang _ _ SrcLazy) _ n
- | not (xopt LangExt.StrictData dflags)
- = addErrTc
- (bad_bang n (text "Lazy annotation (~) without StrictData"))
- check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n
- | isSrcUnpacked want_unpack, not is_strict
- = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))
- | isSrcUnpacked want_unpack
- , case rep_bang of { HsUnpack {} -> False; _ -> True }
- -- If not optimising, we don't unpack (rep_bang is never
- -- HsUnpack), so don't complain! This happens, e.g., in Haddock.
- -- See dataConSrcToImplBang.
- , not (gopt Opt_OmitInterfacePragmas dflags)
- -- When typechecking an indefinite package in Backpack, we
- -- may attempt to UNPACK an abstract type. The test here will
- -- conclude that this is unusable, but it might become usable
- -- when we actually fill in the abstract type. As such, don't
- -- warn in this case (it gives users the wrong idea about whether
- -- or not UNPACK on abstract types is supported; it is!)
- , isHomeUnitDefinite (mkHomeUnitFromFlags dflags)
- = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))
- where
- is_strict = case strict_mark of
- NoSrcStrict -> xopt LangExt.StrictData dflags
- bang -> isSrcStrict bang
-
- check_bang _ _ _
- = return ()
+ is_strict = \case
+ NoSrcStrict -> xopt LangExt.StrictData dflags
+ bang -> isSrcStrict bang
bad_bang n herald
= hang herald 2 (text "on the" <+> speakNth n
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -313,8 +313,7 @@ implicitRequirements' hsc_env normal_imports
Found _ mod | not (isHomeModule home_unit mod) ->
return (uniqDSetToList (moduleFreeHoles mod))
_ -> return []
- where dflags = hsc_dflags hsc_env
- home_unit = mkHomeUnitFromFlags dflags
+ where home_unit = hsc_home_unit hsc_env
-- | Given a 'Unit', make sure it is well typed. This is because
-- unit IDs come from Cabal, which does not know if things are well-typed or
@@ -538,7 +537,7 @@ mergeSignatures
inner_mod = tcg_semantic_mod tcg_env
mod_name = moduleName (tcg_mod tcg_env)
unit_state = unitState dflags
- home_unit = mkHomeUnitFromFlags dflags
+ home_unit = hsc_home_unit hsc_env
-- STEP 1: Figure out all of the external signature interfaces
-- we are going to merge in.
@@ -830,6 +829,7 @@ mergeSignatures
-- we hope that we get lucky / the overlapping instances never
-- get used, but it is not a very good situation to be in.
--
+ hsc_env <- getTopEnv
let merge_inst (insts, inst_env) inst
| memberInstEnv inst_env inst -- test DFun Type equality
= (insts, inst_env)
@@ -844,8 +844,9 @@ mergeSignatures
-- in the listing. We don't want it because a module is NOT
-- supposed to include itself in its dep_orphs/dep_finsts. See #13214
iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }
+ home_unit = hsc_home_unit hsc_env
avails = plusImportAvails (tcg_imports tcg_env) $
- calculateAvails dflags iface' False NotBoot ImportedBySystem
+ calculateAvails home_unit iface' False NotBoot ImportedBySystem
return tcg_env {
tcg_inst_env = inst_env,
tcg_insts = insts,
@@ -912,7 +913,9 @@ impl_msg unit_state impl_mod (Module req_uid req_mod_name)
checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv
checkImplements impl_mod req_mod@(Module uid mod_name) = do
dflags <- getDynFlags
+ hsc_env <- getTopEnv
let unit_state = unitState dflags
+ home_unit = hsc_home_unit hsc_env
addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do
let insts = instUnitInsts uid
@@ -933,7 +936,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do
loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
(dep_orphs (mi_deps impl_iface))
- let avails = calculateAvails dflags
+ let avails = calculateAvails home_unit
impl_iface False{- safe -} NotBoot ImportedBySystem
fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
| (occ, f) <- mi_fixities impl_iface
@@ -997,11 +1000,11 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do
-- checking that the implementation matches the signature.
instantiateSignature :: TcRn TcGblEnv
instantiateSignature = do
+ hsc_env <- getTopEnv
tcg_env <- getGblEnv
- dflags <- getDynFlags
let outer_mod = tcg_mod tcg_env
inner_mod = tcg_semantic_mod tcg_env
- home_unit = mkHomeUnitFromFlags dflags
+ home_unit = hsc_home_unit hsc_env
-- TODO: setup the local RdrEnv so the error messages look a little better.
-- But this information isn't stored anywhere. Should we RETYPECHECK
-- the local one just to get the information? Hmm...
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -146,8 +146,7 @@ lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
lookupGlobal_maybe hsc_env name
= do { -- Try local envt
let mod = icInteractiveModule (hsc_IC hsc_env)
- dflags = hsc_dflags hsc_env
- home_unit = mkHomeUnitFromFlags dflags
+ home_unit = hsc_home_unit hsc_env
tcg_semantic_mod = homeModuleInstantiation home_unit mod
; if nameIsLocalOrFrom tcg_semantic_mod name
@@ -162,7 +161,7 @@ lookupGlobal_maybe hsc_env name
lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
-- Returns (Failed err) if we can't find the interface file for the thing
lookupImported_maybe hsc_env name
- = do { mb_thing <- lookupTypeHscEnv hsc_env name
+ = do { mb_thing <- lookupType hsc_env name
; case mb_thing of
Just thing -> return (Succeeded thing)
Nothing -> importDecl_maybe hsc_env name
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -242,7 +242,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
th_remote_state_var <- newIORef Nothing ;
let {
dflags = hsc_dflags hsc_env ;
- home_unit = mkHomeUnitFromFlags dflags ;
+ home_unit = hsc_home_unit hsc_env ;
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax empty_val
@@ -774,8 +774,9 @@ wrapDocLoc doc = do
getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
getPrintUnqualified dflags
= do { rdr_env <- getGlobalRdrEnv
+ ; hsc_env <- getTopEnv
; let unit_state = unitState dflags
- ; let home_unit = mkHomeUnitFromFlags dflags
+ ; let home_unit = hsc_home_unit hsc_env
; return $ mkPrintUnqualified unit_state home_unit rdr_env }
-- | Like logInfoTcRn, but for user consumption
@@ -1967,9 +1968,9 @@ mkIfLclEnv mod loc boot
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
- ; dflags <- getDynFlags
+ ; hsc_env <- getTopEnv
; let !mod = tcg_semantic_mod tcg_env
- home_unit = mkHomeUnitFromFlags dflags
+ home_unit = hsc_home_unit hsc_env
-- When we are instantiating a signature, we DEFINITELY
-- do not want to knot tie.
is_instantiate = isHomeUnitInstantiating home_unit
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a243e9daaa6c17c0859f47ae3a098e680aa28cf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a243e9daaa6c17c0859f47ae3a098e680aa28cf
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201009/e55d6fa0/attachment-0001.html>
More information about the ghc-commits
mailing list