11 Dec '25
Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC
Commits:
0a6db432 by Simon Peyton Jones at 2025-12-11T17:44:48+00:00
Wibble to insolubles
- - - - -
1 changed file:
- compiler/GHC/Tc/Solver/FunDeps.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -1089,7 +1089,7 @@ solveFunDeps work_ev fd_eqns
= return (False, False) -- Common case no-op
| otherwise
- = do { traceTcS "bumping" (ppr work_ev)
+ = do { traceTcS "solveFunDeps {" (ppr work_ev)
; loc' <- bumpReductionDepth (ctEvLoc work_ev) (ctEvPred work_ev)
-- See (CF3) in Note [Exploiting closed type families]
@@ -1097,7 +1097,7 @@ solveFunDeps work_ev fd_eqns
<- reportFineGrainUnifications $
nestFunDepsTcS $
TcS.pushTcLevelM_ $
- -- pushTcLevelTcM: increase the level so that unification variables
+ -- pushTcLevelTcM: increase the level so that unification variablesb
-- allocated by the fundep-creation itself don't count as useful unifications
-- See Note [Deeper TcLevel for partial improvement unification variables]
do { (_, eqs) <- wrapUnifier (ctEvRewriters work_ev) loc' Nominal $
@@ -1111,7 +1111,12 @@ solveFunDeps work_ev fd_eqns
-- that were unified by the fundep
; kickOutAfterUnification unifs
- ; return (insolubleWC residual, not (isEmptyVarSet unifs)) }
+ ; let insoluble_fundeps = any insolubleCt (wc_simple residual)
+ -- Don't use insolubleWC, because that ignores Given constraints
+ -- and Given constraints are super-important when doing
+ -- tcCheckGivens in the pattern match overlap checker
+ ; traceTcS "solveFunDeps }" (ppr insoluble_fundeps <+> ppr unifs $$ ppr residual)
+ ; return (insoluble_fundeps, not (isEmptyVarSet unifs)) }
-- insolubleWC: see (CF3) in Note [Exploiting closed type families]
where
do_fundeps :: UnifyEnv -> TcM ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a6db4320b314ad835c8df61bced24c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a6db4320b314ad835c8df61bced24c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-mwb-25-07] 3 commits: Abstract out parts of mkUnitState into a handler type
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
11 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb-25-07 at Glasgow Haskell Compiler / GHC
Commits:
804668b0 by Torsten Schmits at 2025-12-11T18:16:51+01:00
Abstract out parts of mkUnitState into a handler type
- - - - -
5d0bf8f5 by Torsten Schmits at 2025-12-11T18:16:51+01:00
Abstract out module provider queries into a handler type
- - - - -
778e89ac by Torsten Schmits at 2025-12-11T18:16:51+01:00
Use unit index for name printing
- - - - -
22 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
+import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
+ index <- hscUnitIndex <$> getSession
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
then do
-- additionally, set checked dflags so we don't lose fixes
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
+ ue_index <- hscUnitIndex <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
@@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_home_unit_graph = home_unit_graph
, ue_current_unit = ue_currentUnit old_unit_env
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -1474,7 +1478,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = 's'
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
ptc = initPromotionTickContext dflags
-- 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
@@ -459,6 +460,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -471,6 +473,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -429,6 +429,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -437,7 +438,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -452,6 +453,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
+hscUnitIndex :: HscEnv -> UnitIndex
+hscUnitIndex = ue_index . hsc_unit_env
+
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery hsc_env =
+ unitIndexQuery (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -188,12 +188,13 @@ depanalE excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -511,15 +512,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
@@ -2386,7 +2387,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -337,7 +338,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -447,14 +449,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -479,6 +481,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: [UnitId]
hpt_deps = homeUnitDepends units
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
(loadSrcInterface (text "runTcInteractive") m
NotBoot mb_pkg)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphans (unLoc (ideclName i)) qual
; let imports = emptyImportAvails { imp_orphs = orphs }
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -869,7 +869,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -68,11 +68,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +206,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +218,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -67,7 +67,7 @@ import Control.Monad
import Data.Time
import qualified Data.Map as M
import GHC.Driver.Env
- ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,17 +162,19 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery hsc_env
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
@@ -194,7 +196,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -205,11 +207,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_units ue
@@ -222,13 +224,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModule fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModule fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -284,15 +286,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -218,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -577,10 +585,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +646,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1484,9 +1492,11 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> UnitId
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger unit cfg index = do
{-
Plan.
@@ -1542,15 +1552,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> readDatabases index logger unit cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1562,15 +1566,20 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
-- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
+ | otherwise = initial_dbs
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1675,6 +1684,9 @@ mkUnitState logger cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
+
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
]
@@ -1687,8 +1699,6 @@ mkUnitState logger cfg = do
req_ctx = mapUniqMap (Set.toList)
$ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
- --
-- Here we build up a set of the packages mentioned in -package
-- flags on the command line; these are called the "preload"
-- packages. we link these packages in eagerly. The preload set
@@ -1711,10 +1721,6 @@ mkUnitState logger cfg = do
$ closeUnitDeps pkg_db
$ zip (map toUnitId preload3) (repeat Nothing)
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
-
-- Force the result to avoid leaking input parameters
let !state = UnitState
{ preloadUnits = dep_preload
@@ -1722,8 +1728,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = Set.toList home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
- , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ , moduleNameProvidersMap
+ , pluginModuleNameProvidersMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1902,76 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map = unusable `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +1979,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
@@ -1933,18 +2010,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -1960,19 +2043,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2118,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (moduleProviders query unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
home_units = unitEnv_keys initial_home_graph
+ ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ae916627a5604c960823d7668f5c1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ae916627a5604c960823d7668f5c1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-mwb-25-07] 3 commits: Abstract out parts of mkUnitState into a handler type
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
11 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb-25-07 at Glasgow Haskell Compiler / GHC
Commits:
1bc1efc3 by Torsten Schmits at 2025-12-11T17:25:26+01:00
Abstract out parts of mkUnitState into a handler type
- - - - -
40e837e9 by Torsten Schmits at 2025-12-11T17:25:26+01:00
Abstract out module provider queries into a handler type
- - - - -
1ae91662 by Torsten Schmits at 2025-12-11T17:25:26+01:00
Use unit index for name printing
- - - - -
22 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
+import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
+ index <- hscUnitIndex <$> getSession
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
then do
-- additionally, set checked dflags so we don't lose fixes
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
+ ue_index <- hscUnitIndex <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
@@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_home_unit_graph = home_unit_graph
, ue_current_unit = ue_currentUnit old_unit_env
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -1474,7 +1478,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = 's'
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
ptc = initPromotionTickContext dflags
-- 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
@@ -459,6 +460,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -471,6 +473,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -429,6 +429,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -437,7 +438,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -452,6 +453,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
+hscUnitIndex :: HscEnv -> UnitIndex
+hscUnitIndex = ue_index . hsc_unit_env
+
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery hsc_env =
+ unitIndexQuery (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -188,12 +188,13 @@ depanalE excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -511,15 +512,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
@@ -2386,7 +2387,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -337,7 +338,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -447,14 +449,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -479,6 +481,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: [UnitId]
hpt_deps = homeUnitDepends units
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
(loadSrcInterface (text "runTcInteractive") m
NotBoot mb_pkg)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphans (unLoc (ideclName i)) qual
; let imports = emptyImportAvails { imp_orphs = orphs }
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -869,7 +869,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -68,11 +68,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +206,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +218,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -67,7 +67,7 @@ import Control.Monad
import Data.Time
import qualified Data.Map as M
import GHC.Driver.Env
- ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,17 +162,19 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery hsc_env
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
@@ -194,7 +196,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -205,11 +207,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_units ue
@@ -222,13 +224,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModule fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModule fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -284,15 +286,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -218,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -577,10 +585,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +646,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1484,9 +1492,11 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> UnitId
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger unit cfg index = do
{-
Plan.
@@ -1542,15 +1552,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> readDatabases index logger unit cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1562,15 +1566,20 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
-- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
+ | otherwise = initial_dbs
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1675,6 +1684,9 @@ mkUnitState logger cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db unusable
+
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
]
@@ -1687,8 +1699,6 @@ mkUnitState logger cfg = do
req_ctx = mapUniqMap (Set.toList)
$ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
- --
-- Here we build up a set of the packages mentioned in -package
-- flags on the command line; these are called the "preload"
-- packages. we link these packages in eagerly. The preload set
@@ -1711,10 +1721,6 @@ mkUnitState logger cfg = do
$ closeUnitDeps pkg_db
$ zip (map toUnitId preload3) (repeat Nothing)
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
-
-- Force the result to avoid leaking input parameters
let !state = UnitState
{ preloadUnits = dep_preload
@@ -1722,8 +1728,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = Set.toList home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
- , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ , moduleNameProvidersMap
+ , pluginModuleNameProvidersMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1902,77 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ UnusableUnits ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ UnusableUnits ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +1980,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
@@ -1933,18 +2011,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -1960,19 +2044,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2119,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (moduleProviders query unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
home_units = unitEnv_keys initial_home_graph
+ ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b3f96b33c8de3009728fa7e9a5180…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b3f96b33c8de3009728fa7e9a5180…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-mwb] 3 commits: Abstract out parts of mkUnitState into a handler type
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
11 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb at Glasgow Haskell Compiler / GHC
Commits:
9a3cb396 by Torsten Schmits at 2025-12-11T17:25:48+01:00
Abstract out parts of mkUnitState into a handler type
- - - - -
37774e95 by Torsten Schmits at 2025-12-11T17:25:48+01:00
Abstract out module provider queries into a handler type
- - - - -
666a8c2e by Torsten Schmits at 2025-12-11T17:25:48+01:00
Use unit index for name printing
- - - - -
22 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
+import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
+ index <- hscUnitIndex <$> getSession
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
then do
-- additionally, set checked dflags so we don't lose fixes
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
+ ue_index <- hscUnitIndex <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
@@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_home_unit_graph = home_unit_graph
, ue_current_unit = ue_currentUnit old_unit_env
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -1474,7 +1478,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = 's'
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
ptc = initPromotionTickContext dflags
-- 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
@@ -459,6 +460,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -471,6 +473,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -430,6 +430,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -438,7 +439,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -453,6 +454,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -871,6 +873,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -883,7 +887,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
+hscUnitIndex :: HscEnv -> UnitIndex
+hscUnitIndex = ue_index . hsc_unit_env
+
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery hsc_env =
+ unitIndexQuery (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2573,9 +2573,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -187,12 +187,13 @@ depanalE excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -510,15 +511,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
@@ -2384,7 +2385,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -696,9 +696,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -337,7 +338,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -447,14 +449,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -479,6 +481,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: [UnitId]
hpt_deps = homeUnitDepends units
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
(loadSrcInterface (text "runTcInteractive") m
NotBoot mb_pkg)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphans (unLoc (ideclName i)) qual
; let imports = emptyImportAvails { imp_orphs = orphs }
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -869,7 +869,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -68,11 +68,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +206,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +218,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -67,7 +67,7 @@ import Control.Monad
import Data.Time
import qualified Data.Map as M
import GHC.Driver.Env
- ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
@@ -161,17 +161,19 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery hsc_env
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
@@ -193,7 +195,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -204,11 +206,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_units ue
@@ -221,13 +223,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModule fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModule fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -283,15 +285,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -218,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -577,10 +585,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +646,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1484,9 +1492,11 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> UnitId
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger unit cfg index = do
{-
Plan.
@@ -1542,15 +1552,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> readDatabases index logger unit cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1562,15 +1566,20 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
-- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
+ | otherwise = initial_dbs
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1675,6 +1684,9 @@ mkUnitState logger cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db unusable
+
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
]
@@ -1687,8 +1699,6 @@ mkUnitState logger cfg = do
req_ctx = mapUniqMap (Set.toList)
$ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
- --
-- Here we build up a set of the packages mentioned in -package
-- flags on the command line; these are called the "preload"
-- packages. we link these packages in eagerly. The preload set
@@ -1711,10 +1721,6 @@ mkUnitState logger cfg = do
$ closeUnitDeps pkg_db
$ zip (map toUnitId preload3) (repeat Nothing)
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
-
-- Force the result to avoid leaking input parameters
let !state = UnitState
{ preloadUnits = dep_preload
@@ -1722,8 +1728,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = Set.toList home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
- , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ , moduleNameProvidersMap
+ , pluginModuleNameProvidersMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1902,77 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ UnusableUnits ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ UnusableUnits ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +1980,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
@@ -1933,18 +2011,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -1960,19 +2044,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2119,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (moduleProviders query unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
home_units = unitEnv_keys initial_home_graph
+ ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1e33ec406dd0266444f03073e8b48…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1e33ec406dd0266444f03073e8b48…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-26636] 20 commits: Add support for building bytecode libraries
by recursion-ninja (＠recursion-ninja) 11 Dec '25
by recursion-ninja (＠recursion-ninja) 11 Dec '25
11 Dec '25
recursion-ninja pushed to branch wip/fix-26636 at Glasgow Haskell Compiler / GHC
Commits:
e36a5fcb by Matthew Pickering at 2025-12-05T16:25:57-05:00
Add support for building bytecode libraries
A bytecode library is a collection of bytecode files (.gbc) and a
library which combines together additional object files.
A bytecode library is created by invoking GHC with the `-bytecodelib`
flag.
A library can be created from in-memory `ModuleByteCode` linkables or
by passing `.gbc` files as arguments on the command line.
Fixes #26298
- - - - -
8f9ae339 by Matthew Pickering at 2025-12-05T16:25:57-05:00
Load bytecode libraries to satisfy package dependencies
This commit allows you to use a bytecode library to satisfy a package
dependency when using the interpreter.
If a user enables `-fprefer-byte-code`, then if a package provides a
bytecode library, that will be loaded and used to satisfy the
dependency.
The main change is to separate the relevant parts of the `LoaderState`
into external and home package byte code. Bytecode is loaded into either
the home package or external part (similar to HPT/EPS split), HPT
bytecode can be unloaded. External bytecode is never unloaded.
The unload function has also only been called with an empty list of
"stable linkables" for a long time. It has been modified to directly
implement a complete unloading of the home package bytecode linkables.
At the moment, the bytecode libraries are found in the "library-dirs"
field from the package description. In the future when `Cabal`
implements support for "bytecode-library-dirs" field, we can read the
bytecode libraries from there. No changes to the Cabal submodule are
necessary at the moment.
Four new tests are added in testsuite/tests/cabal, which generate fake
package descriptions and test loading the libraries into GHCi.
Fixes #26298
- - - - -
54458ce4 by mangoiv at 2025-12-05T16:26:50-05:00
ExplicitLevelImports: improve documentation of the code
- more explicit names for variable names like `flg` or `topLevel`
- don't pass the same value twice to functions
- some explanations of interesting but undocumented code paths
- adjust comment to not mention non-existent error message
- - - - -
c7061392 by mangoiv at 2025-12-05T16:27:42-05:00
driver: don't expect nodes to exist when checking paths between them
In `mgQueryZero`, previously node lookups were expected to never fail,
i.e. it was expected that when calculating the path between two nodes in
a zero level import graph, both nodes would always exist. This is not
the case, e.g. in some situations involving exact names (see the
test-case). The fix is to first check whether the node is present in the
graph at all, instead of panicking, just to report that there is no
path.
Closes #26568
- - - - -
d6cf8463 by Peng Fan at 2025-12-06T11:06:28-05:00
NCG/LA64: Simplify genCCall into two parts
genCCall is too long, so it's been simplified into two parts:
genPrim and genLibCCall.
Suggested by Andreas Klebinger
- - - - -
9d371d23 by Matthew Pickering at 2025-12-06T11:07:09-05:00
hadrian: Use a response file to invoke GHC for dep gathering.
In some cases we construct an argument list too long for GHC to
handle directly on windows. This happens when we generate
the dependency file because the command line will contain
references to a large number of .hs files.
To avoid this we now invoke GHC using a response file when
generating dependencies to sidestep length limitations.
Note that we only pass the actual file names in the dependency
file. Why? Because this side-steps #26560
- - - - -
0043bfb0 by Marc Scholten at 2025-12-06T11:08:03-05:00
update xhtml to 3000.4.0.0
haddock-api: bump xhtml bounds
haddock-api: use lazy text instead of string to support xhtml 3000.4.0.0
Bumping submodule xhtml to 3000.4.0.0
add xhtml to stage0Packages
remove unused import of writeUtf8File
Remove redundant import
Update haddock golden files for xhtml 3000.4.0.0
Metric Decrease:
haddock.Cabal
haddock.base
- - - - -
fc958fc9 by Julian Ospald at 2025-12-06T11:08:53-05:00
rts: Fix object file format detection in loadArchive
Commit 76d1041dfa4b96108cfdd22b07f2b3feb424dcbe seems to
have introduced this bug, ultimately leading to failure of
test T11788. I can only theorize that this test isn't run
in upstream's CI, because they don't build a static GHC.
The culprit is that we go through the thin archive, trying
to follow the members on the filesystem, but don't
re-identify the new object format of the member. This pins
`object_fmt` to `NotObject` from the thin archive.
Thanks to @angerman for spotting this.
- - - - -
0f297f6e by mangoiv at 2025-12-06T11:09:44-05:00
users' guide: don't use f strings in the python script to ensure compatibility with python 3.5
- - - - -
3bfe7aa2 by Matthew Pickering at 2025-12-07T12:18:57-05:00
ci: Try using multi repl in ghc-in-ghci test
This should be quite a bit faster than the ./hadrian/ghci command as it
doesn't properly build all the dependencies.
- - - - -
2ef1601a by Rodrigo Mesquita at 2025-12-07T12:19:38-05:00
Stack.Decode: Don't error on bitmap size 0
A RET_BCO may have a bitmap with no payload.
In that case, the bitmap = 0.
One can observe this by using -ddump-bcos and interpreting
```
main = pure ()
```
Observe, for instance, that the BCO for this main function has size 0:
```
ProtoBCO Main.main#0:
\u []
break<main:Main,0>() GHC.Internal.Base.pure
GHC.Internal.Base.$fApplicativeIO GHC.Internal.Tuple.()
bitmap: 0 []
BRK_FUN <breakarray> main:Main 0 <cc>
PACK () 0
PUSH_G GHC.Internal.Base.$fApplicativeIO
PUSH_APPLY_PP
PUSH_G GHC.Internal.Base.pure
ENTER
```
Perhaps we never tried to decode a stack in which a BCO like this was
present. However, for the debugger, we want to decode stacks of threads
stopped at breakpoints, and these kind of BCOs do get on a stack under
e.g. `stg_apply_interp_info` frames.
See the accompanying test in the next commit for an example to trigger
the bug this commit fixes.
Fixes #26640
- - - - -
747153d2 by Rodrigo Mesquita at 2025-12-07T12:19:38-05:00
Add test for #26640
- - - - -
d4b1e353 by Simon Hengel at 2025-12-10T00:00:02-05:00
Fix syntax error in gadt_syntax.rst
- - - - -
91cc8be6 by Cheng Shao at 2025-12-10T00:00:43-05:00
ci: fix "ci.sh clean" to address frequent out of space error on windows runners
This patch fixes the `ci.sh clean` logic to address frequent out of
space error on windows runners; previously it didn't clean up the
inplace mingw blobs, which is the largest source of space leak on
windows runners. See added comment for detailed explanation.
- - - - -
fe2b79f4 by Recursion Ninja at 2025-12-10T08:34:18-05:00
Narrow before optimising MUL/DIV/REM into shifts
The MUL/DIV/REM operations can be optimised into shifts when one of the
operands is a constant power of 2. However, as literals in Cmm are
stored as 'Integer', for this to be correct we first need to narrow the
literal to the appropriate width before checking whether the literal is
a power of 2.
Fixes #25664
- - - - -
06c2349c by Recursion Ninja at 2025-12-10T08:34:58-05:00
Decouple 'Language.Haskell.Syntax.Type' from 'GHC.Utils.Panic'
- Remove the *original* defintion of 'hsQTvExplicit' defined within 'Language.Haskell.Syntax.Type'
- Redefine 'hsQTvExplicit' as 'hsq_explicit' specialized to 'GhcPass' exported by 'GHC.Utils.Panic'
- Define 'hsQTvExplicitBinders' as 'hsq_explicit' specialized to 'DocNameI' exported by 'Haddock.GhcUtils'.
- Replace all call sites of the original 'hsQTvExplicit' definition with either:
1. 'hsQTvExplicit' updated definition
2. 'hsQTvExplicitBinders'
All call sites never entered the 'XLHsQTyVars' constructor branch, but a call to 'panic' existed on this code path because the type system was not strong enought to guarantee that the 'XLHsQTyVars' construction was impossible.
These two specialized functions provide the type system with enough information to make that guarantee, and hence the dependancy on 'panic' can be removed.
- - - - -
ac0815d5 by sheaf at 2025-12-10T23:39:57-05:00
Quantify arg before mult in function arrows
As noted in #23764, we expect quantification order to be left-to-right,
so that in a type such as
a %m -> b
the inferred quantification order should be [a, m, b] and not [m, a, b].
This was addressed in commit d31fbf6c, but that commit failed to update
some other functions such as GHC.Core.TyCo.FVs.tyCoFVsOfType.
This affects Haddock, as whether we print an explicit forall or not
depends on whether the inferred quantification order matches the actual
quantification order.
- - - - -
2caf796e by sheaf at 2025-12-10T23:39:57-05:00
Haddock: improvements to ty-var quantification
This commit makes several improvements to how Haddock deals with the
quantification of type variables:
1. In pattern synonyms, Haddock used to jumble up universal and
existential quantification. That is now fixed, fixing #26252.
Tested in the 'PatternSyns2' haddock-html test.
2. The logic for computing whether to use an explicit kind annotation
for a type variable quantified in a forall was not even wrong.
This commit improves the heuristic, but it will always remain an
imperfect heuristic (lest we actually run kind inference again).
In the future (#26271), we hope to avoid reliance on this heuristic.
- - - - -
b14bdd59 by Teo Camarasu at 2025-12-10T23:40:38-05:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
1917b72b by Recursion Ninja at 2025-12-11T11:00:30-05:00
'Decouple Language.Haskell.Syntax.Decls' from 'GHC.Unit.Module.Warnings'
- - - - -
145 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Warnings.hs
- + compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Parser.y
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/DefaultEnv.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/Warnings.hs
- compiler/GHC/Unit/State.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Type.hs
- compiler/ghc.cabal.in
- docs/users_guide/conf.py
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/phases.rst
- hadrian/src/Builder.hs
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- libraries/base/src/GHC/Num.hs
- libraries/ghc-boot/GHC/Unit/Database.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/xhtml
- rts/linker/LoadArchive.c
- testsuite/config/ghc
- testsuite/mk/boilerplate.mk
- + testsuite/tests/bytecode/T26640.hs
- + testsuite/tests/bytecode/T26640.script
- + testsuite/tests/bytecode/T26640.stdout
- testsuite/tests/bytecode/all.T
- + testsuite/tests/cabal/Bytecode.hs
- + testsuite/tests/cabal/BytecodeForeign.c
- + testsuite/tests/cabal/BytecodeForeign.hs
- testsuite/tests/cabal/Makefile
- testsuite/tests/cabal/all.T
- + testsuite/tests/cabal/bytecode.pkg
- + testsuite/tests/cabal/bytecode.script
- + testsuite/tests/cabal/bytecode_foreign.pkg
- + testsuite/tests/cabal/bytecode_foreign.script
- testsuite/tests/cabal/ghcpkg03.stderr
- testsuite/tests/cabal/ghcpkg03.stderr-mingw32
- testsuite/tests/cabal/ghcpkg05.stderr
- testsuite/tests/cabal/ghcpkg05.stderr-mingw32
- + testsuite/tests/cabal/pkg_bytecode.stderr
- + testsuite/tests/cabal/pkg_bytecode.stdout
- + testsuite/tests/cabal/pkg_bytecode_foreign.stderr
- + testsuite/tests/cabal/pkg_bytecode_foreign.stdout
- + testsuite/tests/cabal/pkg_bytecode_with_gbc.stderr
- + testsuite/tests/cabal/pkg_bytecode_with_gbc.stdout
- + testsuite/tests/cabal/pkg_bytecode_with_o.stderr
- + testsuite/tests/cabal/pkg_bytecode_with_o.stdout
- + testsuite/tests/cmm/opt/T25664.hs
- + testsuite/tests/cmm/opt/T25664.stdout
- testsuite/tests/cmm/opt/all.T
- testsuite/tests/driver/bytecode-object/Makefile
- testsuite/tests/driver/bytecode-object/all.T
- testsuite/tests/driver/bytecode-object/bytecode_object19.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object20.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object21.stderr
- + testsuite/tests/driver/bytecode-object/bytecode_object21.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object23.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object24.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + testsuite/tests/th/T26568.hs
- + testsuite/tests/th/T26568.stderr
- testsuite/tests/th/all.T
- utils/ghc-pkg/Main.hs
- utils/haddock/cabal.project
- utils/haddock/haddock-api/haddock-api.cabal
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Doc.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Utils.hs
- utils/haddock/html-test/ref/Bug1050.html
- utils/haddock/html-test/ref/Bug26.html
- utils/haddock/html-test/ref/Bug298.html
- utils/haddock/html-test/ref/Bug458.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/Nesting.html
- utils/haddock/html-test/ref/PatternSyns.html
- + utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/TitledPicture.html
- utils/haddock/html-test/ref/TypeOperators.html
- utils/haddock/html-test/ref/Unicode.html
- utils/haddock/html-test/ref/Unicode2.html
- + utils/haddock/html-test/src/PatternSyns2.hs
- utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e8d1355174a1bac067b333365a338e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e8d1355174a1bac067b333365a338e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-mwb] 3 commits: Abstract out parts of mkUnitState into a handler type
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
11 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb at Glasgow Haskell Compiler / GHC
Commits:
7d14c51a by Torsten Schmits at 2025-12-11T16:45:10+01:00
Abstract out parts of mkUnitState into a handler type
- - - - -
1f3cd5da by Torsten Schmits at 2025-12-11T16:45:10+01:00
Abstract out module provider queries into a handler type
- - - - -
c1e33ec4 by Torsten Schmits at 2025-12-11T16:45:10+01:00
Use unit index for name printing
- - - - -
22 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
+import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
+ index <- hscUnitIndex <$> getSession
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
then do
-- additionally, set checked dflags so we don't lose fixes
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
+ ue_index <- hscUnitIndex <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
@@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_home_unit_graph = home_unit_graph
, ue_current_unit = ue_currentUnit old_unit_env
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -1474,7 +1478,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = 's'
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
ptc = initPromotionTickContext dflags
-- 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
@@ -459,6 +460,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -471,6 +473,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -430,6 +430,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -438,7 +439,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -453,6 +454,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -871,6 +873,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -883,7 +887,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
+hscUnitIndex :: HscEnv -> UnitIndex
+hscUnitIndex = ue_index . hsc_unit_env
+
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery hsc_env =
+ unitIndexQuery (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2573,9 +2573,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -187,12 +187,13 @@ depanalE excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -510,15 +511,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
@@ -2384,7 +2385,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -696,9 +696,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -337,7 +338,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -447,14 +449,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -479,6 +481,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: [UnitId]
hpt_deps = homeUnitDepends units
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
(loadSrcInterface (text "runTcInteractive") m
NotBoot mb_pkg)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphans (unLoc (ideclName i)) qual
; let imports = emptyImportAvails { imp_orphs = orphs }
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -869,7 +869,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -68,11 +68,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +206,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +218,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -67,7 +67,7 @@ import Control.Monad
import Data.Time
import qualified Data.Map as M
import GHC.Driver.Env
- ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
@@ -161,17 +161,19 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery hsc_env
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
@@ -193,7 +195,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -204,11 +206,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_units ue
@@ -221,13 +223,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModule fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModule fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -283,15 +285,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -218,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -577,10 +585,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +646,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1484,9 +1492,11 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> UnitId
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger unit cfg index = do
{-
Plan.
@@ -1542,15 +1552,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> readDatabases index logger unit cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1562,15 +1566,20 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
-- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (pkg_map_valid, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> pkg_map_valid
+ | otherwise = pkg_map_valid
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1711,9 +1720,8 @@ mkUnitState logger cfg = do
$ closeUnitDeps pkg_db
$ zip (map toUnitId preload3) (repeat Nothing)
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map pkg_db unusable
-- Force the result to avoid leaking input parameters
let !state = UnitState
@@ -1722,8 +1730,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = Set.toList home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
- , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ , moduleNameProvidersMap
+ , pluginModuleNameProvidersMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1904,75 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnusableUnits ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnusableUnits ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +1980,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
@@ -1933,18 +2011,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -1960,19 +2044,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2119,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (moduleProviders query unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
home_units = unitEnv_keys initial_home_graph
+ ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fadc5ae95430dcfd33c3bff142563f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fadc5ae95430dcfd33c3bff142563f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-mwb-25-07] 2 commits: Abstract out module provider queries into a handler type
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
11 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb-25-07 at Glasgow Haskell Compiler / GHC
Commits:
9c0b67f4 by Torsten Schmits at 2025-12-11T13:41:49+01:00
Abstract out module provider queries into a handler type
- - - - -
2b3f96b3 by Torsten Schmits at 2025-12-11T13:42:00+01:00
Use unit index for name printing
- - - - -
21 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
+import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -1382,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -1477,7 +1478,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -1714,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1741,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = 's'
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
ptc = initPromotionTickContext dflags
-- 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
@@ -459,6 +460,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -471,6 +473,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -872,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -884,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -8,6 +8,7 @@ module GHC.Driver.Env
, hsc_home_unit_maybe
, hsc_units
, hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -122,6 +123,10 @@ hsc_units = ue_units . hsc_unit_env
hscUnitIndex :: HscEnv -> UnitIndex
hscUnitIndex = ue_index . hsc_unit_env
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery hsc_env =
+ unitIndexQuery (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -188,12 +188,13 @@ depanalE excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -511,15 +512,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
@@ -2386,7 +2387,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -337,7 +338,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -447,14 +449,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -479,6 +481,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: [UnitId]
hpt_deps = homeUnitDepends units
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
(loadSrcInterface (text "runTcInteractive") m
NotBoot mb_pkg)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphans n NoPkgQual
- IIDecl i -> getOrphans (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphans (unLoc (ideclName i)) qual
; let imports = emptyImportAvails { imp_orphs = orphs }
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -869,7 +869,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -68,11 +68,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +206,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +218,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -67,7 +67,7 @@ import Control.Monad
import Data.Time
import qualified Data.Map as M
import GHC.Driver.Env
- ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,17 +162,19 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery hsc_env
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
@@ -194,7 +196,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -205,11 +207,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_units ue
@@ -222,13 +224,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModule fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModule fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -284,15 +286,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -49,7 +49,12 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
newUnitIndex,
-- * Module hole substitution
@@ -221,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -580,10 +585,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -1902,8 +1907,15 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- -----------------------------------------------------------------------------
-- Index
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
data UnitIndex =
UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
computeProviders ::
Logger ->
@@ -1916,6 +1928,23 @@ data UnitIndex =
IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
}
+queryFindOriginDefault ::
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
readDatabasesDefault logger _ cfg =
readUnitDatabases logger cfg
@@ -1938,8 +1967,9 @@ computeProvidersDefault logger _ cfg vis_map plugin_vis_map pkg_db unusable =
plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
newUnitIndex :: IO UnitIndex
-newUnitIndex = do
+newUnitIndex =
pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
readDatabases = readDatabasesDefault,
computeProviders = computeProvidersDefault
}
@@ -1950,10 +1980,11 @@ newUnitIndex = do
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
@@ -1980,18 +2011,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -2007,19 +2044,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2080,16 +2119,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (moduleProviders query unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46fe32bc7cb5132f96cceca194d3cb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46fe32bc7cb5132f96cceca194d3cb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ubsan] 13 commits: Fix syntax error in gadt_syntax.rst
by Cheng Shao (＠TerrorJack) 11 Dec '25
by Cheng Shao (＠TerrorJack) 11 Dec '25
11 Dec '25
Cheng Shao pushed to branch wip/ubsan at Glasgow Haskell Compiler / GHC
Commits:
d4b1e353 by Simon Hengel at 2025-12-10T00:00:02-05:00
Fix syntax error in gadt_syntax.rst
- - - - -
91cc8be6 by Cheng Shao at 2025-12-10T00:00:43-05:00
ci: fix "ci.sh clean" to address frequent out of space error on windows runners
This patch fixes the `ci.sh clean` logic to address frequent out of
space error on windows runners; previously it didn't clean up the
inplace mingw blobs, which is the largest source of space leak on
windows runners. See added comment for detailed explanation.
- - - - -
fe2b79f4 by Recursion Ninja at 2025-12-10T08:34:18-05:00
Narrow before optimising MUL/DIV/REM into shifts
The MUL/DIV/REM operations can be optimised into shifts when one of the
operands is a constant power of 2. However, as literals in Cmm are
stored as 'Integer', for this to be correct we first need to narrow the
literal to the appropriate width before checking whether the literal is
a power of 2.
Fixes #25664
- - - - -
06c2349c by Recursion Ninja at 2025-12-10T08:34:58-05:00
Decouple 'Language.Haskell.Syntax.Type' from 'GHC.Utils.Panic'
- Remove the *original* defintion of 'hsQTvExplicit' defined within 'Language.Haskell.Syntax.Type'
- Redefine 'hsQTvExplicit' as 'hsq_explicit' specialized to 'GhcPass' exported by 'GHC.Utils.Panic'
- Define 'hsQTvExplicitBinders' as 'hsq_explicit' specialized to 'DocNameI' exported by 'Haddock.GhcUtils'.
- Replace all call sites of the original 'hsQTvExplicit' definition with either:
1. 'hsQTvExplicit' updated definition
2. 'hsQTvExplicitBinders'
All call sites never entered the 'XLHsQTyVars' constructor branch, but a call to 'panic' existed on this code path because the type system was not strong enought to guarantee that the 'XLHsQTyVars' construction was impossible.
These two specialized functions provide the type system with enough information to make that guarantee, and hence the dependancy on 'panic' can be removed.
- - - - -
ac0815d5 by sheaf at 2025-12-10T23:39:57-05:00
Quantify arg before mult in function arrows
As noted in #23764, we expect quantification order to be left-to-right,
so that in a type such as
a %m -> b
the inferred quantification order should be [a, m, b] and not [m, a, b].
This was addressed in commit d31fbf6c, but that commit failed to update
some other functions such as GHC.Core.TyCo.FVs.tyCoFVsOfType.
This affects Haddock, as whether we print an explicit forall or not
depends on whether the inferred quantification order matches the actual
quantification order.
- - - - -
2caf796e by sheaf at 2025-12-10T23:39:57-05:00
Haddock: improvements to ty-var quantification
This commit makes several improvements to how Haddock deals with the
quantification of type variables:
1. In pattern synonyms, Haddock used to jumble up universal and
existential quantification. That is now fixed, fixing #26252.
Tested in the 'PatternSyns2' haddock-html test.
2. The logic for computing whether to use an explicit kind annotation
for a type variable quantified in a forall was not even wrong.
This commit improves the heuristic, but it will always remain an
imperfect heuristic (lest we actually run kind inference again).
In the future (#26271), we hope to avoid reliance on this heuristic.
- - - - -
b14bdd59 by Teo Camarasu at 2025-12-10T23:40:38-05:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
64553a1c by Cheng Shao at 2025-12-11T15:10:41+01:00
configure: bump LlvmMaxVersion to 22
This commit bumps LlvmMaxVersion to 22; 21.x releases have been
available since Aug 26th, 2025 and there's no regressions with 21.x so
far. This bump is also required for updating fedora image to 43.
- - - - -
c89f17c6 by Cheng Shao at 2025-12-11T16:17:07+01:00
hadrian: add support for building with UndefinedBehaviorSanitizer
This patch adds a +ubsan flavour transformer to hadrian to build all
stage1+ C/C++ code with UndefinedBehaviorSanitizer. This is
particularly useful to catch potential undefined behavior in the RTS
codebase.
- - - - -
97b60f92 by Cheng Shao at 2025-12-11T16:17:11+01:00
ci: update alpine/fedora & add ubsan job
This patch updates alpine image to 3.23, fedora image to 43, and adds
a `x86_64-linux-fedora43-validate+debug_info+ubsan` job that's run in
validate/nightly pipelines to catch undefined behavior in the RTS
codebase.
- - - - -
b65422e6 by Cheng Shao at 2025-12-11T16:17:11+01:00
rts: fix zero-length VLA undefined behavior in interpretBCO
This commit fixes a zero-length VLA undefined behavior in interpretBCO, caught by UBSan:
```
+rts/Interpreter.c:3133:19: runtime variable length array bound evaluates to non-positive value 0
```
- - - - -
993054b2 by Cheng Shao at 2025-12-11T16:17:11+01:00
rts: fix unaligned ReadSpB in interpretBCO
This commit fixes unaligned ReadSpB in interpretBCO, caught by UBSan:
```
+rts/Interpreter.c:2174:64: runtime load of misaligned address 0x004202059dd1 for type 'StgWord', which requires 8 byte alignment
```
To perform proper unaligned read, we define StgUnalignedWord as a type
alias of StgWord with aligned(1) attribute, and load StgUnalignedWord
instead of StgWord in ReadSpB, so the C compiler is aware that we're
not loading with natural alignment.
- - - - -
8870995f by Cheng Shao at 2025-12-11T16:17:11+01:00
rts: fix signed integer overflow in subword arithmetic in interpretBCO
This commit fixes signed integer overflow in subword arithmetic in
interpretBCO, see added note for detailed explanation.
- - - - -
42 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/Language/Haskell/Syntax/Type.hs
- configure.ac
- docs/users_guide/exts/gadt_syntax.rst
- hadrian/doc/flavours.md
- hadrian/src/Flavour.hs
- libraries/base/src/GHC/Num.hs
- + rts/.ubsan-suppressions
- rts/Interpreter.c
- rts/include/stg/Types.h
- rts/rts.cabal
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- + testsuite/tests/cmm/opt/T25664.hs
- + testsuite/tests/cmm/opt/T25664.stdout
- testsuite/tests/cmm/opt/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/html-test/ref/Bug1050.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/PatternSyns.html
- + utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/TypeOperators.html
- + utils/haddock/html-test/src/PatternSyns2.hs
- utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b59a2e2866821f617c3924f4ff4b84…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b59a2e2866821f617c3924f4ff4b84…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ci-note-treeless] 4 commits: Quantify arg before mult in function arrows
by Cheng Shao (＠TerrorJack) 11 Dec '25
by Cheng Shao (＠TerrorJack) 11 Dec '25
11 Dec '25
Cheng Shao pushed to branch wip/ci-note-treeless at Glasgow Haskell Compiler / GHC
Commits:
ac0815d5 by sheaf at 2025-12-10T23:39:57-05:00
Quantify arg before mult in function arrows
As noted in #23764, we expect quantification order to be left-to-right,
so that in a type such as
a %m -> b
the inferred quantification order should be [a, m, b] and not [m, a, b].
This was addressed in commit d31fbf6c, but that commit failed to update
some other functions such as GHC.Core.TyCo.FVs.tyCoFVsOfType.
This affects Haddock, as whether we print an explicit forall or not
depends on whether the inferred quantification order matches the actual
quantification order.
- - - - -
2caf796e by sheaf at 2025-12-10T23:39:57-05:00
Haddock: improvements to ty-var quantification
This commit makes several improvements to how Haddock deals with the
quantification of type variables:
1. In pattern synonyms, Haddock used to jumble up universal and
existential quantification. That is now fixed, fixing #26252.
Tested in the 'PatternSyns2' haddock-html test.
2. The logic for computing whether to use an explicit kind annotation
for a type variable quantified in a forall was not even wrong.
This commit improves the heuristic, but it will always remain an
imperfect heuristic (lest we actually run kind inference again).
In the future (#26271), we hope to avoid reliance on this heuristic.
- - - - -
b14bdd59 by Teo Camarasu at 2025-12-10T23:40:38-05:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
505caf1d by Cheng Shao at 2025-12-11T15:52:43+01:00
ci: use treeless fetch for perf notes
This patch improves the ci logic for fetching perf notes by using
treeless fetch
(https://github.blog/open-source/git/get-up-to-speed-with-partial-clone-and-…)
to avoid downloading all blobs of the perf notes repo at once, and
only fetch the actually required blobs on-demand when needed. This
makes the initial `test-metrics.sh pull` operation much faster, and
also more robust, since we are seeing an increasing rate of 504 errors
in CI when fetching all perf notes at once, which is a major source of
CI flakiness at this point.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
19 changed files:
- .gitlab/test-metrics.sh
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- libraries/base/src/GHC/Num.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/html-test/ref/Bug1050.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/PatternSyns.html
- + utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/TypeOperators.html
- + utils/haddock/html-test/src/PatternSyns2.hs
- utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
Changes:
=====================================
.gitlab/test-metrics.sh
=====================================
@@ -17,12 +17,14 @@ fail() {
function pull() {
local ref="refs/notes/$REF"
- # 2023-10-04: `git fetch` started failing, first on Darwin in CI and then on
- # Linux locally, both using git version 2.40.1. See #24055. One workaround is
- # to set a larger http.postBuffer, although this is definitely a workaround.
- # The default should work just fine. The error could be in git, GitLab, or
- # perhaps the networking tube (including all proxies etc) between the two.
- run git -c http.postBuffer=2097152 fetch -f "$NOTES_ORIGIN" "$ref:$ref"
+
+ # Fetch performance notes from a dedicated promisor remote using a
+ # treeless filter, so that individual note blobs are fetched lazily
+ # as needed.
+ git remote add perf-notes "$NOTES_ORIGIN" || true
+ git config fetch.recurseSubmodules false
+ git config remote.perf-notes.partialclonefilter tree:0
+ run git fetch --force perf-notes "$ref:$ref"
echo "perf notes ref $ref is $(git rev-parse $ref)"
}
@@ -81,4 +83,3 @@ case $1 in
pull) pull ;;
*) fail "Invalid mode $1" ;;
esac
-
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -635,7 +635,9 @@ tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_v
-- See Note [Free vars and synonyms]
tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc
tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc
-tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc
+tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc =
+ -- As per #23764, if we have 'a %m -> b', quantification order should be [a,m,b] not [m,a,b].
+ (tyCoFVsOfType arg `unionFV` tyCoFVsOfType w `unionFV` tyCoFVsOfType res) f bound_vars acc
tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc
tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc
tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc
@@ -958,7 +960,9 @@ invisibleVarsOfType = go
= go ty'
go (TyVarTy v) = go (tyVarKind v)
go (AppTy f a) = go f `unionFV` go a
- go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2
+ go (FunTy _ w ty1 ty2) =
+ -- As per #23764, order is: arg, mult, res.
+ go ty1 `unionFV` go w `unionFV` go ty2
go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV`
invisibleVarsOfTypes visibles
where (invisibles, visibles) = partitionInvisibleTypes tc tys
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1984,7 +1984,9 @@ foldTyCo (TyCoFolder { tcf_view = view
go_ty _ (LitTy {}) = mempty
go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co
go_ty env (CoercionTy co) = go_co env co
- go_ty env (FunTy _ w arg res) = go_ty env w `mappend` go_ty env arg `mappend` go_ty env res
+ go_ty env (FunTy _ w arg res) =
+ -- As per #23764, ordering is [arg, w, res].
+ go_ty env arg `mappend` go_ty env w `mappend` go_ty env res
go_ty env (TyConApp _ tys) = go_tys env tys
go_ty env (ForAllTy (Bndr tv vis) inner)
= let !env' = tycobinder env tv vis -- Avoid building a thunk here
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1432,7 +1432,7 @@ collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty
-- Uses accumulating-parameter style
go dv (AppTy t1 t2) = foldlM go dv [t1, t2]
go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys
- go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res]
+ go dv (FunTy _ w arg res) = foldlM go dv [arg, w, res]
go dv (LitTy {}) = return dv
go dv (CastTy ty co) = do { dv1 <- go dv ty
; collect_cand_qtvs_co orig_ty cur_lvl bound dv1 co }
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -1009,8 +1009,8 @@ tcTyFamInstsAndVisX = go
go _ (LitTy {}) = []
go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr)
++ go is_invis_arg ty
- go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg w
- ++ go is_invis_arg ty1
+ go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg ty1
+ ++ go is_invis_arg w
++ go is_invis_arg ty2
go is_invis_arg ty@(AppTy _ _) =
let (ty_head, ty_args) = splitAppTys ty
=====================================
libraries/base/src/GHC/Num.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
@@ -16,11 +17,190 @@ module GHC.Num
( Num(..)
, subtract
, quotRemInteger
- , module GHC.Num.Integer
- , module GHC.Num.Natural
+ , integerFromNatural
+ , integerToNaturalClamp
+ , integerToNaturalThrow
+ , integerToNatural
+ , integerToWord#
+ , integerToInt#
+ , integerToWord64#
+ , integerToInt64#
+ , integerAdd
+ , integerMul
+ , integerSub
+ , integerNegate
+ , integerAbs
+ , integerPopCount#
+ , integerQuot
+ , integerRem
+ , integerDiv
+ , integerMod
+ , integerDivMod#
+ , integerQuotRem#
+ , integerEncodeFloat#
+ , integerEncodeDouble#
+ , integerGcd
+ , integerLcm
+ , integerAnd
+ , integerOr
+ , integerXor
+ , integerComplement
+ , integerBit#
+ , integerTestBit#
+ , integerShiftL#
+ , integerShiftR#
+ , integerFromWord#
+ , integerFromWord64#
+ , integerFromInt64#
+ , Integer(..)
+ , integerBit
+ , integerCheck
+ , integerCheck#
+ , integerCompare
+ , integerDecodeDouble#
+ , integerDivMod
+ , integerEncodeDouble
+ , integerEq
+ , integerEq#
+ , integerFromAddr
+ , integerFromAddr#
+ , integerFromBigNat#
+ , integerFromBigNatNeg#
+ , integerFromBigNatSign#
+ , integerFromByteArray
+ , integerFromByteArray#
+ , integerFromInt
+ , integerFromInt#
+ , integerFromWord
+ , integerFromWordList
+ , integerFromWordNeg#
+ , integerFromWordSign#
+ , integerGcde
+ , integerGcde#
+ , integerGe
+ , integerGe#
+ , integerGt
+ , integerGt#
+ , integerIsNegative
+ , integerIsNegative#
+ , integerIsOne
+ , integerIsPowerOf2#
+ , integerIsZero
+ , integerLe
+ , integerLe#
+ , integerLog2
+ , integerLog2#
+ , integerLogBase
+ , integerLogBase#
+ , integerLogBaseWord
+ , integerLogBaseWord#
+ , integerLt
+ , integerLt#
+ , integerNe
+ , integerNe#
+ , integerOne
+ , integerPowMod#
+ , integerQuotRem
+ , integerRecipMod#
+ , integerShiftL
+ , integerShiftR
+ , integerSignum
+ , integerSignum#
+ , integerSizeInBase#
+ , integerSqr
+ , integerTestBit
+ , integerToAddr
+ , integerToAddr#
+ , integerToBigNatClamp#
+ , integerToBigNatSign#
+ , integerToInt
+ , integerToMutableByteArray
+ , integerToMutableByteArray#
+ , integerToWord
+ , integerZero
+ , naturalToWord#
+ , naturalPopCount#
+ , naturalShiftR#
+ , naturalShiftL#
+ , naturalAdd
+ , naturalSub
+ , naturalSubThrow
+ , naturalSubUnsafe
+ , naturalMul
+ , naturalQuotRem#
+ , naturalQuot
+ , naturalRem
+ , naturalAnd
+ , naturalAndNot
+ , naturalOr
+ , naturalXor
+ , naturalTestBit#
+ , naturalBit#
+ , naturalGcd
+ , naturalLcm
+ , naturalLog2#
+ , naturalLogBaseWord#
+ , naturalLogBase#
+ , naturalPowMod
+ , naturalSizeInBase#
+ , Natural(..)
+ , naturalBit
+ , naturalCheck
+ , naturalCheck#
+ , naturalClearBit
+ , naturalClearBit#
+ , naturalCompare
+ , naturalComplementBit
+ , naturalComplementBit#
+ , naturalEncodeDouble#
+ , naturalEncodeFloat#
+ , naturalEq
+ , naturalEq#
+ , naturalFromAddr
+ , naturalFromAddr#
+ , naturalFromBigNat#
+ , naturalFromByteArray#
+ , naturalFromWord
+ , naturalFromWord#
+ , naturalFromWord2#
+ , naturalFromWordList
+ , naturalGe
+ , naturalGe#
+ , naturalGt
+ , naturalGt#
+ , naturalIsOne
+ , naturalIsPowerOf2#
+ , naturalIsZero
+ , naturalLe
+ , naturalLe#
+ , naturalLog2
+ , naturalLogBase
+ , naturalLogBaseWord
+ , naturalLt
+ , naturalLt#
+ , naturalNe
+ , naturalNe#
+ , naturalNegate
+ , naturalOne
+ , naturalPopCount
+ , naturalQuotRem
+ , naturalSetBit
+ , naturalSetBit#
+ , naturalShiftL
+ , naturalShiftR
+ , naturalSignum
+ , naturalSqr
+ , naturalTestBit
+ , naturalToAddr
+ , naturalToAddr#
+ , naturalToBigNat#
+ , naturalToMutableByteArray#
+ , naturalToWord
+ , naturalToWordClamp
+ , naturalToWordClamp#
+ , naturalToWordMaybe#
+ , naturalZero
)
where
import GHC.Internal.Num
-import GHC.Num.Integer
-import GHC.Num.Natural
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -11397,7 +11397,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -8569,7 +8569,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -29,7 +29,7 @@ module Haddock.Convert
import Control.DeepSeq (force)
import Data.Either (lefts, partitionEithers, rights)
-import Data.Maybe (catMaybes, mapMaybe, maybeToList)
+import Data.Maybe (catMaybes, mapMaybe)
import GHC.Builtin.Names
( boxedRepDataConKey
, eqTyConKey
@@ -140,7 +140,7 @@ tyThingToLHsDecl prr t = case t of
hsq_explicit $
fdTyVars fd
, feqn_fixity = fdFixity fd
- , feqn_rhs = synifyType WithinType [] rhs
+ , feqn_rhs = synifyType WithinType emptyVarSet rhs
}
extractAtItem
@@ -179,7 +179,7 @@ tyThingToLHsDecl prr t = case t of
noLocA (MinimalSig (noAnn, NoSourceText) . noLocA $ classMinimalDef cl)
: [ noLocA tcdSig
| clsOp <- classOpItems cl
- , tcdSig <- synifyTcIdSig vs clsOp
+ , tcdSig <- synifyTcIdSig (mkVarSet vs) clsOp
]
, tcdMeths = [] -- ignore default method definitions, they don't affect signature
-- class associated-types are a subset of TyCon:
@@ -213,9 +213,9 @@ synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn
synifyAxBranch tc (CoAxBranch{cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs}) =
let name = synifyNameN tc
args_types_only = filterOutInvisibleTypes tc args
- typats = map (synifyType WithinType []) args_types_only
+ typats = map (synifyType WithinType emptyVarSet) args_types_only
annot_typats = zipWith3 annotHsType args_poly args_types_only typats
- hs_rhs = synifyType WithinType [] rhs
+ hs_rhs = synifyType WithinType emptyVarSet rhs
outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs}
in -- TODO: this must change eventually
FamEqn
@@ -344,7 +344,7 @@ synifyTyCon _prr coax tc
, tcdLName = synifyNameN tc
, tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = synifyFixity tc
- , tcdRhs = synifyType WithinType [] ty
+ , tcdRhs = synifyType WithinType emptyVarSet ty
}
-- (closed) newtype and data
| otherwise = do
@@ -578,8 +578,8 @@ synifyDataCon use_gadt_syntax dc =
linear_tys =
zipWith
( \(Scaled mult ty) (HsSrcBang st unp str) ->
- let tySyn = synifyType WithinType [] ty
- multSyn = synifyMultRec [] mult
+ let tySyn = synifyType WithinType emptyVarSet ty
+ multSyn = synifyMultRec emptyVarSet mult
in CDF (noAnn, st) unp str multSyn tySyn Nothing
)
arg_tys
@@ -620,7 +620,7 @@ synifyDataCon use_gadt_syntax dc =
, con_inner_bndrs = inner_bndrs
, con_mb_cxt = ctx
, con_g_args = hat
- , con_res_ty = synifyType WithinType [] res_ty
+ , con_res_ty = synifyType WithinType emptyVarSet res_ty
, con_doc = Nothing
}
else do
@@ -657,11 +657,11 @@ synifyIdSig
-> SynifyTypeState
-- ^ what to do with a 'forall'
-> [TyVar]
- -- ^ free variables in the type to convert
+ -- ^ type variables bound from an outer scope
-> Id
-- ^ the 'Id' from which to get the type signature
-> Sig GhcRn
-synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t)
+synifyIdSig prr s boundTvs i = TypeSig noAnn [n] (synifySigWcType s boundTvs t)
where
!n = force $ synifyNameN i
t = defaultType prr (varType i)
@@ -669,18 +669,18 @@ synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t)
-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going
-- to contain the synified 'ClassOpSig' as well (when appropriate) a default
-- 'ClassOpSig'.
-synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn]
-synifyTcIdSig vs (i, dm) =
+synifyTcIdSig :: TyVarSet -> ClassOpItem -> [Sig GhcRn]
+synifyTcIdSig boundTvs (i, dm) =
[ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i))]
++ [ ClassOpSig noAnn True [noLocA dn] (defSig dt)
| Just (dn, GenericDM dt) <- [dm]
]
where
- mainSig t = synifySigType DeleteTopLevelQuantification vs t
- defSig t = synifySigType ImplicitizeForAll vs t
+ mainSig t = synifySigType DeleteTopLevelQuantification boundTvs t
+ defSig t = synifySigType ImplicitizeForAll boundTvs t
synifyCtx :: [PredType] -> LHsContext GhcRn
-synifyCtx ts = noLocA (map (synifyType WithinType []) ts)
+synifyCtx ts = noLocA (map (synifyType WithinType emptyVarSet) ts)
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
synifyTyVars ktvs =
@@ -699,7 +699,7 @@ synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv
-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind
--- signatures (even if they don't have the lifted type kind).
+-- signatures (even if they don't have kind 'Type').
synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
synify_ty_var no_kinds flag tv =
noLocA (HsTvb noAnn flag bndr_var bndr_kind)
@@ -726,7 +726,7 @@ annotHsType _ _ hs_ty@(L _ (HsKindSig{})) = hs_ty
annotHsType True ty hs_ty
| not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty =
let ki = typeKind ty
- hs_ki = synifyType WithinType [] ki
+ hs_ki = synifyType WithinType emptyVarSet ki
in noLocA (HsKindSig noAnn hs_ty hs_ki)
annotHsType _ _ hs_ty = hs_ty
@@ -768,14 +768,15 @@ data SynifyTypeState
-- the defining class gets to quantify all its functions for free!
DeleteTopLevelQuantification
-synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
+synifySigType :: SynifyTypeState -> TyVarSet -> Type -> LHsSigType GhcRn
-- The use of mkEmptySigType (which uses empty binders in OuterImplicit)
-- is a bit suspicious; what if the type has free variables?
-synifySigType s vs ty = mkEmptySigType (synifyType s vs ty)
+synifySigType s boundTvs ty = mkEmptySigType (synifyType s boundTvs ty)
synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
-- Ditto (see synifySigType)
-synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (rename (map getName vs) $ synifyType s vs ty))
+synifySigWcType s vs ty =
+ mkEmptyWildCardBndrs (mkEmptySigType (rename (map getName vs) $ synifyType s (mkVarSet vs) ty))
synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
-- Ditto (see synifySigType)
@@ -791,13 +792,13 @@ defaultType HideRuntimeRep = defaultRuntimeRepVars
synifyType
:: SynifyTypeState
-- ^ what to do with a 'forall'
- -> [TyVar]
- -- ^ free variables in the type to convert
+ -> TyVarSet
+ -- ^ bound type variables
-> Type
-- ^ the type to convert
-> LHsType GhcRn
synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (noUserRdr $ getName tv)
-synifyType _ vs (TyConApp tc tys) =
+synifyType _ boundTvs (TyConApp tc tys) =
maybe_sig res_ty
where
res_ty :: LHsType GhcRn
@@ -819,24 +820,24 @@ synifyType _ vs (TyConApp tc tys) =
ConstraintTuple -> HsBoxedOrConstraintTuple
UnboxedTuple -> HsUnboxedTuple
)
- (map (synifyType WithinType vs) vis_tys)
+ (map (synifyType WithinType boundTvs) vis_tys)
| isUnboxedSumTyCon tc =
- noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys)
+ noLocA $ HsSumTy noAnn (map (synifyType WithinType boundTvs) vis_tys)
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
, dataConSourceArity dc == length vis_tys =
- noLocA $ HsExplicitTupleTy noExtField IsPromoted (map (synifyType WithinType vs) vis_tys)
+ noLocA $ HsExplicitTupleTy noExtField IsPromoted (map (synifyType WithinType boundTvs) vis_tys)
-- ditto for lists
| getName tc == listTyConName
, [ty] <- vis_tys =
- noLocA $ HsListTy noAnn (synifyType WithinType vs ty)
+ noLocA $ HsListTy noAnn (synifyType WithinType boundTvs ty)
| tc == promotedNilDataCon
, [] <- vis_tys =
noLocA $ HsExplicitListTy noExtField IsPromoted []
| tc == promotedConsDataCon
, [ty1, ty2] <- vis_tys =
- let hTy = synifyType WithinType vs ty1
- in case synifyType WithinType vs ty2 of
+ let hTy = synifyType WithinType boundTvs ty1
+ in case synifyType WithinType boundTvs ty2 of
tTy
| L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy ->
noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')
@@ -846,7 +847,7 @@ synifyType _ vs (TyConApp tc tys) =
| tc `hasKey` ipClassKey
, [name, ty] <- tys
, Just x <- isStrLitTy name =
- noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty)
+ noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType boundTvs ty)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys =
@@ -854,9 +855,9 @@ synifyType _ vs (TyConApp tc tys) =
HsOpTy
noExtField
NotPromoted
- (synifyType WithinType vs ty1)
+ (synifyType WithinType boundTvs ty1)
(noLocA $ noUserRdr eqTyConName)
- (synifyType WithinType vs ty2)
+ (synifyType WithinType boundTvs ty2)
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1 : ty2 : tys_rest <- vis_tys =
@@ -864,9 +865,9 @@ synifyType _ vs (TyConApp tc tys) =
( HsOpTy
noExtField
prom
- (synifyType WithinType vs ty1)
+ (synifyType WithinType boundTvs ty1)
(noLocA $ noUserRdr $ getName tc)
- (synifyType WithinType vs ty2)
+ (synifyType WithinType boundTvs ty2)
)
tys_rest
-- Most TyCons:
@@ -880,7 +881,7 @@ synifyType _ vs (TyConApp tc tys) =
foldl
(\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2)
(noLocA ty_app)
- ( map (synifyType WithinType vs) $
+ ( map (synifyType WithinType boundTvs) $
filterOut isCoercionTy ty_args
)
@@ -891,56 +892,57 @@ synifyType _ vs (TyConApp tc tys) =
maybe_sig ty'
| tyConAppNeedsKindSig False tc tys_len =
let full_kind = typeKind (mkTyConApp tc tys)
- full_kind' = synifyType WithinType vs full_kind
+ full_kind' = synifyType WithinType boundTvs full_kind
in noLocA $ HsKindSig noAnn ty' full_kind'
| otherwise = ty'
-synifyType _ vs ty@(AppTy{}) =
+synifyType _ boundTvs ty@(AppTy{}) =
let
(ty_head, ty_args) = splitAppTys ty
- ty_head' = synifyType WithinType vs ty_head
+ ty_head' = synifyType WithinType boundTvs ty_head
ty_args' =
- map (synifyType WithinType vs) $
+ map (synifyType WithinType boundTvs) $
filterOut isCoercionTy $
filterByList
(map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args)
ty_args
in
foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args'
-synifyType s vs funty@(FunTy af w t1 t2)
- | isInvisibleFunArg af = synifySigmaType s vs funty
+synifyType s boundTvs funty@(FunTy af w t1 t2)
+ | isInvisibleFunArg af = synifySigmaType s boundTvs funty
| otherwise = noLocA $ HsFunTy noExtField w' s1 s2
where
- s1 = synifyType WithinType vs t1
- s2 = synifyType WithinType vs t2
- w' = synifyMultArrow vs w
-synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
+ s1 = synifyType WithinType boundTvs t1
+ s2 = synifyType WithinType boundTvs t2
+ w' = synifyMultArrow boundTvs w
+synifyType s boundTvs forallty@(ForAllTy (Bndr _ argf) _ty) =
case argf of
- Required -> synifyVisForAllType vs forallty
- Invisible _ -> synifySigmaType s vs forallty
+ Required -> synifyVisForAllType boundTvs forallty
+ Invisible _ -> synifySigmaType s boundTvs forallty
synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t
-synifyType s vs (CastTy t _) = synifyType s vs t
+synifyType s boundTvs (CastTy t _) = synifyType s boundTvs t
synifyType _ _ (CoercionTy{}) = error "synifyType:Coercion"
-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType'
synifyVisForAllType
- :: [TyVar]
- -- ^ free variables in the type to convert
+ :: TyVarSet
+ -- ^ bound type variables
-> Type
-- ^ the forall type to convert
-> LHsType GhcRn
-synifyVisForAllType vs ty =
+synifyVisForAllType boundTvs ty =
let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty
- sTvs = map synifyTyVarBndr tvs
+ sTvs = map (synifyTyVarBndr' noKindSigTvs) tvs
+ noKindSigTvs = noKindSigTyVars ty
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
- tvs' = orderedFVs (mkVarSet vs) [rho]
+ tvs' = orderedFVs boundTvs [rho]
in noLocA $
HsForAllTy
{ hst_tele = mkHsForAllVisTele noAnn sTvs
, hst_xforall = noExtField
- , hst_body = synifyType WithinType (tvs' ++ vs) rho
+ , hst_body = synifyType WithinType (extendVarSetList boundTvs tvs') rho
}
-- | Process a 'Type' which starts with an invisible @forall@ or a constraint
@@ -948,18 +950,18 @@ synifyVisForAllType vs ty =
synifySigmaType
:: SynifyTypeState
-- ^ what to do with the 'forall'
- -> [TyVar]
- -- ^ free variables in the type to convert
+ -> TyVarSet
+ -- ^ bound type variables
-> Type
-- ^ the forall type to convert
-> LHsType GhcRn
-synifySigmaType s vs ty =
+synifySigmaType s boundTvs ty =
let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty
sPhi =
HsQualTy
{ hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
- , hst_body = synifyType WithinType (tvs' ++ vs) tau
+ , hst_body = synifyType WithinType (extendVarSetList boundTvs tvs' ) tau
}
sTy =
@@ -969,49 +971,56 @@ synifySigmaType s vs ty =
, hst_body = noLocA sPhi
}
- sTvs = map synifyTyVarBndr tvs
+ sTvs = map (synifyTyVarBndr' noKindSigTvs) tvs
+
+ noKindSigTvs = noKindSigTyVars ty
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
- tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])
+ tvs' = orderedFVs boundTvs (ctx ++ [tau])
in case s of
- DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau
+ DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (extendVarSetList boundTvs tvs') tau
-- Put a forall in if there are any type variables
WithinType
| not (null tvs) -> noLocA sTy
| otherwise -> noLocA sPhi
- ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
+ ImplicitizeForAll -> implicitForAll boundTvs tvs ctx (synifyType WithinType) tau
--- | Put a forall in if there are any type variables which require
--- explicit kind annotations or if the inferred type variable order
--- would be different.
+-- | Use an explicit forall if there are any type variables which require
+-- explicit kind annotations or if the inferred type variable quantification
+-- order would be different.
implicitForAll
- :: [TyCon]
- -- ^ type constructors that determine their args kinds
- -> [TyVar]
- -- ^ free variables in the type to convert
+ :: TyVarSet
+ -- ^ bound type variables (e.g. bound from an outer scope)
-> [InvisTVBinder]
-- ^ type variable binders in the forall
-> ThetaType
-- ^ constraints right after the forall
- -> ([TyVar] -> Type -> LHsType GhcRn)
+ -> (TyVarSet -> Type -> LHsType GhcRn)
-- ^ how to convert the inner type
-> Type
-- ^ inner type
-> LHsType GhcRn
-implicitForAll tycons vs tvs ctx synInner tau
- | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy
- | tvs' /= (binderVars tvs) = noLocA sTy
- | otherwise = noLocA sPhi
+implicitForAll boundTvs tvbs ctx synInner tau
+ | any (isHsKindedTyVar . unLoc) sTvs
+ -- Explicit forall: some type variable needs an explicit kind annotation.
+ = noLocA sTy
+ | tvs /= inferredFreeTvs
+ -- Explicit forall: the inferred quantification order would be different.
+ = noLocA sTy
+ | otherwise
+ -- Implicit forall.
+ = noLocA sPhi
where
- sRho = synInner (tvs' ++ vs) tau
+ tvs = binderVars tvbs
+ sRho = synInner (extendVarSetList boundTvs inferredFreeTvs) tau
sPhi
| null ctx = unLoc sRho
| otherwise =
HsQualTy
{ hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
- , hst_body = synInner (tvs' ++ vs) tau
+ , hst_body = sRho
}
sTy =
HsForAllTy
@@ -1020,84 +1029,129 @@ implicitForAll tycons vs tvs ctx synInner tau
, hst_body = noLocA sPhi
}
- no_kinds_needed = noKindTyVars tycons tau
- sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs
+ no_kinds_needed = noKindSigTyVars tau
+ sTvs = map (synifyTyVarBndr' no_kinds_needed) tvbs
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
- tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])
+ inferredFreeTvs = orderedFVs boundTvs (ctx ++ [tau])
--- | Find the set of type variables whose kind signatures can be properly
--- inferred just from their uses in the type signature. This means the type
--- variable to has at least one fully applied use @f x1 x2 ... xn@ where:
+-- | Returns a subset of the free type variables of the given type whose kinds
+-- can definitely be inferred from their occurrences in the type.
--
--- * @f@ has a function kind where the arguments have the same kinds
--- as @x1 x2 ... xn@.
+-- This function is only a simple heuristic, which is used in order to avoid
+-- needlessly cluttering Haddocks with explicit foralls that are not needed.
+-- This function may return some type variables for which we aren't sure
+-- (which will cause us to display the type with an explicit forall, just in
+-- case).
--
--- * @f@ has a function kind whose final return has lifted type kind
-noKindTyVars
- :: [TyCon]
- -- ^ type constructors that determine their args kinds
- -> Type
+-- In the future, we hope to address the issue of whether to print a type with
+-- an explicit forall by storing whether the user wrote the type with an
+-- explicit forall in the first place (see GHC ticket #26271).
+noKindSigTyVars
+ :: Type
-- ^ type to inspect
-> VarSet
- -- ^ set of variables whose kinds can be inferred from uses in the type
-noKindTyVars _ (TyVarTy var)
- | isLiftedTypeKind (tyVarKind var) = unitVarSet var
-noKindTyVars ts ty
- | (f, xs) <- splitAppTys ty
- , not (null xs) =
- let args = map (noKindTyVars ts) xs
- func = case f of
- TyVarTy var
- | (xsKinds, outKind) <- splitFunTys (tyVarKind var)
- , map scaledThing xsKinds `eqTypes` map typeKind xs
- , isLiftedTypeKind outKind ->
- unitVarSet var
- TyConApp t ks
- | t `elem` ts
- , all noFreeVarsOfType ks ->
- mkVarSet [v | TyVarTy v <- xs]
- _ -> noKindTyVars ts f
- in unionVarSets (func : args)
-noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t
-noKindTyVars ts (FunTy _ w t1 t2) =
- noKindTyVars ts w
- `unionVarSet` noKindTyVars ts t1
- `unionVarSet` noKindTyVars ts t2
-noKindTyVars ts (CastTy t _) = noKindTyVars ts t
-noKindTyVars _ _ = emptyVarSet
-
-synifyMultArrow :: [TyVar] -> Mult -> HsMultAnn GhcRn
-synifyMultArrow vs t = case t of
+ -- ^ set of variables whose kinds can definitely be inferred from occurrences in the type
+noKindSigTyVars ty
+ | Just ty' <- coreView ty
+ = noKindSigTyVars ty'
+ -- In a TyConApp 'T ty_1 ... ty_n', if 'ty_i = tv' is a type variable and the
+ -- i-th argument of the kind of 'T' is monomorphic, then the kind of 'tv'
+ -- is fully determined by its occurrence in the TyConApp.
+ | Just (tc, args) <- splitTyConApp_maybe ty
+ , let (tcArgBndrs, _tcResKi) = splitPiTys (tyConKind tc)
+ tcArgKis = map (\case { Named (Bndr b _) -> tyVarKind b; Anon (Scaled _ t) _ -> t}) tcArgBndrs
+ = mono_tvs tcArgKis args `unionVarSet` (mapUnionVarSet noKindSigTyVars args)
+ -- If we have 'f ty_1 ... ty_n' where 'f :: ki_1 -> ... -> ki_n -> Type'
+ -- then we can infer the kind of 'f' from the kinds of its arguments.
+ --
+ -- This special case handles common examples involving functors, monads...
+ -- with type signatures such as '(a -> b) -> (f a -> f b)'.
+ | (TyVarTy fun, args) <- splitAppTys ty
+ , not (null args)
+ , (funArgKinds, funResKind) <- splitFunTys (tyVarKind fun)
+ , map scaledThing funArgKinds `eqTypes` map typeKind args
+ , isLiftedTypeKind funResKind
+ = ( `extendVarSet` fun ) $ mapUnionVarSet noKindSigTyVars args
+ where
+ mono_tvs :: [Type] -> [Type] -> VarSet
+ mono_tvs (tcArgKi:tcArgKis) (arg:args)
+ | TyVarTy arg_tv <- arg
+ , noFreeVarsOfType tcArgKi
+ = ( `extendVarSet` arg_tv ) $ mono_tvs tcArgKis args
+ | otherwise
+ = mono_tvs tcArgKis args
+ mono_tvs _ _ = emptyVarSet
+noKindSigTyVars (ForAllTy _ t) = noKindSigTyVars t
+noKindSigTyVars (CastTy t _) = noKindSigTyVars t
+noKindSigTyVars _ = emptyVarSet
+
+synifyMultArrow :: TyVarSet -> Mult -> HsMultAnn GhcRn
+synifyMultArrow boundTvs t = case t of
OneTy -> HsLinearAnn noExtField
ManyTy -> HsUnannotated noExtField
- ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
+ ty -> HsExplicitMult noExtField (synifyType WithinType boundTvs ty)
-synifyMultRec :: [TyVar] -> Mult -> HsMultAnn GhcRn
-synifyMultRec vs t = case t of
+synifyMultRec :: TyVarSet -> Mult -> HsMultAnn GhcRn
+synifyMultRec boundTvs t = case t of
OneTy -> HsUnannotated noExtField
- ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
+ ty -> HsExplicitMult noExtField (synifyType WithinType boundTvs ty)
synifyPatSynType :: PatSyn -> LHsType GhcRn
synifyPatSynType ps =
- let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
- ts = maybeToList (tyConAppTyCon_maybe res_ty)
+ let (univ_tvbs, req_theta, ex_tvbs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
+
+{- Recall that pattern synonyms have both "required" and "provided" constraints,
+e.g.
+
+ pattern P :: forall a b c. req => forall e f g => prov => arg_ty1 -> ... -> res_ty
+
+Here:
+
+ a, b, c are universal type variables
+ req are required constraints
- -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
- -- i.e., an explicit empty context, which is what we need. This is not
- -- possible by taking theta = [], as that will print no context at all
+ e, f, g are existential type variables
+ prov are provided constraints
+
+The first pair comes from the outside, while the second pair is obtained upon
+a successful match on the pattern.
+
+Remarks:
+
+ 1. Both foralls are optional.
+
+ 2. If there is only one =>, we interpret the constraints as required.
+ Thus, if we want an empty set of required constraints and a non-empty set
+ of provided constraints, the type signature must be written like
+
+ () => prov => res_ty
+-}
+
+
+ -- Add an explicit "() => ..." when req_theta is empty but there are
+ -- existential variables or provided constraints.
req_theta'
| null req_theta
- , not (null prov_theta && null ex_tvs) =
+ , not (null prov_theta && null ex_tvbs) =
[unitTy]
| otherwise = req_theta
+ univ_tvs = mkVarSet $ binderVars univ_tvbs
+ ex_tvs = mkVarSet $ binderVars ex_tvbs
+
+
in implicitForAll
- ts
- []
- (univ_tvs ++ ex_tvs)
+ ex_tvs -- consider the ex_tvs non-free, so that we don't quantify over them here
+ univ_tvbs -- quantify only over the universals
req_theta'
- (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType))
+ ( \_ ->
+ implicitForAll
+ univ_tvs -- the univ_tvs are already bound
+ ex_tvbs -- quantify only over the existentials
+ prov_theta
+ (synifyType WithinType)
+ )
(mkScaledFunTys arg_tys res_ty)
synifyTyLit :: TyLit -> HsTyLit GhcRn
@@ -1106,7 +1160,7 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c
synifyKindSig :: Kind -> LHsKind GhcRn
-synifyKindSig k = synifyType WithinType [] k
+synifyKindSig k = synifyType WithinType emptyVarSet k
stripKindSig :: LHsType GhcRn -> LHsType GhcRn
stripKindSig (L _ (HsKindSig _ t _)) = t
@@ -1119,7 +1173,7 @@ synifyInstHead (vs, preds, cls, types) associated_families =
, ihdTypes = map unLoc annot_ts
, ihdInstType =
ClassInst
- { clsiCtx = map (unLoc . synifyType WithinType []) preds
+ { clsiCtx = map (unLoc . synifyType WithinType emptyVarSet) preds
, clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
, clsiSigs = map synifyClsIdSig $ specialized_class_methods
, clsiAssocTys =
@@ -1132,7 +1186,7 @@ synifyInstHead (vs, preds, cls, types) associated_families =
where
cls_tycon = classTyCon cls
ts = filterOutInvisibleTypes cls_tycon types
- ts' = map (synifyType WithinType vs) ts
+ ts' = map (synifyType WithinType $ mkVarSet vs) ts
annot_ts = zipWith3 annotHsType args_poly ts ts'
args_poly = tyConArgsPolyKinded cls_tycon
synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs
@@ -1151,7 +1205,7 @@ synifyFamInst fi opaque = do
where
ityp SynFamilyInst | opaque = return $ TypeInst Nothing
ityp SynFamilyInst =
- return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs
+ return . TypeInst . Just . unLoc $ synifyType WithinType emptyVarSet fam_rhs
ityp (DataFamilyInst c) =
DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c
fam_tc = famInstTyCon fi
@@ -1173,7 +1227,7 @@ synifyFamInst fi opaque = do
fam_lhs
ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs
- synifyTypes = map (synifyType WithinType [])
+ synifyTypes = map (synifyType WithinType emptyVarSet)
ts' = synifyTypes ts
annot_ts = zipWith3 annotHsType args_poly ts ts'
args_poly = tyConArgsPolyKinded fam_tc
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -856,8 +856,8 @@ tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c
tyCoFVsOfType' (LitTy{}) a b c = emptyFV a b c
tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c
tyCoFVsOfType' (FunTy _ w arg res) a b c =
- ( tyCoFVsOfType' w
- `unionFV` tyCoFVsOfType' res
+ ( tyCoFVsOfType' res
+ `unionFV` tyCoFVsOfType' w
`unionFV` tyCoFVsOfType' arg
)
a
=====================================
utils/haddock/html-test/ref/Bug1050.html
=====================================
@@ -99,11 +99,7 @@
>mkT</a
> :: <span class="keyword"
>forall</span
- > {k} {f :: <span class="keyword"
- >forall</span
- > k1. k1 -> <a href="#" title="Data.Kind"
- >Type</a
- >} {a :: k}. f a -> <a href="#" title="Bug1050"
+ > {k} {f} {a :: k}. f a -> <a href="#" title="Bug1050"
>T</a
> f a <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/ref/LinearTypes.html
=====================================
@@ -64,11 +64,7 @@
><li class="src short"
><a href="#"
>poly</a
- > :: <span class="keyword"
- >forall</span
- > a (m :: <a href="#" title="GHC.Exts"
- >Multiplicity</a
- >) b. a %m -> b</li
+ > :: a %m -> b</li
><li class="src short"
><span class="keyword"
>data</span
@@ -163,11 +159,7 @@
><p class="src"
><a id="v:poly" class="def"
>poly</a
- > :: <span class="keyword"
- >forall</span
- > a (m :: <a href="#" title="GHC.Exts"
- >Multiplicity</a
- >) b. a %m -> b <a href="#" class="selflink"
+ > :: a %m -> b <a href="#" class="selflink"
>#</a
></p
><div class="doc"
=====================================
utils/haddock/html-test/ref/PatternSyns.html
=====================================
@@ -132,7 +132,9 @@
>pattern</span
> <a href="#"
>E</a
- > :: a <a href="#" title="PatternSyns"
+ > :: <span class="keyword"
+ >forall</span
+ > {k} {a} {b :: k}. a <a href="#" title="PatternSyns"
>><</a
> b</li
><li class="src short"
@@ -335,7 +337,9 @@
>pattern</span
> <a id="v:E" class="def"
>E</a
- > :: a <a href="#" title="PatternSyns"
+ > :: <span class="keyword"
+ >forall</span
+ > {k} {a} {b :: k}. a <a href="#" title="PatternSyns"
>><</a
> b <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/ref/PatternSyns2.html
=====================================
@@ -0,0 +1,160 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><meta name="viewport" content="width=device-width, initial-scale=1"
+ /><title
+ >PatternSyns2</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script type="text/x-mathjax-config"
+ >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-…" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><span class="caption empty"
+ > </span
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >Index</a
+ ></li
+ ></ul
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >None</td
+ ></tr
+ ><tr
+ ><th
+ >Language</th
+ ><td
+ >Haskell2010</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >PatternSyns2</p
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P1" class="def"
+ >P1</a
+ > :: () => <a href="#" title="Prelude"
+ >Num</a
+ > a => a -> D <a href="#" title="Prelude"
+ >Num</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P2" class="def"
+ >P2</a
+ > :: <a href="#" title="Prelude"
+ >Num</a
+ > a => a -> a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P3" class="def"
+ >P3</a
+ > :: () => <span class="keyword"
+ >forall</span
+ > (e :: <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > '<a href="#" title="GHC.Exts"
+ >DoubleRep</a
+ >). <span class="breakable"
+ >(<span class="unbreakable"
+ >PCIR a</span
+ >, <span class="unbreakable"
+ >PCDR e</span
+ >)</span
+ > => a -> e -> Q a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P4" class="def"
+ >P4</a
+ > :: RCIR a => <span class="keyword"
+ >forall</span
+ > (e :: <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > '<a href="#" title="GHC.Exts"
+ >DoubleRep</a
+ >). <span class="breakable"
+ >(<span class="unbreakable"
+ >PCIR a</span
+ >, <span class="unbreakable"
+ >PCDR e</span
+ >)</span
+ > => a -> e -> Q a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P5" class="def"
+ >P5</a
+ > :: RCIR a => <span class="keyword"
+ >forall</span
+ > (e :: <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > '<a href="#" title="GHC.Exts"
+ >DoubleRep</a
+ >). a -> e -> Q a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P" class="def"
+ >P</a
+ > :: () => <span class="keyword"
+ >forall</span
+ > k (a :: k) b. <a href="#" title="Prelude"
+ >Show</a
+ > b => <a href="#" title="Data.Proxy"
+ >Proxy</a
+ > a -> b -> A <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></div
+ ></div
+ ></body
+ ></html
+>
=====================================
utils/haddock/html-test/ref/TypeOperators.html
=====================================
@@ -185,17 +185,7 @@
><p class="src"
><a id="v:biO" class="def"
>biO</a
- > :: <span class="keyword"
- >forall</span
- > (g :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- >) (f :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- >) a. <a href="#" title="TypeOperators"
+ > :: <a href="#" title="TypeOperators"
>O</a
> g f a <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/src/PatternSyns2.hs
=====================================
@@ -0,0 +1,60 @@
+{-# LANGUAGE Haskell2010 #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module PatternSyns2
+ ( pattern P1, pattern P2, pattern P3, pattern P4, pattern P5
+ , pattern P
+ )
+ where
+
+import Data.Kind
+import Data.Proxy
+import GHC.Exts
+
+type D :: ( Type -> Constraint ) -> Type -> Type
+data D c a where
+ MkD :: c a => a -> D c a
+
+pattern P1 :: () => Num a => a -> D Num a
+pattern P1 a = MkD a
+
+pattern P2 :: Num a => () => a -> a
+pattern P2 a = a
+
+type RCIR :: TYPE IntRep -> Constraint
+class RCIR a where
+
+type PCIR :: TYPE IntRep -> Constraint
+class PCIR a where
+
+type PCDR :: TYPE DoubleRep -> Constraint
+class PCDR a where
+
+type Q :: TYPE IntRep -> Type
+data Q a where
+ MkQ :: forall ( a :: TYPE IntRep ) ( e :: TYPE DoubleRep )
+ . ( PCIR a, PCDR e )
+ => a -> e -> Q a
+
+pattern P3 :: forall (a :: TYPE IntRep). () => forall (e :: TYPE DoubleRep). (PCIR a, PCDR e) => a -> e -> Q a
+pattern P3 a e = MkQ a e
+
+pattern P4 :: forall (a :: TYPE IntRep). (RCIR a) => forall (e :: TYPE DoubleRep). (PCIR a, PCDR e) => a -> e -> Q a
+pattern P4 a e = MkQ a e
+
+pattern P5 :: forall (a :: TYPE IntRep). (RCIR a) => forall (e :: TYPE DoubleRep). () => a -> e -> Q a
+pattern P5 a e <- MkQ a e
+
+
+type A :: Type
+data A where
+ MkA :: forall k (a ::k) b. ( Show b ) => Proxy a -> b -> A
+
+pattern P :: forall . () => forall k (a :: k) b. ( Show b ) => Proxy a -> b -> A
+pattern P a b = MkA a b
=====================================
utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
=====================================
@@ -24,7 +24,7 @@ Does something linear.\par}
\end{haddockdesc}
\begin{haddockdesc}
\item[\begin{tabular}{@{}l}
-poly :: forall a (m :: Multiplicity) b. a {\char '45}m -> b
+poly :: a {\char '45}m -> b
\end{tabular}]
{\haddockbegindoc
Does something polymorphic.\par}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f510de080baf1b5ff017fcec83168f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f510de080baf1b5ff017fcec83168f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23162-part2] Back off on always reporting insolubles
by Simon Peyton Jones (＠simonpj) 11 Dec '25
by Simon Peyton Jones (＠simonpj) 11 Dec '25
11 Dec '25
Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC
Commits:
67b1e382 by Simon Peyton Jones at 2025-12-11T13:35:03+00:00
Back off on always reporting insolubles
- - - - -
1 changed file:
- compiler/GHC/Tc/Errors.hs
Changes:
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -1322,8 +1322,13 @@ maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = import
-- report nothing. (If at least one is not suppressed, do report: the function that
-- generates the error message should look for an unsuppressed error item.)
- | any ei_insoluble items
- = False -- Don't suppress insolubles even if cec_suppress is True
+-- It is tempting to say that we always want to see all insoluble errors
+-- But then we get a bit more than we want. Examples:
+-- a ~ t a occurs check errors (T2534, mc25)
+-- T @X1 T1 ~ T @X2 T2 gives two insolubles: X1~X2 and T1~T2 (KindVType, T17380, T22332b)
+--
+-- | any ei_insoluble items
+-- = False -- Don't suppress insolubles even if cec_suppress is True
| cec_suppress ctxt
= True -- Some earlier error has occurred, so suppress this diagnostic
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67b1e382acd47c364715d33bdd6a6f6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67b1e382acd47c364715d33bdd6a6f6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0