Simon Peyton Jones pushed new branch wip/T26615 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26615
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index] WIP: unit index
by Torsten Schmits (＠torsten.schmits) 28 Nov '25
by Torsten Schmits (＠torsten.schmits) 28 Nov '25
28 Nov '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index at Glasgow Haskell Compiler / GHC
Commits:
5f73c9f7 by Torsten Schmits at 2025-11-28T14:10:47+01:00
WIP: unit index
- - - - -
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
@@ -58,6 +60,7 @@ import GHC.Unit.Module.ModDetails
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndex, UnitIndexQuery, unitIndexQuery)
import GHC.Core ( CoreRule )
import GHC.Core.FamInstEnv
@@ -118,6 +121,12 @@ 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 = unitIndexQuery . hscUnitIndex
+
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
=====================================
@@ -146,6 +146,7 @@ import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import GHC.Types.Unique
import GHC.Iface.Errors.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.Word64Set as W
import GHC.Data.Graph.Directed.Reachability
@@ -188,12 +189,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 +513,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 +2388,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
@@ -87,6 +88,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery, unitIndexQuery)
import GHC.Data.Bag
import GHC.Data.FastString
@@ -337,7 +339,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 <- unitIndexQuery (ue_index unit_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 +450,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 +467,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 +482,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
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -68,11 +69,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 +207,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 +219,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
=====================================
@@ -48,6 +48,7 @@ import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.ShortText as ST
@@ -67,7 +68,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), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,17 +163,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 +197,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 +208,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 +225,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 +287,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, OverloadedRecordDot, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,15 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+ unitIndexQuery,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -577,10 +588,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 <$> query.findOrigin 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 +649,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 (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1021,7 +1032,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
+ then Left (filter (matches . fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1485,8 +1496,9 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger cfg index = do
{-
Plan.
@@ -1542,15 +1554,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 -> index.readDatabases logger 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.
@@ -1561,159 +1567,9 @@ 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
-
- -- Now that we've merged everything together, prune out unusable
- -- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
-
- reportCycles logger sccs
- reportUnusable logger unusable
-
- -- Apply trust flags (these flags apply regardless of whether
- -- or not packages are visible or not)
- pkgs1 <- mayThrowUnitErr
- $ foldM (applyTrustFlag prec_map unusable)
- (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
- let prelim_pkg_db = mkUnitInfoMap pkgs1
-
- --
- -- Calculate the initial set of units from package databases, prior to any package flags.
- --
- -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
- -- (not units). This is empty if we have -hide-all-packages.
- --
- -- Then we create an initial visibility map with default visibilities for all
- -- exposed, definite units which belong to the latest valid packages.
- --
- let preferLater unit unit' =
- case compareByPreference prec_map unit unit' of
- GT -> unit
- _ -> unit'
- addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
- -- This is the set of maximally preferable packages. In fact, it is a set of
- -- most preferable *units* keyed by package name, which act as stand-ins in
- -- for "a package in a database". We use units here because we don't have
- -- "a package in a database" as a type currently.
- mostPreferablePackageReps = if unitConfigHideAll cfg
- then emptyUDFM
- else foldl' addIfMorePreferable emptyUDFM pkgs1
- -- When exposing units, we want to consider all of those in the most preferable
- -- packages. We can implement that by looking for units that are equi-preferable
- -- with the most preferable unit for package. Being equi-preferable means that
- -- they must be in the same database, with the same version, and the same package name.
- --
- -- We must take care to consider all these units and not just the most
- -- preferable one, otherwise we can end up with problems like #16228.
- mostPreferable u =
- case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
- Nothing -> False
- Just u' -> compareByPreference prec_map u u' == EQ
- vis_map1 = foldl' (\vm p ->
- -- Note: we NEVER expose indefinite packages by
- -- default, because it's almost assuredly not
- -- what you want (no mix-in linking has occurred).
- if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
- then addToUniqMap vm (mkUnit p)
- UnitVisibility {
- uv_expose_all = True,
- uv_renamings = [],
- uv_package_name = First (Just (fsPackageName p)),
- uv_requirements = emptyUniqMap,
- uv_explicit = Nothing
- }
- else vm)
- emptyUniqMap pkgs1
-
- --
- -- Compute a visibility map according to the command-line flags (-package,
- -- -hide-package). This needs to know about the unusable packages, since if a
- -- user tries to enable an unusable package, we should let them know.
- --
- vis_map2 <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- (unitConfigHideAll cfg) pkgs1)
- vis_map1 other_flags
-
- --
- -- Sort out which packages are wired in. This has to be done last, since
- -- it modifies the unit ids of wired in packages, but when we process
- -- package arguments we need to key against the old versions.
- --
- (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
- let pkg_db = mkUnitInfoMap pkgs2
-
- -- Update the visibility map, so we treat wired packages as visible.
- let vis_map = updateVisibilityMap wired_map vis_map2
-
- let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
- plugin_vis_map <-
- case unitConfigFlagsPlugins cfg of
- -- common case; try to share the old vis_map
- [] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return emptyUniqMap
- _ -> do let plugin_vis_map1
- | hide_plugin_pkgs = emptyUniqMap
- -- Use the vis_map PRIOR to wired in,
- -- because otherwise applyPackageFlag
- -- won't work.
- | otherwise = vis_map2
- plugin_vis_map2
- <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- hide_plugin_pkgs pkgs1)
- plugin_vis_map1
- (reverse (unitConfigFlagsPlugins cfg))
- -- Updating based on wired in packages is mostly
- -- good hygiene, because it won't matter: no wired in
- -- package has a compiler plugin.
- -- TODO: If a wired in package had a compiler plugin,
- -- and you tried to pick different wired in packages
- -- with the plugin flags and the normal flags... what
- -- would happen? I don't know! But this doesn't seem
- -- likely to actually happen.
- return (updateVisibilityMap wired_map plugin_vis_map2)
-
- let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
- | p <- pkgs2
- ]
- -- The explicitUnits accurately reflects the set of units we have turned
- -- on; as such, it also is the only way one can come up with requirements.
- -- The requirement context is directly based off of this: we simply
- -- look for nested unit IDs that are directly fed holes: the requirements
- -- of those units are precisely the ones we need to track
- let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
- 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
- -- should contain at least rts & base, which is why we pretend that
- -- the command line contains -package rts & -package base.
- --
- -- NB: preload IS important even for type-checking, because we
- -- need the correct include path to be set.
- --
- let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
-
- -- add default preload units if they can be found in the db
- basicLinkedUnits = fmap (RealUnit . Definite)
- $ filter (flip elemUniqMap pkg_db)
- $ unitConfigAutoLink cfg
- preload3 = ordNub $ (basicLinkedUnits ++ preload1)
-
- -- Close the preload packages with their dependencies
- dep_preload <- mayThrowUnitErr
- $ closeUnitDeps pkg_db
- $ zip (map toUnitId preload3) (repeat Nothing)
+ (pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger cfg raw_dbs other_flags
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
+ -- pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
-- Force the result to avoid leaking input parameters
let !state = UnitState
@@ -1722,8 +1578,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 = emptyUniqMap
+ , pluginModuleNameProvidersMap = emptyUniqMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1752,263 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ index_all :: ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ query :: IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId],
+ update ::
+ Logger ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (
+ UnitInfoMap,
+ [(Unit, Maybe PackageArg)],
+ [UnitId],
+ UniqMap ModuleName [InstantiatedModule],
+ UniqFM PackageName UnitId,
+ WiringMap
+ )
+ }
+
+unitIndexQuery ::
+ MonadIO m =>
+ UnitIndex ->
+ m UnitIndexQuery
+unitIndexQuery index = liftIO index.query
+
+data UnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders :: !ModuleNameProvidersMap,
+ pluginModuleNameProviders :: !ModuleNameProvidersMap
+ }
+
+newUnitIndexBackend :: UnitIndexBackend
+newUnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders = mempty,
+ pluginModuleNameProviders = mempty
+ }
+
+queryFindOrigin ::
+ UnitIndexBackend ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOrigin UnitIndexBackend {moduleNameProviders} name _plugins =
+ lookupUniqMap moduleNameProviders name
+
+newUnitIndexQuery ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ m UnitIndexQuery
+newUnitIndexQuery ref = do
+ state <- liftIO $ readIORef ref
+ pure UnitIndexQuery {
+ findOrigin = queryFindOrigin state,
+ index_all = state.moduleNameProviders
+ }
+
+updateIndexDefault ::
+ IORef UnitIndexBackend ->
+ Logger ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap)
+updateIndexDefault ref logger cfg raw_dbs other_flags = do
+
+ -- 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
+
+
+ -- Merge databases together, without checking validity
+ (pkg_map1, prec_map) <- mergeDatabases logger dbs
+
+ -- Now that we've merged everything together, prune out unusable
+ -- packages.
+ let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+
+ reportCycles logger sccs
+ reportUnusable logger unusable
+
+ -- Apply trust flags (these flags apply regardless of whether
+ -- or not packages are visible or not)
+ pkgs1 <- mayThrowUnitErr
+ $ foldM (applyTrustFlag prec_map unusable)
+ (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
+ let prelim_pkg_db = mkUnitInfoMap pkgs1
+
+ --
+ -- Calculate the initial set of units from package databases, prior to any package flags.
+ --
+ -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
+ -- (not units). This is empty if we have -hide-all-packages.
+ --
+ -- Then we create an initial visibility map with default visibilities for all
+ -- exposed, definite units which belong to the latest valid packages.
+ --
+ let preferLater unit unit' =
+ case compareByPreference prec_map unit unit' of
+ GT -> unit
+ _ -> unit'
+ addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
+ -- This is the set of maximally preferable packages. In fact, it is a set of
+ -- most preferable *units* keyed by package name, which act as stand-ins in
+ -- for "a package in a database". We use units here because we don't have
+ -- "a package in a database" as a type currently.
+ mostPreferablePackageReps = if unitConfigHideAll cfg
+ then emptyUDFM
+ else foldl' addIfMorePreferable emptyUDFM pkgs1
+ -- When exposing units, we want to consider all of those in the most preferable
+ -- packages. We can implement that by looking for units that are equi-preferable
+ -- with the most preferable unit for package. Being equi-preferable means that
+ -- they must be in the same database, with the same version, and the same package name.
+ --
+ -- We must take care to consider all these units and not just the most
+ -- preferable one, otherwise we can end up with problems like #16228.
+ mostPreferable u =
+ case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
+ Nothing -> False
+ Just u' -> compareByPreference prec_map u u' == EQ
+ vis_map1 = foldl' (\vm p ->
+ -- Note: we NEVER expose indefinite packages by
+ -- default, because it's almost assuredly not
+ -- what you want (no mix-in linking has occurred).
+ if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+ then addToUniqMap vm (mkUnit p)
+ UnitVisibility {
+ uv_expose_all = True,
+ uv_renamings = [],
+ uv_package_name = First (Just (fsPackageName p)),
+ uv_requirements = emptyUniqMap,
+ uv_explicit = Nothing
+ }
+ else vm)
+ emptyUniqMap pkgs1
+ --
+ -- Compute a visibility map according to the command-line flags (-package,
+ -- -hide-package). This needs to know about the unusable packages, since if a
+ -- user tries to enable an unusable package, we should let them know.
+ --
+ vis_map2 <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ (unitConfigHideAll cfg) pkgs1)
+ vis_map1 other_flags
+
+ --
+ -- Sort out which packages are wired in. This has to be done last, since
+ -- it modifies the unit ids of wired in packages, but when we process
+ -- package arguments we need to key against the old versions.
+ --
+ (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ -- let pkg_db = mkUnitInfoMap pkgs2
+
+ let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
+ | p <- pkgs2
+ ]
+
+ -- Update the visibility map, so we treat wired packages as visible.
+ let vis_map = updateVisibilityMap wired_map vis_map2
+
+ let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
+ plugin_vis_map <-
+ case unitConfigFlagsPlugins cfg of
+ -- common case; try to share the old vis_map
+ [] | not hide_plugin_pkgs -> return vis_map
+ | otherwise -> return emptyUniqMap
+ _ -> do let plugin_vis_map1
+ | hide_plugin_pkgs = emptyUniqMap
+ -- Use the vis_map PRIOR to wired in,
+ -- because otherwise applyPackageFlag
+ -- won't work.
+ | otherwise = vis_map2
+ plugin_vis_map2
+ <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ hide_plugin_pkgs pkgs1)
+ plugin_vis_map1
+ (reverse (unitConfigFlagsPlugins cfg))
+ -- Updating based on wired in packages is mostly
+ -- good hygiene, because it won't matter: no wired in
+ -- package has a compiler plugin.
+ -- TODO: If a wired in package had a compiler plugin,
+ -- and you tried to pick different wired in packages
+ -- with the plugin flags and the normal flags... what
+ -- would happen? I don't know! But this doesn't seem
+ -- likely to actually happen.
+ return (updateVisibilityMap wired_map plugin_vis_map2)
+
+ let pkg_db = mkUnitInfoMap pkgs2
+ -- The explicitUnits accurately reflects the set of units we have turned
+ -- on; as such, it also is the only way one can come up with requirements.
+ -- The requirement context is directly based off of this: we simply
+ -- look for nested unit IDs that are directly fed holes: the requirements
+ -- of those units are precisely the ones we need to track
+ let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
+ 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
+ -- should contain at least rts & base, which is why we pretend that
+ -- the command line contains -package rts & -package base.
+ --
+ -- NB: preload IS important even for type-checking, because we
+ -- need the correct include path to be set.
+ --
+ let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
+
+ -- add default preload units if they can be found in the db
+ basicLinkedUnits = fmap (RealUnit . Definite)
+ $ filter (flip elemUniqMap pkg_db)
+ $ unitConfigAutoLink cfg
+ preload3 = ordNub $ (basicLinkedUnits ++ preload1)
+
+ -- Close the preload packages with their dependencies
+ dep_preload <- mayThrowUnitErr
+ $ 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
+ atomicModifyIORef' ref $ \ UnitIndexBackend {..} -> let
+ updated = UnitIndexBackend {
+ -- TODO this favors older entries, which seems sensible because they are
+ -- most likely to be caught in retainers?
+ moduleNameProviders = mod_map Semigroup.<> moduleNameProviders,
+ pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map Semigroup.<> pluginModuleNameProviders,
+ ..
+ }
+ in (updated, (pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map))
+
+readDatabasesDefault :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger cfg =
+ readUnitDatabases logger cfg
+
+newUnitIndex :: MonadIO m => m UnitIndex
+newUnitIndex = do
+ ref <- liftIO $ newIORef newUnitIndexBackend
+ pure UnitIndex {
+ query = newUnitIndexQuery ref,
+ readDatabases = readDatabasesDefault,
+ update = updateIndexDefault ref
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +2016,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 +2047,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 +2080,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 query.findOrigin m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2155,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 query.index_all
, 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 :: UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames query =
+ map fst (filter visible (nonDetUniqMapToList query.index_all))
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 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 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 :: UnitIndexQuery -> [ModuleName]
+allVisibleModules query = listVisibleModuleNames 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
=====================================
@@ -844,7 +844,8 @@ initMulti unitArgsFiles = 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
+ index = hscUnitIndex hsc_env
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags 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 = hscUnitIndex hsc_env} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f73c9f7dbd1611f44e0b84cecdbdd8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f73c9f7dbd1611f44e0b84cecdbdd8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index] WIP: unit index
by Torsten Schmits (＠torsten.schmits) 28 Nov '25
by Torsten Schmits (＠torsten.schmits) 28 Nov '25
28 Nov '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index at Glasgow Haskell Compiler / GHC
Commits:
8d28b090 by Torsten Schmits at 2025-11-28T13:36:04+01:00
WIP: unit index
- - - - -
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
@@ -58,6 +60,7 @@ import GHC.Unit.Module.ModDetails
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndex, UnitIndexQuery, unitIndexQuery)
import GHC.Core ( CoreRule )
import GHC.Core.FamInstEnv
@@ -118,6 +121,12 @@ 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 = unitIndexQuery . hscUnitIndex
+
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
=====================================
@@ -146,6 +146,7 @@ import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import GHC.Types.Unique
import GHC.Iface.Errors.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.Word64Set as W
import GHC.Data.Graph.Directed.Reachability
@@ -188,12 +189,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 +513,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 +2388,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
@@ -87,6 +88,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery, unitIndexQuery)
import GHC.Data.Bag
import GHC.Data.FastString
@@ -337,7 +339,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 <- unitIndexQuery (ue_index unit_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 +450,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 +467,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 +482,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
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -68,11 +69,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 +207,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 +219,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
=====================================
@@ -48,6 +48,7 @@ import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.ShortText as ST
@@ -67,7 +68,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), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,17 +163,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 +197,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 +208,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 +225,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 +287,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, OverloadedRecordDot, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,15 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+ unitIndexQuery,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -577,10 +588,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 <$> query.findOrigin 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 +649,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 (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1021,7 +1032,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
+ then Left (filter (matches . fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1485,8 +1496,9 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger cfg index = do
{-
Plan.
@@ -1542,7 +1554,7 @@ 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 -> index.readDatabases logger cfg
Just dbs -> return dbs
-- distrust all units if the flag is set
@@ -1715,6 +1727,9 @@ mkUnitState logger cfg = do
mod_map2 = mkUnusableModuleNameProvidersMap unusable
mod_map = mod_map2 `plusUniqMap` mod_map1
+ index.update mod_map
+ -- index.update (mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map)
+
-- Force the result to avoid leaking input parameters
let !state = UnitState
{ preloadUnits = dep_preload
@@ -1722,7 +1737,7 @@ mkUnitState logger cfg = do
, homeUnitDepends = Set.toList home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
+ , moduleNameProvidersMap = emptyUniqMap
, pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
, packageNameMap = pkgname_map
, wireMap = wired_map
@@ -1896,6 +1911,91 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ index_all :: ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ query :: IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId],
+ update :: ModuleNameProvidersMap -> IO ()
+ }
+
+unitIndexQuery ::
+ MonadIO m =>
+ UnitIndex ->
+ m UnitIndexQuery
+unitIndexQuery index = liftIO index.query
+
+data UnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders :: !ModuleNameProvidersMap,
+ pluginModuleNameProviders :: !ModuleNameProvidersMap
+ }
+
+newUnitIndexBackend :: UnitIndexBackend
+newUnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders = mempty,
+ pluginModuleNameProviders = mempty
+ }
+
+queryFindOrigin ::
+ UnitIndexBackend ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOrigin UnitIndexBackend {moduleNameProviders} name _plugins =
+ lookupUniqMap moduleNameProviders name
+
+newUnitIndexQuery ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ m UnitIndexQuery
+newUnitIndexQuery ref = do
+ state <- liftIO $ readIORef ref
+ pure UnitIndexQuery {
+ findOrigin = queryFindOrigin state,
+ index_all = state.moduleNameProviders
+ }
+
+-- queryForUnit :: UnitState -> UnitIndexQuery -> UnitIndexQuery
+-- queryForUnit =
+-- undefined
+
+updateIndex ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ ModuleNameProvidersMap ->
+ m ()
+updateIndex ref new =
+ liftIO $ atomicModifyIORef' ref $ \ UnitIndexBackend {..} -> let
+ updated = UnitIndexBackend {
+ -- TODO this favors older entries, which seems sensible because they are
+ -- most likely to be caught in retainers?
+ moduleNameProviders = new Semigroup.<> moduleNameProviders,
+ ..
+ }
+ in (updated, ())
+
+readDatabasesDefault :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger cfg =
+ readUnitDatabases logger cfg
+
+newUnitIndex :: MonadIO m => m UnitIndex
+newUnitIndex = do
+ ref <- liftIO $ newIORef newUnitIndexBackend
+ pure UnitIndex {
+ query = newUnitIndexQuery ref,
+ readDatabases = readDatabasesDefault,
+ update = updateIndex ref
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +2003,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 +2034,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 +2067,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 query.findOrigin m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2142,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 query.index_all
, 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 :: UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames query =
+ map fst (filter visible (nonDetUniqMapToList query.index_all))
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 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 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 :: UnitIndexQuery -> [ModuleName]
+allVisibleModules query = listVisibleModuleNames 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
=====================================
@@ -844,7 +844,8 @@ initMulti unitArgsFiles = 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
+ index = hscUnitIndex hsc_env
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags 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 = hscUnitIndex hsc_env} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d28b0900800ad8e0c5b5dd32fa969c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d28b0900800ad8e0c5b5dd32fa969c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
28 Nov '25
Cheng Shao deleted branch wip/ghc-9.12-fix-wasm at Glasgow Haskell Compiler / GHC
--
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/torsten.schmits/unit-index
by Torsten Schmits (＠torsten.schmits) 28 Nov '25
by Torsten Schmits (＠torsten.schmits) 28 Nov '25
28 Nov '25
Torsten Schmits pushed new branch wip/torsten.schmits/unit-index at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/torsten.schmits/unit-index
You're receiving this email because of your account on gitlab.haskell.org.
1
0
28 Nov '25
Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC
Commits:
f225ae07 by Simon Peyton Jones at 2025-11-28T10:40:57+00:00
More refactoring
- - - - -
50b70db3 by Simon Peyton Jones at 2025-11-28T10:43:46+00:00
Fix Notes about CoercionHoles
- - - - -
4 changed files:
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Utils/Unify.hs
Changes:
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -1022,7 +1022,7 @@ afvFolder check_fv = TyCoFolder { tcf_view = noView -- See Note [Free vars and
do_tcv is tv = Any (not (tv `elemVarSet` is) && check_fv tv)
do_bndr is tv _ = is `extendVarSet` tv
do_hole _ hole = Any (anyFreeVarsOfType check_fv (varType (coHoleCoVar hole)))
- -- See Note [CoercionHoles and their variables]
+ -- See Note [CoercionHoles and their free variables]
-- NB: that call to `anyFreeVarsOfType` on the kind starts again with the
-- empty in-scope set; see Note [Closing over free variable kinds]
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1817,7 +1817,7 @@ Other notes about CoercionHole and HoleCo:
* It carries a type which makes `coercionKind` and `coercionRole` work
* It has a Unique, which gives the hole an identity; see calls to `ctEvEvId`
-(COH3) See Note [CoercionHoles and coercion free variables] in GHC.Core.TyCo.FVs
+(COH3) See Note [CoercionHoles and their free variables] in GHC.Core.TyCo.FVs
(COH4) Coercion holes can be compared for equality like other coercions:
by looking at the types coerced.
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -424,68 +424,43 @@ tcApp rn_expr exp_res_ty
; do_ql <- wantQuickLook rn_fun
; (inst_args, app_res_rho) <- tcInstFun do_ql inst_final tc_head fun_sigma rn_args
- ; case do_ql of
- NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho)
-
- -- Step 4.1: subsumption check against expected result type
- -- See Note [Unify with expected type before typechecking arguments]
- ; res_wrap <- checkResultTy rn_expr tc_head inst_args
- app_res_rho exp_res_ty
-
- -- Step 4.2: typecheck the arguments
- ; tc_args <- tcValArgs NoQL inst_args
-
- -- Step 4.3: wrap up
- ; finishApp tc_head tc_args app_res_rho res_wrap }
-
- DoQL -> do { traceTc "tcApp:DoQL" (ppr rn_fun $$ ppr app_res_rho)
-
- -- Step 5.1: Take a quick look at the result type
+ ; app_res_rho <- case do_ql of
+ NoQL -> return app_res_rho
+ DoQL -> do { -- Step 5.1: Take a quick look at the result type
-- See Note [QuickLook: arguments before result]
- ; case exp_res_ty of
- Check exp_rho -> quickLookResultType app_res_rho exp_rho
- Infer {} -> return ()
+ case exp_res_ty of
+ Check exp_rho -> quickLookResultType app_res_rho exp_rho
+ Infer {} -> return ()
-- Step 5.3: zonk to expose the polymorphism hidden under
-- QuickLook instantiation variables in `app_res_rho`
- ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
+ -- from either quickLookArg or quickLookResultType
+ ; liftZonkM $ zonkTcType app_res_rho }
- -- Step 5.4: subsumption check against the expected type
- -- See Note [Unify with expected type before typechecking arguments]
- ; res_wrap <- checkResultTy rn_expr tc_head inst_args
- app_res_rho exp_res_ty
-
- -- Step 5.2: typecheck the arguments, and monomorphise
- -- any un-unified instantiation variables
- ; tc_args <- tcValArgs DoQL inst_args
-
- -- Step 5.5: wrap up
- ; finishApp tc_head tc_args app_res_rho res_wrap } }
-
--- | Variant of 'getDeepSubsumptionFlag' which enables a top-level subsumption
--- in order to implement the plan of Note [Typechecking data constructors].
-getDeepSubsumptionFlag_DataConHead :: HsExpr GhcTc -> TcM DeepSubsumptionFlag
-getDeepSubsumptionFlag_DataConHead app_head =
- do { user_ds <- xoptM LangExt.DeepSubsumption
- ; return $
- if | user_ds
- -> Deep DeepSub
- | XExpr (ConLikeTc (RealDataCon {})) <- app_head
- -> Deep TopSub
- | otherwise
- -> Shallow
- }
+ ; finishApp do_ql rn_expr tc_head inst_args app_res_rho exp_res_ty }
-finishApp :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc]
- -> TcRhoType -> HsWrapper
+finishApp :: QLFlag -> HsExpr GhcRn
+ -> (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpInst]
+ -> TcRhoType -> ExpRhoType
-> TcM (HsExpr GhcTc)
-- Do final checks and wrap up the result
-finishApp tc_head@(tc_fun,_) tc_args app_res_rho res_wrap
- = do {
- -- Reconstruct, with a horrible special case for tagToEnum#.
- res_expr <- if isTagToEnum tc_fun
+-- Precondition: app_res_rho has no polymorphism hidden under instantiation variables
+finishApp do_ql rn_expr tc_head@(tc_fun,_) inst_args
+ app_res_rho exp_res_ty
+ = do { -- Step 5.4: subsumption check against the expected type
+ -- See Note [Unify with expected type before typechecking arguments]
+ res_wrap <- checkResultTy rn_expr tc_head inst_args
+ app_res_rho exp_res_ty
+
+ -- Step 5.2: Typecheck the arguments, and monomorphise
+ -- any un-unified instantiation variables
+ ; tc_args <- tcValArgs do_ql inst_args
+
+ -- Horrible special case for tagToEnum#.
+ ; res_expr <- if isTagToEnum tc_fun
then tcTagToEnum tc_head tc_args app_res_rho
else return (rebuildHsApps tc_head tc_args)
+
; traceTc "End tcApp }" (ppr tc_fun)
; return (mkHsWrap res_wrap res_expr) }
@@ -630,10 +605,8 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
quickLookResultType app_res_rho exp_arg_rho -- the qlUnify
; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
- ; res_wrap <- checkResultTy rn_expr tc_head inst_args
- app_res_rho (mkCheckExpType exp_arg_rho)
- ; tc_args <- tcValArgs DoQL inst_args
- ; finishApp tc_head tc_args app_res_rho res_wrap }
+ ; finishApp DoQL rn_expr tc_head inst_args app_res_rho
+ (mkCheckExpType exp_arg_rho) }
; traceTc "tcEValArgQL }" $
vcat [ text "app_res_rho:" <+> ppr app_res_rho ]
@@ -644,6 +617,20 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
--------------------
+-- | Variant of 'getDeepSubsumptionFlag' which enables a top-level subsumption
+-- in order to implement the plan of Note [Typechecking data constructors].
+getDeepSubsumptionFlag_DataConHead :: HsExpr GhcTc -> TcM DeepSubsumptionFlag
+getDeepSubsumptionFlag_DataConHead app_head =
+ do { user_ds <- xoptM LangExt.DeepSubsumption
+ ; return $
+ if | user_ds
+ -> Deep DeepSub
+ | XExpr (ConLikeTc (RealDataCon {})) <- app_head
+ -> Deep TopSub
+ | otherwise
+ -> Shallow
+ }
+
whenQL :: QLFlag -> ZonkM () -> TcM ()
whenQL DoQL thing_inside = liftZonkM thing_inside
whenQL NoQL _ = return ()
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -3555,7 +3555,7 @@ mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co)
do_hole _is hole = check_ty (varType (coHoleCoVar hole))
-- For coercion holes, look in the kind of the hole
- -- See Note [CorecionHoles and their free variables] in GHC.Core.TyCo.FVs
+ -- See Note [CoercionHoles and their free variables] in GHC.Core.TyCo.FVs
{- *********************************************************************
* *
@@ -4190,7 +4190,7 @@ checkCo flags co =
else PuFail reason }
-- Occurs check (no promotion)
- -- See Note [CorecionHoles and their free variables] in GHC.Core.TyCo.FVs
+ -- See Note [CoercionHoles and their free variables] in GHC.Core.TyCo.FVs
| OC_Check lhs_tv occ_prob <- occ
, let (_, check_co) = mkOccFolders lhs_tv
, check_co co
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fa545237fe7514276f690ae5fdfa78…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fa545237fe7514276f690ae5fdfa78…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC
Commits:
fa545237 by Simon Peyton Jones at 2025-11-28T10:15:20+00:00
Backtrack
Adding Note [QuickLook: arguments before result]
- - - - -
1 changed file:
- compiler/GHC/Tc/Gen/App.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -354,6 +354,44 @@ Unify result type /before/ typechecking the args
• In the first argument of ‘Pair’, namely ‘"yes"’
The latter is much better. That is why we call checkResultType before tcValArgs.
+
+Note [QuickLook: arguments before result]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally we try to push the expected result type into the call;
+see Note [Unify with expected type before typechecking arguments].
+But surprisingly we can't do that for QuickLook. (#26599 was a failed
+attempt to suggest this.) Consider
+ h :: (Int->Int) -> Int ids :: [forall a. a->a]
+and the call
+ h (head ids)
+Let's say we instantiate `head :: [a] -> a` with `a:=kappa`.
+We QuickLook at the argument with expected type (Int->Int). We must NOT
+unify kappa:=(Int->Int), because kappa:=forall a. a->a is the only
+solution, and one that we will find if we look at the argument first.
+
+TL;DR: we must do `quickLookArg` on all arguments before doing `quickLookResultType`
+on the result type.
+
+Remember: `quickLookResultType` is really anticipating a /subsumption/ test, not
+an equality test. Doing `qlUnify` on the result type (always a rho-type) is
+in general wrong if there is an un-guarded kappa in the result type. It's wrong
+UNLESS we have already gotten all the info about `kappa` (from the
+arguments) that we are going to get. That's why we QuickLook the arguments first.
+
+This is a bit sad, as #26599 shows. Consider
+
+ woo :: (x, [forall a. a->a])
+ bar1 = snd woo
+ bar2 = snd (id woo)
+
+For `bar1` we instantiate `snd` at [a:=k1,b:=k2]. Then we QL on the argument `woo`
+(instantiating with `x:=k3`. Since the result type is guarded we qlUnify
+ (k3,forall a.a->a) ~ (k1,k2)
+and thus succeed in discovering k2:=forall a.a->a, as desired.
+
+But for `bar2` we fail. When quick-looking (id woo) we instantiate `id` with [a:=k],
+and quick-look the argument `woo` with expected type `k`. That's not guarded,
+so we get no information. Adding the `id` call makes it un-typeable. Boo.
-}
tcApp :: HsExpr GhcRn
@@ -403,24 +441,23 @@ tcApp rn_expr exp_res_ty
DoQL -> do { traceTc "tcApp:DoQL" (ppr rn_fun $$ ppr app_res_rho)
-- Step 5.1: Take a quick look at the result type
- ; inst_args_with_guards <- case exp_res_ty of
- Check exp_rho -> do { qlUnify app_res_rho exp_rho
- ; mapM reGuardArg inst_args }
- Infer {} -> return inst_args
-
- ; inst_args_ql <- mapM quickLookArg inst_args_with_guards
+ -- See Note [QuickLook: arguments before result]
+ ; case exp_res_ty of
+ Check exp_rho -> quickLookResultType app_res_rho exp_rho
+ Infer {} -> return ()
-- Step 5.3: zonk to expose the polymorphism hidden under
-- QuickLook instantiation variables in `app_res_rho`
; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
-- Step 5.4: subsumption check against the expected type
- ; res_wrap <- checkResultTy rn_expr tc_head inst_args_ql
- app_res_rho exp_res_ty
+ -- See Note [Unify with expected type before typechecking arguments]
+ ; res_wrap <- checkResultTy rn_expr tc_head inst_args
+ app_res_rho exp_res_ty
-- Step 5.2: typecheck the arguments, and monomorphise
-- any un-unified instantiation variables
- ; tc_args <- tcValArgs DoQL inst_args_ql
+ ; tc_args <- tcValArgs DoQL inst_args
-- Step 5.5: wrap up
; finishApp tc_head tc_args app_res_rho res_wrap } }
@@ -589,13 +626,13 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
-- Unify with context if we have not already done so
-- See (QLA4) in Note [Quick Look at value arguments]
- ; unless arg_influences_enclosing_call $ -- Don't repeat
- qlUnify app_res_rho exp_arg_rho -- the qlUnify
+ ; unless arg_influences_enclosing_call $ -- Don't repeat
+ quickLookResultType app_res_rho exp_arg_rho -- the qlUnify
- ; tc_args <- tcValArgs DoQL inst_args
; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
; res_wrap <- checkResultTy rn_expr tc_head inst_args
app_res_rho (mkCheckExpType exp_arg_rho)
+ ; tc_args <- tcValArgs DoQL inst_args
; finishApp tc_head tc_args app_res_rho res_wrap }
; traceTc "tcEValArgQL }" $
@@ -607,6 +644,10 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
--------------------
+whenQL :: QLFlag -> ZonkM () -> TcM ()
+whenQL DoQL thing_inside = liftZonkM thing_inside
+whenQL NoQL _ = return ()
+
wantQuickLook :: HsExpr GhcRn -> TcM QLFlag
wantQuickLook (HsVar _ (L _ (WithUserRdr _ f)))
| getUnique f `elem` quickLookKeys = return DoQL
@@ -839,11 +880,8 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
(Just $ HsExprTcThing tc_fun)
(n_val_args, fun_sigma) fun_ty
- ; let arg' = EValArg { ea_ctxt = ctxt
- , ea_arg = arg
- , ea_arg_ty = arg_ty }
- acc' = arg' : addArgWrap (mkWpCastN fun_co) acc
-
+ ; arg' <- quickLookArg do_ql ctxt arg arg_ty
+ ; let acc' = arg' : addArgWrap (mkWpCastN fun_co) acc
; go (pos+1) acc' res_ty rest_args }
new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType)
@@ -1841,21 +1879,28 @@ This turned out to be more subtle than I expected. Wrinkles:
-}
-quickLookArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst)
+quickLookArg :: QLFlag -> AppCtxt
+ -> LHsExpr GhcRn -- ^ Argument
+ -> Scaled TcSigmaTypeFRR -- ^ Type expected by the function
+ -> TcM (HsExprArg 'TcpInst)
-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper
-- See Note [Quick Look at value arguments]
-quickLookArg e_arg@(EValArg { ea_ctxt = ctxt
- , ea_arg = larg@(L _ arg)
- , ea_arg_ty = orig_arg_ty })
- = do { let !(Scaled _ orig_arg_rho) = orig_arg_ty
- -- NB: orig_arg_rho may not be zonked, but that's ok
- ; is_rho <- tcIsDeepRho orig_arg_rho
+quickLookArg NoQL ctxt larg orig_arg_ty
+ = skipQuickLook ctxt larg orig_arg_ty
+quickLookArg DoQL ctxt larg orig_arg_ty
+ = do { is_rho <- tcIsDeepRho (scaledThing orig_arg_ty)
; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho)
; if not is_rho
- then return e_arg
- else
+ then skipQuickLook ctxt larg orig_arg_ty
+ else quickLookArg1 ctxt larg orig_arg_ty }
- addArgCtxt ctxt larg $ -- Context needed for constraints
+quickLookArg1 :: AppCtxt -> LHsExpr GhcRn
+ -> Scaled TcRhoType -- Deeply skolemised
+ -> TcM (HsExprArg 'TcpInst)
+-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper
+quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
+ -- NB: orig_arg_rho may not be zonked, but that's ok
+ = addArgCtxt ctxt larg $ -- Context needed for constraints
-- generated by calls in arg
do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg
@@ -1873,7 +1918,7 @@ quickLookArg e_arg@(EValArg { ea_ctxt = ctxt
, text "args:" <+> ppr rn_args ]
; case mb_fun_ty of {
- Nothing -> return e_arg ; -- fun is too complicated
+ Nothing -> skipQuickLook ctxt larg sc_arg_ty ; -- fun is too complicated
Just (tc_fun, fun_sigma) ->
-- step 2: use |-inst to instantiate the head applied to the arguments
@@ -1903,37 +1948,40 @@ quickLookArg e_arg@(EValArg { ea_ctxt = ctxt
-- unzonked orig_arg_rho, so that we deliberately do not exploit
-- guardedness that emerges a result of QL on earlier args
-- In contrast, we must do the `anyFreeKappa` test /after/ tcInstFun; see (QLA3).
+ ; arg_influences_enclosing_call
+ <- if isGuardedTy orig_arg_rho
+ then return True
+ else not <$> anyFreeKappa app_res_rho -- (B)
+ -- For (B) see Note [The fiv test in quickLookArg]
- ; (arg_influences_call, inst_args_ql)
- <- if isGuardedTy orig_arg_rho -- (A)
- then do { qlUnify app_res_rho orig_arg_rho
- ; inst_args_with_guards <- mapM reGuardArg inst_args
- ; inst_args_ql <- mapM quickLookArg inst_args_with_guards
- ; return (True, inst_args_ql) }
- else do { inst_args_ql <- mapM quickLookArg inst_args
- ; has_free_inst_vars <- anyFreeKappa app_res_rho --(B)
- ; if has_free_inst_vars
- then return (False, inst_args_ql)
- else do { qlUnify app_res_rho orig_arg_rho
- ; return (True, inst_args_ql) } }
+ -- Step 4: do quick-look unification if either (A) or (B) hold
+ -- NB: orig_arg_rho may not be zonked, but that's ok
+ ; when arg_influences_enclosing_call $
+ quickLookResultType app_res_rho orig_arg_rho
; traceTc "quickLookArg done }" (ppr rn_fun)
; return (EValArgQL { eaql_ctxt = ctxt
- , eaql_arg_ty = orig_arg_ty
+ , eaql_arg_ty = sc_arg_ty
, eaql_larg = larg
, eaql_tc_fun = tc_head
, eaql_fun_ue = fun_ue
- , eaql_args = inst_args_ql
+ , eaql_args = inst_args
, eaql_wanted = wanted
- , eaql_encl = arg_influences_call
- , eaql_res_rho = app_res_rho }) }}}}
+ , eaql_encl = arg_influences_enclosing_call
+ , eaql_res_rho = app_res_rho }) }}}
-quickLookArg other_arg = return other_arg
+quickLookResultType :: TcRhoType -> TcRhoType -> TcM ()
+-- See Note [QuickLook: arguments before result]
+quickLookResultType app_rest_rho exp_res_rho
+ = qlUnify app_rest_rho exp_res_rho
-whenQL :: QLFlag -> ZonkM () -> TcM ()
-whenQL DoQL thing_inside = liftZonkM thing_inside
-whenQL NoQL _ = return ()
+skipQuickLook :: AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType
+ -> TcM (HsExprArg 'TcpInst)
+skipQuickLook ctxt larg arg_ty
+ = return (EValArg { ea_ctxt = ctxt
+ , ea_arg = larg
+ , ea_arg_ty = arg_ty })
tcIsDeepRho :: TcType -> TcM Bool
-- This top-level zonk step, which is the reason we need a local 'go' loop,
@@ -1961,15 +2009,6 @@ tcIsDeepRho ty
| otherwise
= return True
-reGuardArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst)
--- Zonk the result type of an EValArg, so that a subseqent
--- call to isGuardedTy will see the unifications so far
-reGuardArg arg@(EValArg { ea_arg_ty = arg_ty })
- = do { arg_ty' <- liftZonkM $ zonkScaledTcType arg_ty
- ; return (arg { ea_arg_ty = arg_ty' }) }
-reGuardArg arg
- = return arg
-
isGuardedTy :: TcType -> Bool
isGuardedTy ty
| Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa545237fe7514276f690ae5fdfa789…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa545237fe7514276f690ae5fdfa789…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/backports-9.14] rts/linker/PEi386: Copy strings before they are inserted into LoadedDllCache....
by Zubin (＠wz1000) 28 Nov '25
by Zubin (＠wz1000) 28 Nov '25
28 Nov '25
Zubin pushed to branch wip/backports-9.14 at Glasgow Haskell Compiler / GHC
Commits:
85e8147d by Zubin Duggal at 2025-11-28T14:00:24+05:30
rts/linker/PEi386: Copy strings before they are inserted into LoadedDllCache. The original strings are temporary and might be freed at an arbitrary point.
Fixes #26613
(cherry picked from commit 5072da477b8ec883aea4b9ea27763fcc1971af1a)
- - - - -
1 changed file:
- rts/linker/PEi386.c
Changes:
=====================================
rts/linker/PEi386.c
=====================================
@@ -552,7 +552,12 @@ static int compare_path(StgWord key1, StgWord key2)
static void addLoadedDll(LoadedDllCache *cache, const pathchar *dll_name, HINSTANCE instance)
{
- insertHashTable_(cache->hash, (StgWord) dll_name, instance, hash_path);
+ // dll_name might be deallocated, we need to copy it to have a stable reference to the contents
+ // See #26613
+ size_t size = wcslen(dll_name) + 1;
+ pathchar* dll_name_copy = stgMallocBytes(size * sizeof(pathchar), "addLoadedDll");
+ wcsncpy(dll_name_copy, dll_name, size);
+ insertHashTable_(cache->hash, (StgWord) dll_name_copy, instance, hash_path);
}
static HINSTANCE isDllLoaded(const LoadedDllCache *cache, const pathchar *dll_name)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85e8147dd7893db46db1868d65f4cff…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85e8147dd7893db46db1868d65f4cff…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/26613] rts/linker/PEi386: Copy strings before they are inserted into LoadedDllCache....
by Zubin (＠wz1000) 28 Nov '25
by Zubin (＠wz1000) 28 Nov '25
28 Nov '25
Zubin pushed to branch wip/26613 at Glasgow Haskell Compiler / GHC
Commits:
5072da47 by Zubin Duggal at 2025-11-28T13:48:36+05:30
rts/linker/PEi386: Copy strings before they are inserted into LoadedDllCache. The original strings are temporary and might be freed at an arbitrary point.
Fixes #26613
- - - - -
1 changed file:
- rts/linker/PEi386.c
Changes:
=====================================
rts/linker/PEi386.c
=====================================
@@ -552,7 +552,12 @@ static int compare_path(StgWord key1, StgWord key2)
static void addLoadedDll(LoadedDllCache *cache, const pathchar *dll_name, HINSTANCE instance)
{
- insertHashTable_(cache->hash, (StgWord) dll_name, instance, hash_path);
+ // dll_name might be deallocated, we need to copy it to have a stable reference to the contents
+ // See #26613
+ size_t size = wcslen(dll_name) + 1;
+ pathchar* dll_name_copy = stgMallocBytes(size * sizeof(pathchar), "addLoadedDll");
+ wcsncpy(dll_name_copy, dll_name, size);
+ insertHashTable_(cache->hash, (StgWord) dll_name_copy, instance, hash_path);
}
static HINSTANCE isDllLoaded(const LoadedDllCache *cache, const pathchar *dll_name)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5072da477b8ec883aea4b9ea27763fc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5072da477b8ec883aea4b9ea27763fc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][ghc-9.12] 20 commits: rts: fix top handler closure type signatures
by Zubin (＠wz1000) 28 Nov '25
by Zubin (＠wz1000) 28 Nov '25
28 Nov '25
Zubin pushed to branch ghc-9.12 at Glasgow Haskell Compiler / GHC
Commits:
d4489170 by Cheng Shao at 2025-11-21T15:50:36+01:00
rts: fix top handler closure type signatures
This commit fixes the runIO/runNonIO closure type signatures in the
RTS which should be extern StgClosure. This allows us to remove an
unnecessary type cast in the C foreign desugaring logic, as well as
unneeded complications of JSFFI desugaring logic that also needs to
generate C stubs that may refer to those top handler closures.
Otherwise, we'll have to take special care to avoid generating "extern
StgClosure" declarations for them as we would for other closures, just
to avoid conflicting type signature error at stub compile time.
(cherry picked from commit c78d8f55afacfd559b1602bc2fbc35b1f326f1c1)
- - - - -
18d6cf11 by Cheng Shao at 2025-11-21T15:50:36+01:00
compiler: allow arbitrary label string for JSFFI exports
This commit allows arbitrary label string to appear in a foreign
export declaration, as long as the calling convention is javascript.
Well, doesn't make sense to enforce it's a C function symbol for a
JSFFI declaration anyway, and it gets in the way of implementing the
"sync" flavour of exports.
(cherry picked from commit a204df3aa5a7be00c67aa7c92c5091ab32522226)
- - - - -
3ecb5e0b by Cheng Shao at 2025-11-21T15:50:36+01:00
compiler: wasm backend JSFFI sync exports
This commit implements the synchronous flavour of the wasm backend
JSFFI exports:
- `foreign export javascript "foo sync"` exports a top-level Haskell
binding as a synchronous JS function
- `foreign import javascript "wrapper sync"` dynamically exports a
Haskell function closure as a synchronous JS function
- `foreign import javascript unsafe` is now re-entrant by lowering to
a safe ccall
- Also fix the issue that JSFFI dynamic exports didn't really work in
TH & ghci (#25473)
(cherry picked from commit 03ebab52bd00d4726735829cf6a24e5c9d3ac0c1)
- - - - -
5afe9c33 by Cheng Shao at 2025-11-21T15:50:36+01:00
testsuite: test wasm backend JSFFI sync exports
This commit repurposes some existing JSFFI test cases to make them
cover JSFFI sync exports as well.
(cherry picked from commit b6ae908bd3ae7b75b79925e56c3e11ba5c40b5ec)
- - - - -
9efbf3f4 by Cheng Shao at 2025-11-21T15:50:37+01:00
docs: document wasm backend JSFFI sync exports
This commit updates wasm backend documentation to reflect the new
JSFFI sync exports feature.
(cherry picked from commit edae287402792c09fa92b655e0cbd01100db9856)
- - - - -
61754416 by Cheng Shao at 2025-11-21T15:50:37+01:00
wasm: add error message to WouldBlockException
This commit attaches an error message to WouldBlockException, for now
the error message consists of the JS async import code snippet that
thunk is trying to block for. This is useful for debugging synchronous
callbacks that accidentally call an async JS function.
(cherry picked from commit 9b54eecbee7329543e5016cec1574831bfb788c2)
- - - - -
3b26d306 by Cheng Shao at 2025-11-21T15:50:37+01:00
ghc-experimental: make JSVal abstract in GHC.Wasm.Prim
This commit makes JSVal an abstract type in the export list of
GHC.Wasm.Prim. JSVal's internal representation is supposed to be a non
user facing implementation detail subject to change at any time. We
should only expose things that are newtypes of JSVal, not JSVal
itself.
(cherry picked from commit 8037f487ff1721973737b01e29136c671fd25157)
- - - - -
03600749 by Cheng Shao at 2025-11-21T15:50:37+01:00
wasm: make JSVal internal Weak# point to lifted JSVal
JSVal has an internal Weak# with the unlifted JSVal# object as key to
arrange its builtin finalization logic. The Weak# used to designate
Unit_closure as a dummy value; now this commit designates the lifted
JSVal closure as the Weak# value. This allows the implementation of
mkWeakJSVal which can be used to observe the liveliness of a JSVal and
attach a user-specified finalizer.
(cherry picked from commit 4f34243101684a0ad15f5986abec00c675b48955)
- - - - -
f66e52c8 by Cheng Shao at 2025-11-21T15:50:37+01:00
ghc-experimental: add mkWeakJSVal
This commit adds a mkWeakJSVal function that can be used to set up a
Weak pointer with a JSVal key to observe the key's lifetime and
optionally attach a finalizer.
(cherry picked from commit 55af20e6ed5c72a46a09b88e8590b6b2309eb41b)
- - - - -
da0ccd0e by Cheng Shao at 2025-11-21T15:50:37+01:00
wasm: don't create a wasm global for dyld poison
There's a much more efficient way to convert an unsigned i32 to a
signed one. Thanks, o3-mini-high.
(cherry picked from commit 75fcc5c9ab900cb80834802c581283681cf8c398)
- - - - -
8003474f by Cheng Shao at 2025-11-21T16:01:18+01:00
wasm: revamp JSFFI internal implementation and documentation
This patch revamps the wasm backend's JSFFI internal implementation
and documentation:
- `JSValManager` logic to allocate a key is simplified to simple
bumping. According to experiments with all major browsers, the
internal `Map` would overflow the heap much earlier before we really
exhaust the 32-bit key space, so there's no point in the extra
complexity.
- `freeJSVal` is now idempotent and safe to call more than once. This
is achieved by attaching the `StablePtr#` to the `JSVal#` closure
and nullifying it when calling `freeJSVal`, so the same stable
pointer cannot be double freed.
- `mkWeakJSVal` no longer exposes the internal `Weak#` pointer and
always creates a new `Weak#` on the fly. Otherwise by finalizing
that `Weak#`, user could accidentally drop the `JSVal`, but
`mkWeakJSVal` is only supposed to create a `Weak` that observes the
`JSVal`'s liveliness without actually interfering it.
- `PromisePendingException` is no longer exported since it's never
meant to be caught by user code; it's a severe bug if it's actually
raised at runtime.
- Everything exported by user-facing `GHC.Wasm.Prim` now has proper
haddock documentation.
- Note [JSVal representation for wasm] has been updated to reflect the
new JSVal# memory layout.
(cherry picked from commit fd40eaa17c6ce8716ec2eacc95beae194a935352)
- - - - -
60acee61 by Cheng Shao at 2025-11-21T16:03:36+01:00
rts: add hs_try_putmvar_with_value to RTS API
This commit adds hs_try_putmvar_with_value to rts. It allows more
flexibility than hs_try_putmvar by taking an additional value argument
as a closure to be put into the MVar. This function is used & tested
by the wasm backend runtime, though it makes sense to expose it as a
public facing RTS API function as well.
(cherry picked from commit f75e823e0a9ac9fbe661fce232324c5b103ee8a8)
- - - - -
cdfb37c3 by Cheng Shao at 2025-11-21T16:03:36+01:00
wasm: use MVar as JSFFI import blocking mechanism
Previously, when blocking on a JSFFI import, we push a custom
stg_jsffi_block stack frame and arrange the `promise.then` callback to
write to that stack frame. It turns out we can simply use the good old
MVar to implement the blocking logic, with a few benefits:
- Less maintenance burden. We can drop the stg_jsffi_block related Cmm
code without loss of functionality.
- It interacts better with existing async exception mechanism. throwTo
would properly block the caller if the target thread is masking
async exceptions.
(cherry picked from commit 9cd9f34787b4d54e1ba3fbbf927a160a0f8eab99)
- - - - -
8dfb64de by Cheng Shao at 2025-11-21T16:03:36+01:00
wasm: properly pin the raiseJSException closure
We used to use keepAlive# to pin the raiseJSException closure when
blocking on a JSFFI import thunk, since it can potentially be used by
RTS. But raiseJSException may be used in other places as well (e.g.
the promise.throwTo logic), and it's better to simply unconditionally
pin it in the JSFFI initialization logic.
(cherry picked from commit da34f0aa2082d1c5a306cc8356abba15f3d59aad)
- - - - -
0166eb5d by Cheng Shao at 2025-11-21T16:03:36+01:00
wasm: implement promise.throwTo() for async JSFFI exports
This commit implements promise.throwTo() for wasm backend JSFFI
exports. This allows the JavaScript side to interrupt Haskell
computation by raising an async exception. See subsequent docs/test
commits for more details.
(cherry picked from commit dc904bfdd17ed1108580367b34bbe7204ed4ea95)
- - - - -
93de375e by Cheng Shao at 2025-11-21T16:03:36+01:00
testsuite: add test for wasm promise.throwTo() logic
This commit adds a test case to test the wasm backend
promise.throwTo() logic.
(cherry picked from commit 7f80455ee45e70d142bbc69478b9a8db43082187)
- - - - -
791ac161 by Cheng Shao at 2025-11-21T16:03:36+01:00
docs: document the wasm backend promise.throwTo() feature
(cherry picked from commit afdd3fe7fff60e046f6a3ee4795c58abe81f03a2)
- - - - -
8d8807f2 by Cheng Shao at 2025-11-21T16:24:59+01:00
rts: fix wasm JSFFI initialization constructor code
This commit fixes wasm JSFFI initialization constructor code so that
the constructor is self-contained and avoids invoking a fake
__main_argc_argv function. The previous approach of reusing
__main_void logic in wasi-libc saves a tiny bit of code, at the
expense of link-time trouble whenever GHC links a wasm module without
-no-hs-main, in which case the driver-generated main function would
clash with the definition here, resulting in a linker error. It's
simply better to avoid messing with the main function, and it would
additionally allow linking wasm32-wasi command modules that does make
use of synchronous JSFFI.
(cherry picked from commit bdc9d130a838017f863f5c7a380cb0858035f859)
- - - - -
6d38b32c by Cheng Shao at 2025-11-21T17:16:11+01:00
wasm: fix remaining regressions in upstream 9.12 branch
This commit fixes remaining regressions in upstream 9.12 branch caused
by broken backporting of !14892. Fixes #26600.
- - - - -
3cd27895 by Cheng Shao at 2025-11-25T14:30:05+01:00
docs: add wasm related items in 9.12.3 notes
- - - - -
31 changed files:
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Foreign/Wasm.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- docs/users_guide/9.12.3-notes.rst
- docs/users_guide/exts/ffi.rst
- docs/users_guide/wasm.rst
- libraries/ghc-experimental/src/GHC/Wasm/Prim.hs
- libraries/ghc-internal/src/GHC/Internal/Wasm/Prim.hs
- libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs
- libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Flag.hs
- libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs
- libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs
- rts/RtsAPI.c
- rts/RtsSymbols.c
- rts/include/HsFFI.h
- rts/wasm/JSFFI.c
- rts/wasm/blocker.cmm
- rts/wasm/jsval.cmm
- rts/wasm/scheduler.cmm
- testsuite/tests/jsffi/all.T
- + testsuite/tests/jsffi/cancel.hs
- + testsuite/tests/jsffi/cancel.mjs
- + testsuite/tests/jsffi/cancel.stdout
- testsuite/tests/jsffi/jsffigc.hs
- testsuite/tests/jsffi/jsffigc.mjs
- testsuite/tests/jsffi/jsffisleep.hs
- testsuite/tests/jsffi/jsffisleep.stdout
- testsuite/tests/jsffi/textconv.hs
- testsuite/tests/jsffi/textconv.mjs
- utils/jsffi/dyld.mjs
- utils/jsffi/prelude.mjs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c7de5d8551824cb309c61dc625280f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c7de5d8551824cb309c61dc625280f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0