Torsten Schmits pushed to branch wip/torsten.schmits/mwb-perf-tuning-2 at Glasgow Haskell Compiler / GHC Commits: 44e58cbd by Matthew Pickering at 2025-12-08T17:48:09+01:00 Use ModuleGraph for cache - - - - - e24f2f02 by Matthew Pickering at 2025-12-08T17:48:09+01:00 OsPath for Map - - - - - 0a9fd4a6 by Matthew Pickering at 2025-12-08T17:48:09+01:00 Set hpt deps - - - - - 4d5286c1 by Matthew Pickering at 2025-12-08T17:48:09+01:00 HomeUnitMap - - - - - c293535e by Matthew Pickering at 2025-12-08T17:48:09+01:00 Use a name provider map for home packages - - - - - 444ba945 by Torsten Schmits at 2025-12-08T17:48:09+01:00 disable home unit closure check - - - - - afa9ff5f by Torsten Schmits at 2025-12-08T17:48:09+01:00 WIP: unit index - - - - - 26 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/Linker/Loader.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/Module/Graph.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - ghc/Main.hs - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails) +import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env) let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env) + index <- hscUnitIndex <$> getSession + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env) updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let upd hue = @@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do then do -- additionally, set checked dflags so we don't lose fixes old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession + ue_index <- hscUnitIndex <$> getSession home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv @@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = unitEnv_keys (ue_home_unit_graph old_unit_env) - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants pure HomeUnitEnv @@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit old_unit_env , ue_eps = ue_eps old_unit_env + , ue_index } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) @@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env -> getNamePprCtx :: GhcMonad m => m NamePprCtx getNamePprCtx = withSession $ \hsc_env -> do - return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { @@ -1474,7 +1478,8 @@ mkNamePprCtxForModule :: ModuleInfo -> m NamePprCtx mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) + query <- liftIO $ hscUnitIndexQuery hsc_env + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) ptc = initPromotionTickContext (hsc_dflags hsc_env) return name_ppr_ctx @@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual -renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p) +renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual -renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p) +renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p -- | Like 'findModule', but differs slightly when the module refers to -- a source file, and the file has not been loaded via 'load'. In @@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags - res <- findExposedPackageModule fc fopts units mod_name NoPkgQual + query <- hscUnitIndexQuery hsc_env + res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod , mg_rdr_env = rdr_env }) = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars uniq_tag = 's' + ; query <- hscUnitIndexQuery hsc_env + ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod name_ppr_ctx loc $ @@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod , gwib_isBoot = NotBoot }) hpt_rule_base = mkRuleBase home_pkg_rules - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to @@ -459,6 +460,7 @@ doCorePass pass guts = do dflags <- getDynFlags us <- getUniqueSupplyM p_fam_env <- getPackageFamInstEnv + query <- liftIO $ hscUnitIndexQuery hsc_env let platform = targetPlatform dflags let fam_envs = (p_fam_env, mg_fam_inst_env guts) let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } @@ -471,6 +473,7 @@ doCorePass pass guts = do mkNamePprCtx (initPromotionTickContext dflags) (hsc_unit_env hsc_env) + query rdr_env ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -430,6 +430,7 @@ addUnit u = do logger <- getLogger let dflags0 = hsc_dflags hsc_env let old_unit_env = hsc_unit_env hsc_env + ue_index = hscUnitIndex hsc_env newdbs <- case ue_unit_dbs old_unit_env of Nothing -> panic "addUnit: called too early" Just dbs -> @@ -438,7 +439,7 @@ addUnit u = do , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env) + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env) -- update platform constants dflags <- liftIO $ updatePlatformConstants dflags0 mconstants @@ -453,6 +454,7 @@ addUnit u = do (homeUnitId home_unit) (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env + , ue_index } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } @@ -871,6 +873,8 @@ hsModuleToModSummary home_keys pn hsc_src modname hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + query <- liftIO $ hscUnitIndexQuery hsc_env + -- Also copied from 'getImports' let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps @@ -883,7 +887,7 @@ hsModuleToModSummary home_keys pn hsc_src modname implicit_imports = mkPrelImports modname loc implicit_prelude imps - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -7,6 +7,8 @@ module GHC.Driver.Env , hsc_home_unit , hsc_home_unit_maybe , hsc_units + , hscUnitIndex + , hscUnitIndexQuery , hsc_HPT , hsc_HUE , hsc_HUG @@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState hsc_units = ue_units . hsc_unit_env +hscUnitIndex :: HscEnv -> UnitIndex +hscUnitIndex = ue_index . hsc_unit_env + +hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery +hscUnitIndexQuery hsc_env = + unitIndexQuery (hscActiveUnitId hsc_env) (hscUnitIndex hsc_env) + hsc_HPT :: HscEnv -> HomePackageTable hsc_HPT = ue_hpt . hsc_unit_env ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -2573,9 +2573,10 @@ hscTidy hsc_env guts = do $! {-# SCC "CoreTidy" #-} tidyProgram opts guts -- post tidy pretty-printing and linting... + query <- hscUnitIndexQuery hsc_env let tidy_rules = md_rules details let all_tidy_binds = cg_binds cgguts - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts) + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts) ptc = initPromotionTickContext (hsc_dflags hsc_env) endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -113,6 +113,8 @@ import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map import qualified Data.Set as Set +import GHC.Data.OsPath (OsPath) +import qualified GHC.Data.OsPath as OsPath import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) import qualified GHC.Conc as CC import Control.Concurrent.MVar @@ -187,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 @@ -244,7 +247,7 @@ depanalPartial excluded_mods allow_dup_roots = do liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) (errs, graph_nodes) <- liftIO $ downsweep - hsc_env (mgModSummaries old_graph) + hsc_env (mgModSummaries old_graph) Nothing excluded_mods allow_dup_roots let mod_graph = mkModuleGraph graph_nodes @@ -510,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 @@ -1537,6 +1540,10 @@ warnUnnecessarySourceImports sccs = do -- an import of this module mean. type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary] +moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode +moduleGraphNodeMap graph = + M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph] + ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) @@ -1555,6 +1562,8 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv downsweep :: HscEnv -> [ModSummary] -- ^ Old summaries + -> Maybe ModuleGraph + -- ^ Existing module graph to reuse cached nodes from -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have @@ -1564,10 +1573,10 @@ downsweep :: HscEnv -- The non-error elements of the returned list all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots = do +downsweep hsc_env old_summaries old_graph excl_mods allow_dup_roots = do n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) new <- rootSummariesParallel n_jobs hsc_env summary - downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new + downsweep_imports hsc_env old_summary_map old_graph excl_mods allow_dup_roots new where summary = getRootSummary excl_mods old_summary_map @@ -1576,22 +1585,23 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do -- file was used in. -- Reuse these if we can because the most expensive part of downsweep is -- reading the headers. - old_summary_map :: M.Map (UnitId, FilePath) ModSummary + old_summary_map :: M.Map (UnitId, OsPath) ModSummary old_summary_map = - M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] + M.fromList [((ms_unitid ms, OsPath.unsafeEncodeUtf (msHsFilePath ms)), ms) | ms <- old_summaries] downsweep_imports :: HscEnv - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary + -> Maybe ModuleGraph -> [ModuleName] -> Bool -> ([(UnitId, DriverMessages)], [ModSummary]) -> IO ([DriverMessages], [ModuleGraphNode]) -downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk) +downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (root_errs, rootSummariesOk) = do let root_map = mkRootMap rootSummariesOk checkDuplicates root_map - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map) - let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) + let done0 = maybe M.empty moduleGraphNodeMap old_graph + (deps, map0) <- loopSummaries rootSummariesOk (done0, root_map) let unit_env = hsc_unit_env hsc_env let tmpfs = hsc_tmpfs hsc_env @@ -1601,7 +1611,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) all_nodes = downsweep_nodes ++ unit_nodes all_errs = all_root_errs ++ downsweep_errs ++ other_errs - all_root_errs = closure_errs ++ map snd root_errs + all_root_errs = map snd root_errs -- if we have been passed -fno-code, we enable code generation -- for dependencies of modules that have -XTemplateHaskell, @@ -1721,7 +1731,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro getRootSummary :: [ModuleName] -> - M.Map (UnitId, FilePath) ModSummary -> + M.Map (UnitId, OsPath) ModSummary -> HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary) @@ -2067,7 +2077,7 @@ mkRootMap summaries = Map.fromListWith (flip (++)) summariseFile :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary -- old summaries + -> M.Map (UnitId, OsPath) ModSummary -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) @@ -2076,7 +2086,7 @@ summariseFile summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries = do let location = ms_location $ old_summary @@ -2097,6 +2107,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf where -- change the main active unit so all operations happen relative to the given unit hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + src_fn_os = OsPath.unsafeEncodeUtf src_fn -- src_fn does not necessarily exist on the filesystem, so we need to -- check what kind of target we are dealing with get_src_hash = case maybe_buf of @@ -2186,7 +2197,7 @@ data SummariseResult = summariseModule :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised @@ -2247,7 +2258,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p Right ms -> FoundHome ms new_summary_cache_check loc mod src_fn h - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map = -- check the hash on the source file, and -- return the cached summary if it hasn't changed. If the @@ -2258,6 +2269,8 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p Nothing -> checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h | otherwise = new_summary loc mod src_fn h + where + src_fn_os = OsPath.unsafeEncodeUtf src_fn new_summary :: ModLocation -> Module @@ -2385,7 +2398,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps - let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) let pi_srcimps = rn_imps pi_srcimps' let pi_theimps = rn_imps pi_theimps' ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -696,9 +696,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do buf <- hGetStringBuffer input_fn + query <- hscUnitIndexQuery hsc_env let imp_prelude = xopt LangExt.ImplicitPrelude dflags popts = initParserOpts dflags - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn)) eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -149,7 +149,8 @@ deSugar hsc_env = do { let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env ptc = initPromotionTickContext (hsc_dflags hsc_env) - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + ; query <- hscUnitIndexQuery hsc_env + ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env ; withTiming logger (text "Desugar"<+>brackets (ppr mod)) (const ()) $ ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -89,6 +89,7 @@ import GHC.Data.FastString import GHC.Unit.Env import GHC.Unit.External +import GHC.Unit.State (UnitIndexQuery) import GHC.Unit.Module import GHC.Unit.Module.ModGuts @@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env ++ eps_complete_matches eps -- from imports -- re-use existing next_wrapper_num to ensure uniqueness next_wrapper_num_var = tcg_next_wrapper_num tcg_env - ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc + ; query <- liftIO $ hscUnitIndexQuery hsc_env + ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num_var complete_matches } @@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds ; next_wrapper_num <- newIORef emptyModuleEnv ; msg_var <- newIORef emptyMessages ; eps <- liftIO $ hscEPS hsc_env + ; query <- liftIO $ hscUnitIndexQuery hsc_env ; let unit_env = hsc_unit_env hsc_env type_env = typeEnvFromEntities ids tycons patsyns fam_insts ptc = initPromotionTickContext (hsc_dflags hsc_env) @@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds bindsToIds (Rec binds) = map fst binds ids = concatMap bindsToIds binds - envs = mkDsEnvs unit_env this_mod rdr_env type_env + envs = mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches ; runDs hsc_env envs thing_inside @@ -342,12 +345,12 @@ initTcDsForSolver thing_inside Just ret -> pure ret Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } -mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv +mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> PromotionTickContext -> IORef (Messages DsMessage) -> IORef CostCentreState -> IORef (ModuleEnv Int) -> CompleteMatches -> (DsGblEnv, DsLclEnv) -mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var +mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs" -- Failing tests here are `ghci` and `T11985` if you get this wrong. @@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var , ds_fam_inst_env = fam_inst_env , ds_gbl_rdr_env = rdr_env , ds_if_env = (if_genv, if_lenv) - , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env + , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env , ds_msgs = msg_var , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface = do res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary) - res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) + query <- liftIO $ hscUnitIndexQuery hsc_env + res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of Left recomp -> return $ NeedsRecompile recomp Right es -> do ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -355,7 +355,7 @@ loadCmdLineLibs' interp hsc_env pls = snd <$> let hsc' = hscSetActiveUnitId uid hsc_env -- Load potential dependencies first (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) - (homeUnitDepends (hsc_units hsc')) + (Set.toList (homeUnitDepends (hsc_units hsc'))) pls'' <- loadCmdLineLibs'' interp hsc' pls' return $ (Set.insert uid done', pls'') ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -27,6 +27,7 @@ module GHC.Rename.Names ( getMinimalImports, printMinimalImports, renamePkgQual, renameRawPkgQual, + hscRenamePkgQual, hscRenameRawPkgQual, classifyGREs, ImportDeclUsage, ) where @@ -337,7 +338,8 @@ rnImportDecl this_mod hsc_env <- getTopEnv unit_env <- hsc_unit_env <$> getTopEnv - let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual + query <- liftIO $ hscUnitIndexQuery hsc_env + let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual -- Check for self-import, which confuses the typechecker (#9032) -- ghc --make rejects self-import cycles already, but batch-mode may not @@ -447,14 +449,14 @@ rnImportDecl this_mod -- | Rename raw package imports -renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual -renameRawPkgQual unit_env mn = \case +renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual +renameRawPkgQual unit_env query mn = \case NoRawPkgQual -> NoPkgQual - RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p)) + RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p)) -- | Rename raw package imports -renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual -renamePkgQual unit_env mn mb_pkg = case mb_pkg of +renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual +renamePkgQual unit_env query mn mb_pkg = case mb_pkg of Nothing -> NoPkgQual Just pkg_fs | Just uid <- homeUnitId <$> ue_homeUnit unit_env @@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names -> ThisPkg uid - | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs) + | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs) -> OtherPkg uid | otherwise @@ -472,13 +474,35 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- not really correct as pkg_fs is unlikely to be a valid unit-id but -- we will report the failure later... where - home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps + home_names = + [ (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env))) + | uid <- S.toList hpt_deps + ] units = ue_units unit_env - hpt_deps :: [UnitId] + hpt_deps :: S.Set 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 @@ -138,7 +142,7 @@ ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid]) loop acc (uid:uids) | uid `Set.member` acc = loop acc uids | otherwise = - let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env)) + let hue = Set.toList (homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))) in loop (Set.insert uid acc) (hue ++ uids) ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -67,8 +67,9 @@ import Control.Monad import Data.Time import qualified Data.Map as M import GHC.Driver.Env - ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) ) + ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery ) import GHC.Driver.Config.Finder +import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap) import qualified Data.Set as Set type FileExt = String -- Filename extension @@ -161,28 +162,36 @@ 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 + let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env) + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv + -> UnitIndexQuery + -> ModuleNameHomeMap -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import - | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) + | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os) | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where + (complete_units, module_name_map) = home_module_map + module_home_units = M.findWithDefault Set.empty mod_name module_name_map + current_unit_id = homeUnitId <$> mhome_unit all_opts = case mhome_unit of - Nothing -> other_fopts - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + Nothing -> other_fopts_list + Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list + other_fopts_map = M.fromList other_fopts_list home_import = case mhome_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name @@ -193,7 +202,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 home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual | mod_name `Set.member` finder_hiddenModules opts = return (mkHomeHidden uid) | otherwise = @@ -202,32 +211,44 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as -- that is not the same!! home_import is first because we need to look within ourselves -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts) + any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list) - 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 Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue - hpt_deps :: [UnitId] + hpt_deps :: Set.Set UnitId hpt_deps = homeUnitDepends units - other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps + dep_providers = Set.intersection module_home_units hpt_deps + known_other_uids = + let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id + in Set.toList providers + unknown_units = + let candidates = Set.difference hpt_deps complete_units + excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id + in Set.toList (Set.difference candidates excluded) + other_home_uids = known_other_uids ++ unknown_units + other_fopts_list = + [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue))) + | uid <- other_home_uids + ] -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified. -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModule fc fopts units (Just home_unit) mod_name = +findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult +findPluginModule fc fopts units query (Just home_unit) mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` - findExposedPluginPackageModule fc fopts units mod_name -findPluginModule fc fopts units Nothing mod_name = - findExposedPluginPackageModule fc fopts units mod_name + findExposedPluginPackageModule fc fopts units query mod_name +findPluginModule fc fopts units query Nothing mod_name = + findExposedPluginPackageModule fc fopts units query mod_name -- | Locate a specific 'Module'. The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out @@ -283,15 +304,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/Module/Graph.hs ===================================== @@ -18,6 +18,8 @@ module GHC.Unit.Module.Graph , mgModSummaries , mgModSummaries' , mgLookupModule + , ModuleNameHomeMap + , mgHomeModuleMap , showModMsg , moduleGraphNodeModule , moduleGraphNodeModSum @@ -153,23 +155,31 @@ instance Outputable ModNodeKeyWithUid where -- check that the module and its hs-boot agree. -- -- The graph is not necessarily stored in topologically-sorted order. Use +type ModuleNameHomeMap = (Set UnitId, Map.Map ModuleName (Set UnitId)) + -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. data ModuleGraph = ModuleGraph { mg_mss :: [ModuleGraphNode] , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) -- A cached transitive dependency calculation so that a lot of work is not -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances) + , mg_home_map :: ModuleNameHomeMap + -- ^ For each module name, which home-unit UnitIds define it together with the set of units for which the listing is complete. } -- | Map a function 'f' over all the 'ModSummaries'. -- To preserve invariants 'f' can't change the isBoot status. mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg - { mg_mss = flip fmap mg_mss $ \case - InstantiationNode uid iuid -> InstantiationNode uid iuid - LinkNode uid nks -> LinkNode uid nks - ModuleNode deps ms -> ModuleNode deps (f ms) + { mg_mss = new_mss + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = + flip fmap mg_mss $ \case + InstantiationNode uid iuid -> InstantiationNode uid iuid + LinkNode uid nks -> LinkNode uid nks + ModuleNode deps ms -> ModuleNode deps (f ms) unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph unionMG a b = @@ -177,11 +187,27 @@ unionMG a b = in ModuleGraph { mg_mss = new_mss , mg_graph = mkTransDeps new_mss + , mg_home_map = mkHomeModuleMap new_mss } mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False +mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap +mkHomeModuleMap nodes = + (complete_units, provider_map) + where + provider_map = + Map.fromListWith Set.union + [ (ms_mod_name ms, Set.singleton (ms_unitid ms)) + | ModuleNode _ ms <- nodes + ] + complete_units = + Set.fromList + [ ms_unitid ms + | ModuleNode _ ms <- nodes + ] + mgModSummaries :: ModuleGraph -> [ModSummary] mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ] @@ -200,8 +226,11 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss = Just ms go _ = Nothing +mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap +mgHomeModuleMap = mg_home_map + emptyMG :: ModuleGraph -emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) +emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (Set.empty, Map.empty) isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool isTemplateHaskellOrQQNonBoot ms = @@ -213,9 +242,12 @@ isTemplateHaskellOrQQNonBoot ms = -- not an element of the ModuleGraph. extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph extendMG ModuleGraph{..} deps ms = ModuleGraph - { mg_mss = ModuleNode deps ms : mg_mss - , mg_graph = mkTransDeps (ModuleNode deps ms : mg_mss) + { mg_mss = new_mss + , mg_graph = mkTransDeps new_mss + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = ModuleNode deps ms : mg_mss extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph extendMGInst mg uid depUnitId = mg ===================================== 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, newIORef, readIORef) -- --------------------------------------------------------------------------- -- The Unit state @@ -458,7 +469,7 @@ data UnitState = UnitState { -- -Wunused-packages warning. explicitUnits :: [(Unit, Maybe PackageArg)], - homeUnitDepends :: [UnitId], + homeUnitDepends :: Set UnitId, -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want @@ -493,7 +504,7 @@ emptyUnitState = UnitState { unwireMap = emptyUniqMap, preloadUnits = [], explicitUnits = [], - homeUnitDepends = [], + homeUnitDepends = Set.empty, moduleNameProvidersMap = emptyUniqMap, pluginModuleNameProvidersMap = emptyUniqMap, requirementContext = emptyUniqMap, @@ -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 unit_st mn False -- 2. Get the UnitIds of the candidates let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers -- 3. Get the package names of the candidates @@ -638,14 +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 (homeUnitId_ dflags) (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. @@ -1484,9 +1495,11 @@ validateDatabase cfg pkg_map1 = mkUnitState :: Logger + -> UnitId -> UnitConfig + -> UnitIndex -> IO (UnitState,[UnitDatabase UnitId]) -mkUnitState logger cfg = do +mkUnitState logger unit cfg index = do {- Plan. @@ -1542,15 +1555,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 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. @@ -1561,169 +1568,17 @@ 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) - - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map - mod_map2 = mkUnusableModuleNameProvidersMap unusable - mod_map = mod_map2 `plusUniqMap` mod_map1 + (moduleNameProvidersMap, pluginModuleNameProvidersMap, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger unit cfg raw_dbs other_flags -- Force the result to avoid leaking input parameters let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs - , homeUnitDepends = Set.toList home_unit_deps + , homeUnitDepends = home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet - , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + , moduleNameProvidersMap + , pluginModuleNameProvidersMap , packageNameMap = pkgname_map , wireMap = wired_map , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] @@ -1896,6 +1751,263 @@ 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), + index_all :: UnitState -> ModuleNameProvidersMap + } + +data UnitIndex = + UnitIndex { + query :: UnitId -> IO UnitIndexQuery, + readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId], + update :: + Logger -> + UnitId -> + UnitConfig -> + [UnitDatabase UnitId] -> + [PackageFlag] -> + IO ( + ModuleNameProvidersMap, + ModuleNameProvidersMap, + UnitInfoMap, + [(Unit, Maybe PackageArg)], + [UnitId], + UniqMap ModuleName [InstantiatedModule], + UniqFM PackageName UnitId, + WiringMap + ) + } + +unitIndexQuery :: + MonadIO m => + UnitId -> + UnitIndex -> + m UnitIndexQuery +unitIndexQuery unit index = liftIO (index.query unit) + +data UnitIndexBackend = + UnitIndexBackend { + moduleNameProviders :: !ModuleNameProvidersMap, + pluginModuleNameProviders :: !ModuleNameProvidersMap + } + +newUnitIndexBackend :: UnitIndexBackend +newUnitIndexBackend = + UnitIndexBackend { + moduleNameProviders = mempty, + pluginModuleNameProviders = mempty + } + +queryFindOriginDefault :: + UnitIndexBackend -> + 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 :: + MonadIO m => + IORef UnitIndexBackend -> + UnitId -> + m UnitIndexQuery +newUnitIndexQuery ref _ = do + state <- liftIO $ readIORef ref + pure UnitIndexQuery { + findOrigin = queryFindOriginDefault state, + index_all = \ s -> s.moduleNameProvidersMap + } + +updateIndexDefault :: + Logger -> + UnitId -> + UnitConfig -> + [UnitDatabase UnitId] -> + [PackageFlag] -> + IO (ModuleNameProvidersMap, ModuleNameProvidersMap, UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap) +updateIndexDefault 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 + + -- 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) + + let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map + mod_map2 = mkUnusableModuleNameProvidersMap unusable + mod_map = mod_map2 `plusUniqMap` mod_map1 + pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + pure (mod_map, pluginModuleNameProviders, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) + +readDatabasesDefault :: Logger -> UnitId -> 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 + } -- ----------------------------------------------------------------------------- -- Package Utils @@ -1903,10 +2015,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 +2046,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 +2079,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 pkgs m onlyPlugins of Nothing -> LookupNotFound suggestions Just xs -> case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of @@ -2033,16 +2154,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 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 (query.index_all unit_state))) where visible (_, ms) = anyUniqMap originVisible ms -- | Takes a list of UnitIds (and their "parent" dependency, used for error ===================================== ghc/GHCi/UI.hs ===================================== @@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 completeModule = wrapIdentCompleterMod $ \w -> do hsc_env <- GHC.getSession - let pkg_mods = allVisibleModules (hsc_units hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + let pkg_mods = allVisibleModules (hsc_units hsc_env) query loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do hsc_env <- GHC.getSession + query <- liftIO $ hscUnitIndexQuery hsc_env modules <- case m of Just '-' -> do imports <- GHC.getContext return $ map iiModuleName imports _ -> do - let pkg_mods = allVisibleModules (hsc_units hsc_env) + let pkg_mods = allVisibleModules (hsc_units hsc_env) query loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ loaded_mods ++ pkg_mods return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules @@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor -- | Return a list of visible module names for autocompletion. -- (NB: exposed != visible) -allVisibleModules :: UnitState -> [ModuleName] -allVisibleModules unit_state = listVisibleModuleNames unit_state +allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName] +allVisibleModules us query = listVisibleModuleNames us query completeExpression = completeQuotedWord (Just '\\') "\"" listFiles completeIdentifier ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do where mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) = - withSession $ \ hsc_env -> + withSession $ \ hsc_env -> do + query <- liftIO $ hscUnitIndexQuery hsc_env let unit_env = hsc_unit_env hsc_env ptc = initPromotionTickContext dflags - in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env + return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env printForUser :: GhcMonad m => SDoc -> m () printForUser doc = do ===================================== ghc/Main.hs ===================================== @@ -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 @@ -892,7 +893,7 @@ checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc () checkUnitCycles dflags graph = processSCCs sccs where mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId - mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue)) + mkNode (uid, hue) = DigraphNode uid uid (Set.toList (homeUnitDepends (homeUnitEnv_units hue))) nodes = map mkNode (unitEnv_elts graph) sccs = stronglyConnCompFromEdgedVerticesOrd nodes ===================================== testsuite/tests/ghc-api/downsweep/OldModLocation.hs ===================================== @@ -47,13 +47,13 @@ main = do liftIO $ do - _emss <- downsweep hsc_env [] [] False + _emss <- downsweep hsc_env [] Nothing [] False flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) createDirectoryIfMissing False "mydir" renameFile "B.hs" "mydir/B.hs" - (_, nodes) <- downsweep hsc_env [] [] False + (_, nodes) <- downsweep hsc_env [] Nothing [] False -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with -- (ms_location old_summary) like summariseFile used to instead of ===================================== testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs ===================================== @@ -168,7 +168,7 @@ go label mods cnd = setTargets [tgt] hsc_env <- getSession - (_, nodes) <- liftIO $ downsweep hsc_env [] [] False + (_, nodes) <- liftIO $ downsweep hsc_env [] Nothing [] False it label $ cnd (mapMaybe moduleGraphNodeModSum nodes) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/735dc6a73e0f3f87f56e54db7e5fd35... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/735dc6a73e0f3f87f56e54db7e5fd35... You're receiving this email because of your account on gitlab.haskell.org.