Matthew Pickering pushed to branch wip/unit-index at Glasgow Haskell Compiler / GHC Commits: 64b3f6f3 by Torsten Schmits at 2026-02-18T16:00:26+00:00 Abstract out parts of mkUnitState into a handler type - - - - - 24 changed files: - compiler/GHC.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Runtime/Context.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/GHCi/UI/Print.hs - ghc/Main.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -376,7 +376,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) +import GHC.Rename.Names (hscRenamePkgQual, hscRenameRawPkgQual) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -663,7 +663,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 = @@ -747,6 +748,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 @@ -754,7 +756,7 @@ setProgramDynFlags_ invalidate_needed dflags = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (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 @@ -773,6 +775,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_current_unit = ue_currentUnit old_unit_env , ue_module_graph = ue_module_graph 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) @@ -830,6 +833,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_current_unit = ue_currentUnit unit_env0 , ue_eps = ue_eps unit_env0 , ue_module_graph = ue_module_graph unit_env0 + , ue_index = ue_index unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -878,7 +882,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph 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 unit_env) cached_unit_dbs home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants pure HomeUnitEnv @@ -1700,10 +1704,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d parens (text (expectJust (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 @@ -1728,7 +1732,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env let sec = initSourceErrorContext dflags 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 sec $ noModError hsc_env noSrcSpan mod_name err @@ -1778,7 +1783,8 @@ lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env let sec = initSourceErrorContext dflags 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 sec $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -79,8 +79,10 @@ core2core hsc_env guts@(ModGuts { mg_module = mod , mg_loc = loc , mg_rdr_env = rdr_env }) = do { hpt_rule_base <- home_pkg_rules + ; query <- hscUnitIndexQuery hsc_env ; let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars uniq_tag = SimplTag + name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod name_ppr_ctx loc $ @@ -103,7 +105,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod extra_vars = interactiveInScope (hsc_IC hsc_env) home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot }) - name_ppr_ctx = mkNamePprCtx ptc unit_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 @@ -448,6 +449,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) } @@ -461,6 +463,7 @@ doCorePass pass guts = do mkNamePprCtx (initPromotionTickContext dflags) (hsc_unit_env hsc_env) + query rdr_env ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -438,6 +438,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 -> @@ -446,7 +447,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 @@ -462,6 +463,7 @@ addUnit u = do (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env + , ue_index } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } @@ -879,13 +881,15 @@ hsModuleToModSummary home_keys pn hsc_src modname hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file_ospath location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file_ospath location) + query <- liftIO $ hscUnitIndexQuery hsc_env + -- Also copied from 'getImports' let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps implicit_prelude = xopt LangExt.ImplicitPrelude dflags generated_imports = mkPrelImports modname 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) = (convImportLevel (ideclLevelSpec i), rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -275,7 +275,7 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do where -- - mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) + mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, RawPkgQual, GenWithIsBoot (Located ModuleName)) -- A simple edge to a module from the same home unit mkEdge (IIModule n) = let @@ -294,12 +294,12 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do let lvl = convImportLevel (ideclLevelSpec i) wanted_mod = unLoc (ideclName i) is_boot = ideclSource i - mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i) + raw_pkg = ideclPkgQual i unitId = homeUnitId $ hsc_home_unit hsc_env - in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) + in Right (unitId, lvl, raw_pkg, GWIB (noLoc wanted_mod) is_boot) loopFromInteractive :: HscEnv - -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + -> [Either ModuleNodeEdge (UnitId, ImportLevel, RawPkgQual, GenWithIsBoot (Located ModuleName))] -> M.Map NodeKey ModuleGraphNode -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode) loopFromInteractive _ [] cached_nodes = return ([], cached_nodes) @@ -308,12 +308,13 @@ loopFromInteractive hsc_env (edge:edges) cached_nodes = Left edge -> do (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes return (edge : edges, cached_nodes') - Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do + Right (unitId, lvl, raw_pkg, GWIB wanted_mod is_boot) -> do let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) let k _ loc mod = let key = moduleToMnk mod is_boot in return $ FoundHome (ModuleNodeFixed key loc) - found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg [] + pkg_qual <- hscRenameRawPkgQual hsc_env (unLoc wanted_mod) raw_pkg + found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod pkg_qual [] case found of -- Case 1: Home modules have to already be in the cache. FoundHome (ModuleNodeFixed mod _) -> do @@ -1541,7 +1542,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do sec = initSourceErrorContext pi_local_dflags mimps <- getImports popts sec imp_prelude pi_hspp_buf pi_hspp_fn src_fn return (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 (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn)) let pi_srcimps = pi_srcimps' let pi_theimps = rn_imps pi_theimps' ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -9,6 +9,8 @@ module GHC.Driver.Env , hsc_home_unit , hsc_home_unit_maybe , hsc_units + , hscUnitIndex + , hscUnitIndexQuery , hsc_HPT , hsc_HUE , hsc_HUG @@ -123,6 +125,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState hsc_units = ue_homeUnitState . hsc_unit_env +hscUnitIndex :: HscEnv -> UnitIndex +hscUnitIndex = ue_index . hsc_unit_env + +hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery +hscUnitIndexQuery hsc_env = + unitIndexQuery (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env) + hsc_HPT :: HscEnv -> HomePackageTable hsc_HPT = ue_hpt . hsc_unit_env ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -2733,9 +2733,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 ===================================== @@ -173,12 +173,13 @@ depanalE diag_wrapper msg 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 @@ -451,15 +452,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 (\(_st, fs, mn) -> lookupModulePackage us (unLoc mn) fs) + mapMaybe (\(_st, fs, mn) -> lookupModulePackage us query (unLoc mn) fs) $ concatMap ms_imps home_mod_sum used_args = Set.fromList (map unitId loadedPackages) ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -671,9 +671,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps) <- 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 (\(s, rpk, lmn@(L _ mn)) -> (s, rn_pkg_qual mn rpk, lmn)) sec = initSourceErrorContext dflags eimps <- getImports popts sec imp_prelude buf input_fn (basename <.> suff) ===================================== compiler/GHC/Driver/Session/Inspect.hs ===================================== @@ -80,7 +80,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 { @@ -175,7 +176,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 @@ -196,4 +198,3 @@ modInfoSafe = minf_safe modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks modInfoModBreaks = minf_modBreaks - ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -128,11 +128,12 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags let home_units = HUG.allUnits initial_home_graph + let ue_index = hscUnitIndex hsc_env home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv hue_flags = homeUnitEnv_dflags homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units + (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_index cached_unit_dbs home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants emptyHpt <- liftIO $ emptyHomePackageTable @@ -244,4 +245,3 @@ createUnitEnvFromFlags unitDflags = do let activeUnit = fst $ NE.head unitEnvList return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) - ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -145,7 +145,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 ===================================== @@ -87,6 +87,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 @@ -284,7 +285,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env -- in allocations by ~5% if we don't do this. traverse (lookupCompleteMatch type_env hsc_env) =<< localAndImportedCompleteMatches tcg_comp_env eps - ; 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 statics_var next_wrapper_num_var ds_complete_matches } @@ -336,6 +338,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds ; msg_var <- newIORef emptyMessages ; statics_var <- newIORef nilOL ; 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) @@ -345,7 +348,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds ; ds_complete_matches <- traverse (lookupCompleteMatch type_env hsc_env) =<< localAndImportedCompleteMatches local_complete_matches eps ; let - 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 statics_var next_wrapper_num ds_complete_matches ; runDs hsc_env envs thing_inside @@ -384,13 +387,13 @@ 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 (OrdList (Id,CoreExpr)) -> IORef (ModuleEnv Int) -> DsCompleteMatches -> (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 statics_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. @@ -407,7 +410,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/Rename/Names.hs ===================================== @@ -23,6 +23,7 @@ module GHC.Rename.Names ( getMinimalImports, printMinimalImports, renamePkgQual, renameRawPkgQual, + hscRenamePkgQual, hscRenameRawPkgQual, classifyGREs, ImportDeclUsage ) where @@ -332,7 +333,8 @@ rnImportDecl this_mod hsc_env <- getTopEnv unit_env <- hsc_unit_env <$> getTopEnv - let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual + query <- liftIO $ hscUnitIndexQuery hsc_env + let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual -- Check for self-import, which confuses the typechecker (#9032) -- ghc --make rejects self-import cycles already, but batch-mode may not @@ -442,14 +444,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 @@ -459,7 +461,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 unit_state mn (PackageName pkg_fs) + | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs) -> OtherPkg uid | otherwise @@ -474,6 +476,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of hpt_deps :: [UnitId] hpt_deps = homeUnitDepends unit_state +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'. @@ -2557,4 +2578,3 @@ addDupDeclErr gres@(gre :| _) checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name) - ===================================== 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 @@ -397,8 +398,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/Tc/Module.hs ===================================== @@ -265,9 +265,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 @@ -2122,19 +2124,21 @@ runTcInteractive hsc_env thing_inside , let local_gres = filter isLocalGRE gres , not (null local_gres) ]) ] - ; let getOrphansForModuleName m mb_pkg = do - iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg + ; let getOrphansForModuleName m pkg = do + iface <- loadSrcInterface (text "runTcInteractive") m NotBoot pkg pure $ mi_module iface : dep_orphs (mi_deps iface) getOrphansForModule m = do iface <- loadModuleInterface (text "runTcInteractive") m pure $ mi_module iface : dep_orphs (mi_deps iface) + ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111 IIModule n -> getOrphansForModule n - IIDecl i -> getOrphansForModuleName (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) + getOrphansForModuleName (unLoc (ideclName i)) qual ; (home_insts, home_fam_insts) <- liftIO $ UnitEnv.hugAllInstances (hsc_unit_env hsc_env) ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -971,7 +971,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 ===================================== @@ -69,15 +69,16 @@ 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 unit_env) + (mkQualModule unit_state index home_unit) (mkQualPackage unit_state) (mkPromTick ptc env) where unit_state = ue_homeUnitState unit_env + home_unit = ue_homeUnit unit_env mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName mkQualName env = qual_name where @@ -215,12 +216,10 @@ 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 -> UnitEnv -> QueryQualifyModule -mkQualModule unit_state unitEnv mod - -- Check whether the unit of the module is in the HomeUnitGraph. - -- If it is, then we consider this 'mod' to be "local" and don't - -- want to qualify it. - | HUG.memberHugUnit (moduleUnit mod) (ue_home_unit_graph unitEnv) = False +mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule +mkQualModule unit_state index mhome_unit mod + | Just home_unit <- mhome_unit + , isHomeModule home_unit mod = False | [(_, pkgconfig)] <- lookup, mkUnit pkgconfig == moduleUnit mod @@ -229,7 +228,7 @@ mkQualModule unit_state unitEnv 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 ===================================== @@ -174,6 +174,8 @@ data UnitEnv = UnitEnv , ue_namever :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix) + + , ue_index :: !UnitIndex } ueEPS :: UnitEnv -> IO ExternalPackageState @@ -182,6 +184,7 @@ 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 @@ -189,6 +192,7 @@ initUnitEnv cur_unit hug namever platform = do , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever + , ue_index } updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -181,7 +181,8 @@ 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 findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do @@ -194,11 +195,12 @@ 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 @@ -220,7 +222,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. | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual | elementOfUniqSet mod_name (finder_hiddenModules opts) = return (mkHomeHidden uid) | otherwise = @@ -231,11 +233,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_homeUnitState ue @@ -248,20 +250,21 @@ 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. -findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModuleNoHsc fc fopts units (Just home_unit) mod_name = +findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult +findPluginModuleNoHsc fc fopts units query (Just home_unit) mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` - findExposedPluginPackageModule fc fopts units mod_name -findPluginModuleNoHsc fc fopts units Nothing mod_name = - findExposedPluginPackageModule fc fopts units mod_name + findExposedPluginPackageModule fc fopts units query mod_name +findPluginModuleNoHsc fc fopts units query Nothing mod_name = + findExposedPluginPackageModule fc fopts units query mod_name findPluginModule :: HscEnv -> ModuleName -> IO FindResult findPluginModule hsc_env mod_name = do let fc = hsc_FC hsc_env let units = hsc_units hsc_env let mhome_unit = hsc_home_unit_maybe hsc_env - findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name + query <- hscUnitIndexQuery hsc_env + findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units query mhome_unit mod_name -- | A version of findExactModule which takes the exact parts of the HscEnv it needs @@ -333,15 +336,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 @@ +{-# LANGUAGE LambdaCase, RecordWildCards #-} -- (c) The University of Glasgow, 2006 - -- | Unit manipulation module GHC.Unit.State ( module GHC.Unit.Info, @@ -48,6 +48,14 @@ module GHC.Unit.State ( closeUnitDeps', mayThrowUnitErr, + UnitConfig (..), + UnitIndex (..), + UnitIndexQuery (..), + UnitVisibility (..), + VisibilityMap, + ModuleNameProvidersMap, + newUnitIndex, + -- * Module hole substitution ShHoleSubst, renameHoleUnit, @@ -578,10 +586,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId) -- | Find the UnitId which an import qualified by a package import comes from. -- Compared to 'lookupPackageName', this function correctly accounts for visibility, -- renaming and thinning. -resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId -resolvePackageImport unit_st mn pn = do +resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId +resolvePackageImport unit_st query mn pn = do -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc) - providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn + providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False -- 2. Get the UnitIds of the candidates let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers -- 3. Get the package names of the candidates @@ -639,14 +647,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) -initUnits logger dflags cached_dbs home_units = do +initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits logger dflags index cached_dbs home_units = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () (unit_state,dbs) <- withTiming logger (text "initializing unit database") forceUnitInfoMap - $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) + $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) @@ -1480,9 +1488,11 @@ validateDatabase cfg pkg_map1 = mkUnitState :: Logger + -> UnitId -> UnitConfig + -> UnitIndex -> IO (UnitState,[UnitDatabase UnitId]) -mkUnitState logger cfg = do +mkUnitState logger unit cfg index = do {- Plan. @@ -1538,15 +1548,9 @@ mkUnitState logger cfg = do -- if databases have not been provided, read the database flags raw_dbs <- case unitConfigDBCache cfg of - Nothing -> readUnitDatabases logger cfg + Nothing -> readDatabases index logger unit cfg Just dbs -> return dbs - -- distrust all units if the flag is set - let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) } - dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs - | otherwise = raw_dbs - - -- This, and the other reverse's that you will see, are due to the fact that -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order -- than they are on the command line. @@ -1558,15 +1562,20 @@ mkUnitState logger cfg = do let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags -- Merge databases together, without checking validity - (pkg_map1, prec_map) <- mergeDatabases logger dbs + (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs -- Now that we've merged everything together, prune out unusable -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1 reportCycles logger sccs reportUnusable logger unusable + -- distrust all units if the flag is set + let distrust_all info = info {unitIsTrusted = False} + pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs + | otherwise = initial_dbs + -- Apply trust flags (these flags apply regardless of whether -- or not packages are visible or not) pkgs1 <- mayThrowUnitErr @@ -1671,6 +1680,9 @@ mkUnitState logger cfg = do -- likely to actually happen. return (updateVisibilityMap wired_map plugin_vis_map2) + (moduleNameProvidersMap, pluginModuleNameProvidersMap) <- + computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable) + let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p) | p <- pkgs2 ] @@ -1683,8 +1695,6 @@ mkUnitState logger cfg = do req_ctx = mapUniqMap (Set.toList) $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map)) - - -- -- Here we build up a set of the packages mentioned in -package -- flags on the command line; these are called the "preload" -- packages. we link these packages in eagerly. The preload set @@ -1707,10 +1717,6 @@ mkUnitState logger cfg = do $ closeUnitDeps pkg_db $ zip (map toUnitId preload3) (repeat Nothing) - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map - mod_map2 = mkUnusableModuleNameProvidersMap unusable - mod_map = mod_map2 `plusUniqMap` mod_map1 - -- Force the result to avoid leaking input parameters let !state = UnitState { preloadUnits = dep_preload @@ -1718,8 +1724,8 @@ mkUnitState logger cfg = do , homeUnitDepends = Set.toList home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet - , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + , moduleNameProvidersMap + , pluginModuleNameProvidersMap , packageNameMap = pkgname_map , wireMap = wired_map , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] @@ -1892,6 +1898,76 @@ addListTo = foldl' merge mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin mkModMap pkg mod = unitUniqMap (mkModule pkg mod) +-- ----------------------------------------------------------------------------- +-- Index + +data UnitIndexQuery = + UnitIndexQuery { + findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin), + moduleProviders :: UnitState -> ModuleNameProvidersMap + } + +data UnitIndex = + UnitIndex { + unitIndexQuery :: UnitId -> IO UnitIndexQuery, + readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId], + computeProviders :: + Logger -> + UnitId -> + UnitConfig -> + VisibilityMap -> + VisibilityMap -> + UnitInfoMap -> + UnitInfoMap -> + ModuleNameProvidersMap -> + IO (ModuleNameProvidersMap, ModuleNameProvidersMap) + } + +queryFindOriginDefault :: + UnitState -> + ModuleName -> + Bool -> + Maybe (UniqMap Module ModuleOrigin) +queryFindOriginDefault UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins = + lookupUniqMap source name + where + source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap + +newUnitIndexQuery :: UnitId -> IO UnitIndexQuery +newUnitIndexQuery _ = + pure UnitIndexQuery { + findOrigin = queryFindOriginDefault, + moduleProviders = moduleNameProvidersMap + } + +readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId] +readDatabasesDefault logger _ cfg = + readUnitDatabases logger cfg + +computeProvidersDefault :: + Logger -> + UnitId -> + UnitConfig -> + VisibilityMap -> + VisibilityMap -> + UnitInfoMap -> + UnitInfoMap -> + ModuleNameProvidersMap -> + IO (ModuleNameProvidersMap, ModuleNameProvidersMap) +computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable = + pure (mod_map, plugin_mod_map) + where + mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map + mod_map = unusable `plusUniqMap` mod_map1 + plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + +newUnitIndex :: IO UnitIndex +newUnitIndex = + pure UnitIndex { + unitIndexQuery = newUnitIndexQuery, + readDatabases = readDatabasesDefault, + computeProviders = computeProvidersDefault + } -- ----------------------------------------------------------------------------- -- Package Utils @@ -1899,10 +1975,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 (lookupUnit pkgs (moduleUnit m))) @@ -1928,18 +2005,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} -> @@ -1955,19 +2038,21 @@ lookupModulePackage pkgs mn mfs = _ -> Nothing lookupPluginModuleWithSuggestions :: UnitState + -> UnitIndexQuery -> ModuleName -> PkgQual -> LookupResult -lookupPluginModuleWithSuggestions pkgs - = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs) +lookupPluginModuleWithSuggestions pkgs query name + = lookupModuleWithSuggestions' pkgs query name True lookupModuleWithSuggestions' :: UnitState - -> ModuleNameProvidersMap + -> UnitIndexQuery -> ModuleName + -> Bool -> PkgQual -> LookupResult -lookupModuleWithSuggestions' pkgs mod_map m mb_pn - = case lookupUniqMap mod_map m of +lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn + = case findOrigin query pkgs m onlyPlugins of Nothing -> LookupNotFound suggestions Just xs -> case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of @@ -2028,16 +2113,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn all_mods :: [(String, ModuleSuggestion)] -- All modules all_mods = sortBy (comparing fst) $ [ (moduleNameString m, suggestion) - | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) + | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs) , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) ] getSuggestion name (mod, origin) = (if originVisible origin then SuggestVisible else SuggestHidden) name mod origin -listVisibleModuleNames :: UnitState -> [ModuleName] -listVisibleModuleNames state = - map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state))) +listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName] +listVisibleModuleNames unit_state query = + map fst (filter visible (nonDetUniqMapToList (moduleProviders query unit_state))) where visible (_, ms) = anyUniqMap originVisible ms -- | Takes a list of UnitIds (and their "parent" dependency, used for error ===================================== ghc/GHCi/UI.hs ===================================== @@ -87,6 +87,7 @@ import qualified GHC.Parser.Header as Header import GHC.Types.PkgQual import GHC.Unit +import GHC.Unit.State (UnitIndex) import GHC.Unit.Finder as Finder import GHC.Unit.Module.Graph (filterToposortToModules) import GHC.Unit.Module.ModSummary @@ -764,8 +765,9 @@ installInteractiveHomeUnits = do S.insert interactiveSessionUnitId $ hsc_all_home_unit_ids hsc_env - ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids cached_unit_dbs - ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids cached_unit_dbs + let unit_index = hscUnitIndex hsc_env + ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt unit_index all_unit_ids cached_unit_dbs + ghciSessionUnit <- setupHomeUnitFor logger dflagsSession unit_index all_unit_ids cached_unit_dbs let -- Setup up the HUG, install the interactive home units withInteractiveUnits = @@ -787,10 +789,10 @@ installInteractiveHomeUnits = do pure () where - setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv - setupHomeUnitFor logger dflags all_home_units cached_unit_dbs = do + setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> UnitIndex -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv + setupHomeUnitFor logger dflags index all_home_units cached_unit_dbs = do (dbs,unit_state,home_unit,_mconstants) <- - liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units + liftIO $ initUnits logger dflags index (Just cached_unit_dbs) all_home_units hpt <- liftIO emptyHomePackageTable pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit)) @@ -4087,19 +4089,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 completeModule = wrapIdentCompleterMod $ \w -> do hsc_env <- GHC.getSession - let pkg_mods = allVisibleModules (hsc_units hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + let pkg_mods = allVisibleModules (hsc_units hsc_env) query loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do hsc_env <- GHC.getSession + query <- liftIO $ hscUnitIndexQuery hsc_env modules <- case m of Just '-' -> do imports <- GHC.getContext return $ map iiModuleName imports _ -> do - let pkg_mods = allVisibleModules (hsc_units hsc_env) + let pkg_mods = allVisibleModules (hsc_units hsc_env) query loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules return $ loaded_mods ++ pkg_mods return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules @@ -4167,8 +4171,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor -- | Return a list of visible module names for autocompletion. -- (NB: exposed != visible) -allVisibleModules :: UnitState -> [ModuleName] -allVisibleModules unit_state = listVisibleModuleNames unit_state +allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName] +allVisibleModules us query = listVisibleModuleNames us query completeExpression = completeQuotedWord (Just '\\') "\"" listFiles completeIdentifier ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -365,7 +365,6 @@ unsetOption opt = do st <- getGHCiState setGHCiState (st{ options = filter (/= opt) (options st) }) - -- | Run a single Haskell expression runStmt :: GhciMonad m ===================================== ghc/GHCi/UI/Print.hs ===================================== @@ -18,6 +18,7 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Errors import GHC.Driver.Config.Diagnostic +import GHC.Driver.Env (hsc_unit_env, hscUnitIndexQuery) import GHC.Utils.Logger import GHC.Utils.Error @@ -45,10 +46,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do where mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) = - withSession $ \ hsc_env -> - let unit_env = hsc_unit_env hsc_env - ptc = initPromotionTickContext dflags - in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env + withSession $ \ hsc_env -> do + query <- liftIO $ hscUnitIndexQuery hsc_env + let unit_env = hsc_unit_env hsc_env + ptc = initPromotionTickContext dflags + return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env printForUser :: GhcMonad m => SDoc -> m () printForUser doc = do ===================================== ghc/Main.hs ===================================== @@ -339,6 +339,7 @@ doMake units targets = do ok_flag <- GHC.load LoadAllTargets when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) + -- --------------------------------------------------------------------------- -- Various banners and verbosity output. @@ -524,4 +525,3 @@ abiHash strs = do f <- fingerprintBinMem bh putStrLn (showPpr dflags f) - View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64b3f6f358ce0fc9ee8428cb8739c9ff... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64b3f6f358ce0fc9ee8428cb8739c9ff... You're receiving this email because of your account on gitlab.haskell.org.