[Git][ghc/ghc][master] driver: Use ModuleGraph for oneshot and --make mode

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d47bf776 by Matthew Pickering at 2025-04-14T16:44:41+01:00 driver: Use ModuleGraph for oneshot and --make mode This patch uses the `hsc_mod_graph` field for both oneshot and --make mode. Therefore, if part of the compiler requires usage of the module graph, you do so in a uniform way for the two different modes. The `ModuleGraph` describes the relationship between the modules in the home package and units in external packages. The `ModuleGraph` can be queried when information about the transitive closure of a package is needed. For example, the primary use of the ModuleGraph from within the compiler is in the loader, which needs to know the transitive closure of a module so it can load all the relevant objects for evaluation. In --make mode, downsweep computes the ModuleGraph before any compilation starts. In oneshot mode, a thunk is created at the start of compilation, which when forced will compute the module graph beneath the current module. The thunk is only forced at the moment when the user uses Template Haskell. Finally, there are some situations where we need to discover what dependencies to load but haven't loaded a module graph at all. In this case, there is a fallback which computes the transitive closure on the fly and doesn't cache the result. Presumably if you are going to call getLinkDeps a lot, you would compute the right ModuleGraph before you started. Importantly, this removes the ExternalModuleGraph abstraction. This was quite awkward to work with since it stored information about the home package inside the EPS. This patch will also be very useful when implementing explicit level imports, which requires more significant use of the module graph in order to determine which level instances are available at. Towards #25795 ------------------------- Metric Decrease: MultiLayerModulesTH_Make MultiLayerModulesTH_OneShot ------------------------- - - - - - 26 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeAction.hs - + compiler/GHC/Driver/Messager.hs - compiler/GHC/Driver/Pipeline.hs-boot - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Finder.hs - − compiler/GHC/Unit/Module/External/Graph.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/ModNodeKey.hs - compiler/ghc.cabal.in - + testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - + testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.stdout - testsuite/tests/ghc-api/fixed-nodes/all.T - testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -10,9 +10,14 @@ {-# LANGUAGE ViewPatterns #-} module GHC.Driver.Downsweep ( downsweep + , downsweepThunk + , downsweepInstalledModules + , downsweepFromRootNodes + , DownsweepMode(..) -- * Summary functions , summariseModule , summariseFile + , summariseModuleInterface , SummariseResult(..) -- * Helper functions , instantiationNodes @@ -21,33 +26,37 @@ module GHC.Driver.Downsweep import GHC.Prelude -import GHC.Tc.Utils.Backpack - - import GHC.Platform.Ways import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Phases -import GHC.Driver.Pipeline +import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess) import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Monad import GHC.Driver.Env import GHC.Driver.Errors import GHC.Driver.Errors.Types -import GHC.Driver.Main +import GHC.Driver.Messager import GHC.Driver.MakeSem import GHC.Driver.MakeAction +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Ppr -import GHC.Parser.Header +import GHC.Iface.Load +import GHC.Parser.Header +import GHC.Rename.Names +import GHC.Tc.Utils.Backpack import GHC.Data.Graph.Directed import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) +import qualified GHC.Data.Maybe as M import GHC.Data.OsPath ( unsafeEncodeUtf ) import GHC.Data.StringBuffer +import GHC.Data.Graph.Directed.Reachability import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Exception ( throwIO, SomeAsyncException ) @@ -58,6 +67,7 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.Fingerprint import GHC.Utils.TmpFs +import GHC.Utils.Constants import GHC.Types.Error import GHC.Types.Target @@ -71,7 +81,10 @@ import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface import GHC.Unit.Module.Graph +import GHC.Unit.Module.Deps +import qualified GHC.Unit.Home.Graph as HUG import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map @@ -82,6 +95,7 @@ import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.Maybe +import Data.List (partition) import Data.Time import Data.List (unfoldr) import Data.Bifunctor (first) @@ -91,19 +105,45 @@ import System.FilePath import Control.Monad.Trans.Reader import qualified Data.Map.Strict as M import Control.Monad.Trans.Class -import GHC.Rename.Names -import GHC.Utils.Constants +import System.IO.Unsafe (unsafeInterleaveIO) -import GHC.Data.Graph.Directed.Reachability -import qualified GHC.Unit.Home.Graph as HUG +{- +Note [Downsweep and the ModuleGraph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The ModuleGraph stores the relationship between all the modules, units, and +instantiations in the current session. + +When we do downsweep, we build up a new ModuleGraph, starting from the root +modules. By following all the dependencies we construct a graph which allows +us to answer questions about the transitive closure of the imports. + +The module graph is accessible in the HscEnv. + +When is this graph constructed? + +1. In `--make` mode, we construct the graph before starting to do any compilation. + +2. In `-c` (oneshot) mode, we construct the graph when we have calculated the + ModSummary for the module we are compiling. The `ModuleGraph` is stored in a + thunk, so it is only constructed when it is needed. This avoids reading + the interface files of the whole transitive closure unless they are needed. + +3. In some situations (such as loading plugins) we may need to construct the + graph without having a ModSummary. In this case we use the `downsweepInstalledModules` + function. + +The result is having a uniform graph available for the whole compilation pipeline. + +-} -- This caches the answer to the question, if we are in this unit, what does -- an import of this module mean. -type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary] +type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo] ----------------------------------------------------------------------------- -- --- | Downsweep (dependency analysis) +-- | Downsweep (dependency analysis) for --make mode -- -- Chase downwards from the specified root set, returning summaries -- for all home modules encountered. Only follow source-import @@ -113,9 +153,15 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv -- cache to avoid recalculating a module summary if the source is -- unchanged. -- --- The returned list of [ModSummary] nodes has one node for each home-package +-- The returned ModuleGraph has one node for each home-package -- module, plus one for any hs-boot files. The imports of these nodes -- are all there, including the imports of non-home-package modules. +-- +-- This function is intendned for use by --make mode and will also insert +-- LinkNodes and InstantiationNodes for any home units. +-- +-- It will also turn on code generation for any modules that need it by calling +-- 'enableCodeGenForTH'. downsweep :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager @@ -132,8 +178,31 @@ downsweep :: HscEnv -- which case there can be repeats downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) - new <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary - downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new + (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary + let closure_errs = checkHomeUnitsClosed unit_env + unit_env = hsc_unit_env hsc_env + + all_errs = closure_errs ++ root_errs + + case all_errs of + [] -> do + (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] + + let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) + + let all_nodes = downsweep_nodes ++ unit_nodes + let all_errs = downsweep_errs ++ other_errs + + let logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + -- if we have been passed -fno-code, we enable code generation + -- for dependencies of modules that have -XTemplateHaskell, + -- otherwise those modules will fail to compile. + -- See Note [-fno-code mode] #8025 + th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes + + return (all_errs, th_configured_nodes) + _ -> return (all_errs, emptyMG) where summary = getRootSummary excl_mods old_summary_map @@ -146,47 +215,102 @@ downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do old_summary_map = M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] -downsweep_imports :: HscEnv + -- Dependencies arising on a unit (backpack and module linking deps) + unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] + unitModuleNodes summaries uid hue = + maybeToList (linkNodes summaries uid hue) + +-- | Calculate the module graph starting from a single ModSummary. The result is a +-- thunk, which when forced will perform the downsweep. This is useful in oneshot +-- mode where the module graph may never be needed. +-- If downsweep fails, then the resulting errors are just thrown. +downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph +downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do + debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." + ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) + return (mkModuleGraph mg) + +-- | Create a module graph from a list of installed modules. +-- This is used by the loader when we need to load modules but there +-- isn't already an existing module graph. For example, when loading plugins +-- during initialisation. +-- +-- If you call this function, then if the `Module` you request to downsweep can't +-- be found then this function will throw errors. +-- If you need to use this function elsewhere, then it would make sense to make it +-- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit. +-- At the moment, it is overfitted for what `get_reachable_nodes` needs. +downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph +downsweepInstalledModules hsc_env mods = do + let + (home_mods, external_mods) = partition (\u -> moduleUnitId u `elem` hsc_all_home_unit_ids hsc_env) mods + installed_mods = map (fst . getModuleInstantiation) home_mods + external_uids = map moduleUnitId external_mods + + process :: InstalledModule -> IO ModuleNodeInfo + process i = do + res <- findExactModule hsc_env i NotBoot + case res of + InstalledFound loc -> return $ ModuleNodeFixed (installedModuleToMnk i) loc + -- It is an internal-ish error if this happens, since we any call to this function should + -- already know that we can find the modules we need to load. + _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i + + nodes <- mapM process installed_mods + (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids + + -- Similarly here, we should really not get any errors, but print them out if we do. + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) + + return (mkModuleGraph mg) + + + +-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used +-- by --make mode, and fixed nodes by oneshot mode. +-- +-- See Note [Module Types in the ModuleGraph] for the difference between the two. +data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed + +-- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root +-- 'UnitId's. +-- This function will start at the given roots, and traverse downwards to find +-- all the dependencies, all the way to the leaf units. +downsweepFromRootNodes :: HscEnv -> M.Map (UnitId, FilePath) ModSummary -> [ModuleName] -> Bool - -> ([(UnitId, DriverMessages)], [ModSummary]) - -> IO ([DriverMessages], ModuleGraph) -downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk) + -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies + -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo + -> [UnitId] -- ^ The starting units + -> IO ([DriverMessages], [ModuleGraphNode]) +downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids = do - let root_map = mkRootMap rootSummariesOk + let root_map = mkRootMap root_nodes checkDuplicates root_map - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map) + (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map) + let all_deps = loopUnit hsc_env module_deps root_uids + let all_instantiations = getHomeUnitInstantiations hsc_env - let deps' = loopInstantiations all_instantiations deps - let closure_errs = checkHomeUnitsClosed unit_env - unit_env = hsc_unit_env hsc_env - tmpfs = hsc_tmpfs hsc_env + let deps' = loopInstantiations all_instantiations all_deps downsweep_errs = lefts $ concat $ M.elems map0 downsweep_nodes = M.elems deps' - (other_errs, unit_nodes) = partitionEithers $ HUG.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 - - -- if we have been passed -fno-code, we enable code generation - -- for dependencies of modules that have -XTemplateHaskell, - -- otherwise those modules will fail to compile. - -- See Note [-fno-code mode] #8025 - th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes - if null all_root_errs - then return (all_errs, th_enabled_nodes) - else pure $ (all_root_errs, emptyMG) + return (downsweep_errs, downsweep_nodes) where getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) - -- Dependencies arising on a unit (backpack and module linking deps) - unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] - unitModuleNodes summaries uid hue = - maybeToList (linkNodes summaries uid hue) calcDeps ms = -- Add a dependency on the HsBoot file if it exists @@ -195,8 +319,6 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ] - logger = hsc_logger hsc_env - -- In a root module, the filename is allowed to diverge from the module -- name, so we have to check that there aren't multiple root files -- defining the same module (otherwise the duplicates will be silently @@ -209,7 +331,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root | otherwise = pure () where - dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2 dup_roots = filterOut isSingleton $ map rights (M.elems root_map) loopInstantiations :: [(UnitId, InstantiatedUnit)] @@ -250,6 +372,102 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro | otherwise = Nothing + loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache) + loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is + + loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache) + loopModuleNodeInfo mod_node_info (done, summarised) = do + case mod_node_info of + ModuleNodeCompile ms -> do + loopSummaries [ms] (done, summarised) + ModuleNodeFixed mod ml -> do + done' <- loopFixedModule mod ml done + return (done', summarised) + + -- NB: loopFixedModule does not take a downsweep cache, because if you + -- ever reach a Fixed node, everything under that also must be fixed. + loopFixedModule :: ModNodeKeyWithUid -> ModLocation + -> M.Map NodeKey ModuleGraphNode + -> IO (M.Map NodeKey ModuleGraphNode) + loopFixedModule key loc done = do + let nk = NodeKey_Module key + case M.lookup nk done of + Just {} -> return done + Nothing -> do + -- MP: TODO, we should just read the dependency info from the interface rather than either + -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) + -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) + read_result <- + -- 1. Check if the interface is already loaded into the EPS by some other + -- part of the compiler. + lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case + Just iface -> return (M.Succeeded iface) + Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) + case read_result of + M.Succeeded iface -> do + -- Computer information about this node + let node_deps = ifaceDeps (mi_deps iface) + edges = map (either NodeKey_Module NodeKey_ExternalUnit) node_deps + node = ModuleNode edges (ModuleNodeFixed key loc) + foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) node_deps + -- Ignore any failure, we might try to read a .hi-boot file for + -- example, even if there is not one. + M.Failed {} -> + return done + + loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> IO (M.Map NodeKey ModuleGraphNode) + loopFixedNodeKey _ done (Left key) = do + loopFixedImports [key] done + loopFixedNodeKey home_uid done (Right uid) = do + -- Set active unit so that looking loopUnit finds the correct + -- -package flags in the unit state. + let hsc_env' = hscSetActiveUnitId home_uid hsc_env + return $ loopUnit hsc_env' done [uid] + + + ifaceDeps :: Dependencies -> [Either ModNodeKeyWithUid UnitId] + ifaceDeps deps = + [ Left (ModNodeKeyWithUid dep uid) + | (uid, dep) <- Set.toList (dep_direct_mods deps) + ] ++ + [ Right uid + | uid <- Set.toList (dep_direct_pkgs deps) + ] + + -- Like loopImports, but we already know exactly which module we are looking for. + loopFixedImports :: [ModNodeKeyWithUid] + -> M.Map NodeKey ModuleGraphNode + -> IO (M.Map NodeKey ModuleGraphNode) + loopFixedImports [] done = pure done + loopFixedImports (key:keys) done = do + let nk = NodeKey_Module key + case M.lookup nk done of + Just {} -> loopFixedImports keys done + Nothing -> do + read_result <- findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) + case read_result of + InstalledFound loc -> do + done' <- loopFixedModule key loc done + loopFixedImports keys done' + _otherwise -> + -- If the finder fails, just keep going, there will be another + -- error later. + loopFixedImports keys done + + downsweepSummarise :: HscEnv + -> HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] + -> IO SummariseResult + downsweepSummarise hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = + case mode of + DownsweepUseCompile -> summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods + DownsweepUseFixed -> summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover -- a new module by doing this. @@ -268,7 +486,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro | Just summs <- M.lookup cache_key summarised = case summs of [Right ms] -> do - let nk = NodeKey_Module (msKey ms) + let nk = NodeKey_Module (mnKey ms) (rest, summarised', done') <- loopImports ss done summarised return (nk: rest, summarised', done') [Left _err] -> @@ -277,7 +495,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro loopImports ss done summarised | otherwise = do - mb_s <- summariseModule hsc_env home_unit old_summaries + mb_s <- downsweepSummarise hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg Nothing excl_mods case mb_s of @@ -295,11 +513,11 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) FoundHome s -> do (done', summarised') <- - loopSummaries [s] (done, Map.insert cache_key [Right s] summarised) + loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised) (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. - return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised) + return (NodeKey_Module (mnKey s) : other_deps, final_done, final_summarised) where cache_key = (home_uid, mb_pkg, unLoc <$> gwib) home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) @@ -316,17 +534,17 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u) -multiRootsErr :: [ModSummary] -> IO () +multiRootsErr :: [ModuleNodeInfo] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) = throwOneError $ fmap GhcDriverMessage $ mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files where - mod = ms_mod summ1 - files = map (expectJust . ml_hs_file . ms_location) summs + mod = moduleNodeInfoModule summ1 + files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs -moduleNotFoundErr :: ModuleName -> DriverMessages -moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod) +moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages +moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod) -- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes. -- These are used to represent the type checking that is done after @@ -380,18 +598,17 @@ getRootSummary :: M.Map (UnitId, FilePath) ModSummary -> HscEnv -> Target -> - IO (Either (UnitId, DriverMessages) ModSummary) + IO (Either DriverMessages ModSummary) getRootSummary excl_mods old_summary_map hsc_env target | TargetFile file mb_phase <- targetId = do let offset_file = augmentByWorkingDirectory dflags file exists <- liftIO $ doesFileExist offset_file if exists || isJust maybe_buf - then first (uid,) <$> - summariseFile hsc_env home_unit old_summary_map offset_file mb_phase + then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase maybe_buf else - return $ Left $ (uid,) $ singleMessage $ + return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) | TargetModule modl <- targetId = do @@ -399,9 +616,9 @@ getRootSummary excl_mods old_summary_map hsc_env target (L rootLoc modl) (ThisPkg (homeUnitId home_unit)) maybe_buf excl_mods pure case maybe_summary of - FoundHome s -> Right s - FoundHomeWithError err -> Left err - _ -> Left (uid, moduleNotFoundErr modl) + FoundHome (ModuleNodeCompile s) -> Right s + FoundHomeWithError err -> Left (snd err) + _ -> Left (moduleNotFoundErr uid modl) where Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) @@ -426,8 +643,8 @@ rootSummariesParallel :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> - (HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)) -> - IO ([(UnitId, DriverMessages)], [ModSummary]) + (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) -> + IO ([DriverMessages], [ModSummary]) rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles) runPipelines n_jobs hsc_env diag_wrapper msg actions @@ -732,10 +949,10 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do -- | Populate the Downsweep cache with the root modules. mkRootMap - :: [ModSummary] + :: [ModuleNodeInfo] -> DownsweepCache mkRootMap summaries = Map.fromListWith (flip (++)) - [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ] + [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ] ----------------------------------------------------------------------------- -- Summarising modules @@ -863,26 +1080,64 @@ checkSummaryHash data SummariseResult = FoundInstantiation InstantiatedUnit | FoundHomeWithError (UnitId, DriverMessages) - | FoundHome ModSummary + | FoundHome ModuleNodeInfo | External UnitId | NotThere +-- | summariseModule finds the location of the source file for the given module. +-- This version always returns a ModuleNodeCompile node, it is useful for +-- --make mode. +summariseModule :: HscEnv + -> HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] + -> IO SummariseResult +summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = + summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + where + k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf + + +-- | Like summariseModule but for interface files that we don't want to compile. +-- This version always returns a ModuleNodeFixed node. +summariseModuleInterface :: HscEnv + -> HomeUnit + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> [ModuleName] + -> IO SummariseResult +summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods = + summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + where + k _hsc_env loc mod = do + -- The finder will return a path to the .hi-boot even if it doesn't actually + -- exist. So check if it exists first before concluding it's there. + does_exist <- doesFileExist (ml_hi_file loc) + if does_exist + then let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + else return NotThere + + + -- Summarise a module, and pick up source and timestamp. -summariseModule - :: HscEnv +summariseModuleDispatch + :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module. + -> HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary - -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised -> PkgQual - -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude -> IO SummariseResult -summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_pkg - maybe_buf excl_mods +summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods | wanted_mod `elem` excl_mods = return NotThere | otherwise = find_it @@ -890,7 +1145,6 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p -- Temporarily change the currently active home unit so all operations -- happen relative to it hsc_env = hscSetActiveHomeUnit home_unit hsc_env' - dflags = hsc_dflags hsc_env find_it :: IO SummariseResult @@ -898,9 +1152,9 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg case found of Found location mod - | isJust (ml_hs_file location) -> + | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env -> -- Home package - just_found location mod + k hsc_env location mod | VirtUnit iud <- moduleUnit mod , not (isHomeModule home_unit mod) -> return $ FoundInstantiation iud @@ -910,9 +1164,22 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p -- (If it is TRULY not found at all, we'll -- error when we actually try to compile) - just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so + +-- | The continuation to summarise a home module if we want to find the source file +-- for it and potentially compile it. +summariseModuleWithSource + :: HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -- ^ Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Maybe (StringBuffer, UTCTime) + -> HscEnv + -> ModLocation + -> Module + -> IO SummariseResult +summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so let src_fn = expectJust (ml_hs_file location) -- Check that it exists @@ -926,8 +1193,10 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p fresult <- new_summary_cache_check location mod src_fn h return $ case fresult of Left err -> FoundHomeWithError (moduleUnitId mod, err) - Right ms -> FoundHome ms + Right ms -> FoundHome (ModuleNodeCompile ms) + where + dflags = hsc_dflags hsc_env new_summary_cache_check loc mod src_fn h | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = @@ -1061,4 +1330,4 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do 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' - return PreprocessedImports {..} \ No newline at end of file + return PreprocessedImports {..} ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -27,6 +27,7 @@ module GHC.Driver.Env , discardIC , lookupType , lookupIfaceByModule + , lookupIfaceByModuleHsc , mainModIs , hugRulesBelow @@ -249,6 +250,11 @@ hugInstancesBelow hsc_env uid mnwib = do -- -- Note: Don't expose this function. This is a footgun if exposed! hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] +-- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk +-- These things are currently stored in the EPS for home packages. (See #25795 for +-- progress in removing these kind of checks) +-- See Note [Downsweep and the ModuleGraph] +hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn = let hug = hsc_HUG hsc_env mg = hsc_mod_graph hsc_env @@ -345,6 +351,11 @@ lookupIfaceByModule hug pit mod -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. +lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe ModIface) +lookupIfaceByModuleHsc hsc_env mod = do + eps <- hscEPS hsc_env + lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod + mainModIs :: HomeUnitEnv -> Module mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -67,6 +67,7 @@ data HscEnv hsc_mod_graph :: ModuleGraph, -- ^ The module graph of the current session + -- See Note [Downsweep and the ModuleGraph] for when this is constructed. hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements ===================================== compiler/GHC/Driver/Errors/Ppr.hs ===================================== @@ -155,7 +155,7 @@ instance Diagnostic DriverMessage where text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) - DriverModuleNotFound mod + DriverModuleNotFound _uid mod -> mkSimpleDecorated (text "module" <+> quotes (ppr mod) <+> text "cannot be found locally") DriverFileModuleNameMismatch actual expected -> mkSimpleDecorated $ ===================================== compiler/GHC/Driver/Errors/Types.hs ===================================== @@ -187,7 +187,7 @@ data DriverMessage where Test cases: None. -} - DriverModuleNotFound :: !ModuleName -> DriverMessage + DriverModuleNotFound :: !UnitId -> !ModuleName -> DriverMessage {-| DriverFileModuleNameMismatch occurs if a module 'A' is defined in a file with a different name. The first field is the name written in the source code; the second argument is the name extracted ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -118,6 +118,7 @@ import GHC.Driver.Backend import GHC.Driver.Env import GHC.Driver.Env.KnotVars import GHC.Driver.Errors +import GHC.Driver.Messager import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig) @@ -220,7 +221,6 @@ import GHC.Cmm.UniqueRenamer import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder -import GHC.Unit.External import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface @@ -814,7 +814,6 @@ This is the only thing that isn't caught by the type-system. -} -type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () -- | Do the recompilation avoidance checks for both one-shot and --make modes -- This function is the *only* place in the compiler where we decide whether to @@ -1476,46 +1475,6 @@ genModDetails hsc_env old_iface dumpIfaceStats hsc_env return new_details --------------------------------------------------------------- --- Progress displayers. --------------------------------------------------------------- - -oneShotMsg :: Logger -> RecompileRequired -> IO () -oneShotMsg logger recomp = - case recomp of - UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required" - NeedsRecompile _ -> return () - -batchMsg :: Messager -batchMsg = batchMsgWith (\_ _ _ _ -> empty) -batchMultiMsg :: Messager -batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (mgNodeUnitId node))) - -batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager -batchMsgWith extra hsc_env_start mod_index recomp node = - case recomp of - UpToDate - | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty - | otherwise -> return () - NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of - MustCompile -> empty - (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" - where - herald = case node of - LinkNode {} -> "Linking" - InstantiationNode {} -> "Instantiating" - ModuleNode {} -> "Compiling" - UnitNode {} -> "Loading" - hsc_env = hscSetActiveUnitId (mgNodeUnitId node) hsc_env_start - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - state = hsc_units hsc_env - showMsg msg reason = - compilationProgressMsg logger $ - (showModuleIndex mod_index <> - msg <+> showModMsg dflags (recompileRequired recomp) node) - <> extra hsc_env mod_index recomp node - <> reason -------------------------------------------------------------- -- Safe Haskell @@ -1803,10 +1762,7 @@ hscCheckSafe' m l = do lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do hsc_env <- getHscEnv - hsc_eps <- liftIO $ hscEPS hsc_env - let pkgIfaceT = eps_PIT hsc_eps - hug = hsc_HUG hsc_env - iface <- liftIO $ lookupIfaceByModule hug pkgIfaceT m + iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m -- the 'lookupIfaceByModule' method will always fail when calling from GHCi -- as the compiler hasn't filled in the various module tables -- so we need to call 'getModuleInterface' to load from disk @@ -2954,18 +2910,6 @@ dumpIfaceStats hsc_env = do logDumpMsg logger "Interface statistics" (ifaceStats eps) -{- ********************************************************************** -%* * - Progress Messages: Module i of n -%* * -%********************************************************************* -} - -showModuleIndex :: (Int, Int) -> SDoc -showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] " - where - -- compute the length of x > 0 in base 10 - len x = ceiling (logBase 10 (fromIntegral x+1) :: Float) - pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr writeInterfaceOnlyMode :: DynFlags -> Bool writeInterfaceOnlyMode dflags = ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -41,6 +41,7 @@ module GHC.Driver.Make ( -- * Re-exports from Downsweep checkHomeUnitsClosed, summariseModule, + summariseModuleInterface, SummariseResult(..), summariseFile, @@ -648,7 +649,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do | otherwise = do throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ GhcDriverMessage - $ DriverModuleNotFound (moduleName m) + $ DriverModuleNotFound (moduleUnit m) (moduleName m) checkHowMuch how_much $ do @@ -1667,7 +1668,7 @@ executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod loc = wrapAction diag_wrapper hsc_env $ do forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc)) - read_result <- readIface (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc) + read_result <- readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc) case read_result of M.Failed interface_err -> let mn = mnkModuleName mod ===================================== compiler/GHC/Driver/MakeAction.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Driver.DynFlags import GHC.Driver.Monad import GHC.Driver.Env import GHC.Driver.Errors.Types -import GHC.Driver.Main +import GHC.Driver.Messager import GHC.Driver.MakeSem import GHC.Utils.Logger ===================================== compiler/GHC/Driver/Messager.hs ===================================== @@ -0,0 +1,66 @@ +module GHC.Driver.Messager (Messager, oneShotMsg, batchMsg, batchMultiMsg, showModuleIndex) where + +import GHC.Prelude +import GHC.Driver.Env +import GHC.Unit.Module.Graph +import GHC.Iface.Recomp +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Unit.State + +type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () + +-------------------------------------------------------------- +-- Progress displayers. +-------------------------------------------------------------- + +oneShotMsg :: Logger -> RecompileRequired -> IO () +oneShotMsg logger recomp = + case recomp of + UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required" + NeedsRecompile _ -> return () + +batchMsg :: Messager +batchMsg = batchMsgWith (\_ _ _ _ -> empty) +batchMultiMsg :: Messager +batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (mgNodeUnitId node))) + +batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager +batchMsgWith extra hsc_env_start mod_index recomp node = + case recomp of + UpToDate + | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty + | otherwise -> return () + NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of + MustCompile -> empty + (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" + where + herald = case node of + LinkNode {} -> "Linking" + InstantiationNode {} -> "Instantiating" + ModuleNode {} -> "Compiling" + UnitNode {} -> "Loading" + hsc_env = hscSetActiveUnitId (mgNodeUnitId node) hsc_env_start + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + state = hsc_units hsc_env + showMsg msg reason = + compilationProgressMsg logger $ + (showModuleIndex mod_index <> + msg <+> showModMsg dflags (recompileRequired recomp) node) + <> extra hsc_env mod_index recomp node + <> reason + +{- ********************************************************************** +%* * + Progress Messages: Module i of n +%* * +%********************************************************************* -} + +showModuleIndex :: (Int, Int) -> SDoc +showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] " + where + -- compute the length of x > 0 in base 10 + len x = ceiling (logBase 10 (fromIntegral x+1) :: Float) + pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr \ No newline at end of file ===================================== compiler/GHC/Driver/Pipeline.hs-boot ===================================== @@ -3,12 +3,22 @@ module GHC.Driver.Pipeline where import GHC.Driver.Env.Types ( HscEnv ) import GHC.ForeignSrcLang ( ForeignSrcLang ) -import GHC.Prelude (FilePath, IO) +import GHC.Prelude (FilePath, IO, Maybe, Either) import GHC.Unit.Module.Location (ModLocation) import GHC.Driver.Session (DynFlags) +import GHC.Driver.Phases (Phase) +import GHC.Driver.Errors.Types (DriverMessages) +import GHC.Types.Target (InputFileBuffer) import Language.Haskell.Syntax.Module.Name -- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () + +preprocess :: HscEnv + -> FilePath + -> Maybe InputFileBuffer + -> Maybe Phase + -> IO (Either DriverMessages (DynFlags, FilePath)) + ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Unit.Module.ModSummary import qualified GHC.LanguageExtensions as LangExt import GHC.Types.SrcLoc import GHC.Driver.Main +import GHC.Driver.Downsweep import GHC.Tc.Types import GHC.Types.Error import GHC.Driver.Errors.Types @@ -760,11 +761,17 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do let msg :: Messager msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what + -- A lazy module graph thunk, don't force it unless you need it! + mg <- downsweepThunk hsc_env mod_summary + -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } + let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) + , hsc_mod_graph = mg } + + status <- hscRecompStatus (Just msg) hsc_env' mod_summary Nothing emptyHomeModInfoLinkable (1, 1) ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -25,7 +25,6 @@ module GHC.Iface.Load ( -- IfM functions loadInterface, loadSysInterface, loadUserInterface, loadPluginInterface, - loadExternalGraphBelow, findAndReadIface, readIface, writeIface, flagsToIfCompression, moduleFreeHolesPrecise, @@ -49,7 +48,6 @@ import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst , tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceDefaults) -import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Errors.Types import GHC.Driver.DynFlags @@ -110,7 +108,6 @@ import GHC.Unit.Home import GHC.Unit.Home.PackageTable import GHC.Unit.Finder import GHC.Unit.Env -import GHC.Unit.Module.External.Graph import GHC.Data.Maybe @@ -122,7 +119,6 @@ import GHC.Driver.Env.KnotVars import {-# source #-} GHC.Driver.Main (loadIfaceByteCode) import GHC.Iface.Errors.Types import Data.Function ((&)) -import qualified Data.Set as Set import GHC.Unit.Module.Graph import qualified GHC.Unit.Home.Graph as HUG @@ -413,112 +409,6 @@ loadInterfaceWithException doc mod_name where_from let ctx = initSDocContext dflags defaultUserStyle withIfaceErr ctx (loadInterface doc mod_name where_from) --- | Load the part of the external module graph which is transitively reachable --- from the given modules. --- --- This operation is used just before TH splices are run (in 'getLinkDeps'). --- --- A field in the EPS tracks which home modules are already fully loaded, which we use --- here to avoid trying to load them a second time. --- --- The function takes a set of keys which are currently in the process of being loaded. --- This is used to avoid duplicating work by loading keys twice if they appear along multiple --- paths in the transitive closure. Once the interface and all its dependencies are --- loaded, the key is added to the "fully loaded" set, so we know that it and it's --- transitive closure are present in the graph. --- --- Note that being "in progress" is different from being "fully loaded", consider if there --- is an exception during `loadExternalGraphBelow`, then an "in progress" item may fail --- to become fully loaded. -loadExternalGraphBelow :: (Module -> SDoc) -> Maybe HomeUnit {-^ The current home unit -} - -> Set.Set ExternalKey -> [Module] -> IfM lcl (Set.Set ExternalKey) -loadExternalGraphBelow _ Nothing _ _ = panic "loadExternalGraphBelow: No home unit" -loadExternalGraphBelow msg (Just home_unit) in_progress mods = - foldM (loadExternalGraphModule msg home_unit) in_progress mods - --- | Load the interface for a module, and all its transitive dependencies but --- only if we haven't fully loaded the module already or are in the process of fully loading it. -loadExternalGraphModule :: (Module -> SDoc) -> HomeUnit - -> Set.Set ExternalKey - -> Module - -> IfM lcl (Set.Set ExternalKey) -loadExternalGraphModule msg home_unit in_progress mod - | homeUnitId home_unit /= moduleUnitId mod = do - loadExternalPackageBelow in_progress (moduleUnitId mod) - | otherwise = do - - let key = ExternalModuleKey $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod) - graph <- eps_module_graph <$> getEps - - if (not (isFullyLoadedModule key graph || Set.member key in_progress)) - then actuallyLoadExternalGraphModule msg home_unit in_progress key mod - else return in_progress - --- | Load the interface for a module, and all its transitive dependenices. -actuallyLoadExternalGraphModule - :: (Module -> SDoc) - -> HomeUnit - -> Set.Set ExternalKey - -> ExternalKey - -> Module - -> IOEnv (Env IfGblEnv lcl) (Set.Set ExternalKey) -actuallyLoadExternalGraphModule msg home_unit in_progress key mod = do - dflags <- getDynFlags - let ctx = initSDocContext dflags defaultUserStyle - iface <- withIfaceErr ctx $ - loadInterface (msg mod) mod (ImportByUser NotBoot) - - let deps = mi_deps iface - mod_deps = dep_direct_mods deps - pkg_deps = dep_direct_pkgs deps - - -- Do not attempt to load the same key again when traversing - let in_progress' = Set.insert key in_progress - - -- Load all direct dependencies that are in the home package - cache_mods <- loadExternalGraphBelow msg (Just home_unit) in_progress' - $ map (\(uid, GWIB mn _) -> mkModule (RealUnit (Definite uid)) mn) - $ Set.toList mod_deps - - -- Load all the package nodes, and packages beneath them. - cache_pkgs <- foldM loadExternalPackageBelow cache_mods (Set.toList pkg_deps) - - registerFullyLoaded key - return cache_pkgs - -registerFullyLoaded :: ExternalKey -> IfM lcl () -registerFullyLoaded key = do - -- Update the external graph with this module being fully loaded. - logger <- getLogger - liftIO $ trace_if logger (text "Fully loaded:" <+> ppr key) - updateEps_ $ \eps -> - eps{eps_module_graph = setFullyLoadedModule key (eps_module_graph eps)} - -loadExternalPackageBelow :: Set.Set ExternalKey -> UnitId -> IfM lcl (Set.Set ExternalKey) -loadExternalPackageBelow in_progress uid = do - graph <- eps_module_graph <$> getEps - us <- hsc_units <$> getTopEnv - let key = ExternalPackageKey uid - if not (isFullyLoadedModule key graph || Set.member key in_progress) - then do - let in_progress' = Set.insert key in_progress - case unitDepends <$> lookupUnitId us uid of - Just dep_uids -> do - loadPackageIntoEPSGraph uid dep_uids - final_cache <- foldM loadExternalPackageBelow in_progress' dep_uids - registerFullyLoaded key - return final_cache - Nothing -> pprPanic "loadExternalPackagesBelow: missing" (ppr uid) - else - return in_progress - -loadPackageIntoEPSGraph :: UnitId -> [UnitId] -> IfM lcl () -loadPackageIntoEPSGraph uid dep_uids = - updateEps_ $ \eps -> - eps { eps_module_graph = - extendExternalModuleGraph (NodeExternalPackage uid - (Set.fromList dep_uids)) (eps_module_graph eps) } - ------------------ loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr MissingInterfaceError ModIface) @@ -628,15 +518,6 @@ loadInterface doc_str mod from ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) ; purged_hsc_env <- getTopEnv - ; let direct_deps = map (uncurry (flip ModNodeKeyWithUid)) $ (Set.toList (dep_direct_mods $ mi_deps iface)) - ; let direct_pkg_deps = Set.toList $ dep_direct_pkgs $ mi_deps iface - ; let !module_graph_key = - if moduleUnitId mod `elem` hsc_all_home_unit_ids hsc_env - --- ^ home unit mods in eps can only happen in oneshot mode - then Just $ NodeHomePackage (miKey iface) (map ExternalModuleKey direct_deps - ++ map ExternalPackageKey direct_pkg_deps) - else Nothing - ; let final_iface = iface & set_mi_decls (panic "No mi_decls in PIT") & set_mi_insts (panic "No mi_insts in PIT") @@ -678,11 +559,6 @@ loadInterface doc_str mod from eps_iface_bytecode = add_bytecode (eps_iface_bytecode eps), eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules, - eps_module_graph = - let eps_graph' = case module_graph_key of - Just k -> extendExternalModuleGraph k (eps_module_graph eps) - Nothing -> eps_module_graph eps - in eps_graph', eps_complete_matches = eps_complete_matches eps ++ new_eps_complete_matches, eps_inst_env = extendInstEnvList (eps_inst_env eps) @@ -792,6 +668,9 @@ dontLeakTheHUG thing_inside = do -- tweak. old_unit_env = hsc_unit_env hsc_env keepFor20509 + -- oneshot mode does not support backpack + -- and we want to avoid prodding the hsc_mod_graph thunk + | isOneShot (ghcMode (hsc_dflags hsc_env)) = False | mgHasHoles (hsc_mod_graph hsc_env) = True | otherwise = False pruneHomeUnitEnv hme = do @@ -1012,12 +891,10 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags unit_state = hsc_units hsc_env - fc = hsc_FC hsc_env name_cache = hsc_NC hsc_env mhome_unit = hsc_home_unit_maybe hsc_env dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) trace_if logger (sep [hsep [text "Reading", @@ -1036,9 +913,8 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do let iface = getGhcPrimIface hsc_env return (Succeeded (iface, panic "GHC.Prim ModLocation (findAndReadIface)")) else do - let fopts = initFinderOpts dflags -- Look for the file - mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod hi_boot_file) + mb_found <- liftIO (findExactModule hsc_env mod hi_boot_file) case mb_found of InstalledFound loc -> do -- See Note [Home module load error] @@ -1101,7 +977,6 @@ read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) read_file logger name_cache unit_state dflags wanted_mod file_path = do - trace_if logger (text "readIFace" <+> text file_path) -- Figure out what is recorded in mi_module. If this is -- a fully definite interface, it'll match exactly, but @@ -1112,7 +987,7 @@ read_file logger name_cache unit_state dflags wanted_mod file_path = do (_, Just indef_mod) -> instModuleToModule unit_state (uninstantiateInstantiatedModule indef_mod) - read_result <- readIface dflags name_cache wanted_mod' file_path + read_result <- readIface logger dflags name_cache wanted_mod' file_path case read_result of Failed err -> return (Failed err) Succeeded iface -> return (Succeeded (iface, file_path)) @@ -1139,12 +1014,14 @@ flagsToIfCompression dflags -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed readIface - :: DynFlags + :: Logger + -> DynFlags -> NameCache -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError ModIface) -readIface dflags name_cache wanted_mod file_path = do +readIface logger dflags name_cache wanted_mod file_path = do + trace_if logger (text "readIFace" <+> text file_path) let profile = targetProfile dflags res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path case res of ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -23,7 +23,6 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Driver.Backend -import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.DynFlags import GHC.Driver.Ppr @@ -303,7 +302,7 @@ check_old_iface hsc_env mod_summary maybe_iface loadIface read_dflags iface_path = do let ncu = hsc_NC hsc_env - read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path + read_result <- readIface logger read_dflags ncu (ms_mod mod_summary) iface_path case read_result of Failed err -> do let msg = readInterfaceErrorDiagnostic err @@ -635,7 +634,7 @@ 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) + res_plugin <- classify_import (\mod _ -> findPluginModule hsc_env mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin) of Left recomp -> return $ NeedsRecompile recomp Right es -> do @@ -657,13 +656,8 @@ checkDependencies hsc_env summary iface let reason = ModuleChanged mod in classify reason <$> find_import mod mb_pkg) imports - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags logger = hsc_logger hsc_env - fc = hsc_FC hsc_env - mhome_unit = hsc_home_unit_maybe hsc_env all_home_units = hsc_all_home_unit_ids hsc_env - units = hsc_units hsc_env prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) (dep_plugin_pkgs (mi_deps iface))) ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -228,31 +228,6 @@ See Note [Home module build products] for some more information about that. The only other place where the flag is consulted is when enabling code generation with `-fno-code`, which does so to anticipate what decision we will make at the splice point about what we would prefer. - -Note [Reachability in One-shot mode vs Make mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why are there two code paths in `get_reachable_nodes`? (ldOneShotMode vs otherwise) - -In one-shot mode, the home package modules are loaded into the EPS, -whereas for --make mode, the home package modules are in the HUG/HPT. - -For both of these cases, we cache the calculation of transitive -dependencies in a 'ModuleGraph'. For the --make case, the relevant -'ModuleGraph' is in the EPS, the other case uses the 'ModuleGraph' -for the home modules. - -The home modules graph is known statically after downsweep. -On the contrary, the EPS module graph is only extended when a -module is loaded into the EPS -- which is done lazily as needed. -Therefore, for get_link_deps, we need to force the transitive -closure to be loaded before querying the graph for the reachable -link dependencies -- done in the call to 'loadExternalGraphBelow'. -Because we cache the transitive closure, this work is only done once. - -After forcing the modules with the call to 'loadExternalGraphBelow' in -'get_reachable_nodes', the external module graph has all edges needed to -compute the full transitive closure so we can proceed just like we do in the -second path with a normal module graph. -} dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -76,12 +76,10 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Unit.Env -import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.External (ExternalPackageState (..)) import GHC.Unit.Module import GHC.Unit.Module.ModNodeKey -import GHC.Unit.Module.External.Graph import GHC.Unit.Module.Graph import GHC.Unit.Module.ModIface import GHC.Unit.State as Packages @@ -119,6 +117,9 @@ import System.Win32.Info (getSystemDirectory) import GHC.Utils.Exception import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey) +import GHC.Driver.Downsweep + + -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -615,89 +616,53 @@ initLinkDepsOpts hsc_env = opts dflags = hsc_dflags hsc_env ldLoadByteCode mod = do + _ <- initIfaceLoad hsc_env $ + loadInterface (text "get_reachable_nodes" <+> parens (ppr mod)) + mod ImportBySystem EPS {eps_iface_bytecode} <- hscEPS hsc_env sequence (lookupModuleEnv eps_iface_bytecode mod) --- See Note [Reachability in One-shot mode vs Make mode] get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId) get_reachable_nodes hsc_env mods - -- Reachability on 'ExternalModuleGraph' (for one shot mode) - | isOneShot (ghcMode dflags) + -- Fallback case if the ModuleGraph has not been initialised by the user. + -- This can happen if is the user is loading plugins or doing something else very + -- early in the compiler pipeline. + | isEmptyMG (hsc_mod_graph hsc_env) = do - initIfaceCheck (text "loader") hsc_env - $ void $ loadExternalGraphBelow msg (hsc_home_unit_maybe hsc_env) Set.empty mods - -- Read the EPS only after `loadExternalGraphBelow` - eps <- hscEPS hsc_env - let - emg = eps_module_graph eps - get_mod_info_eps (ModNodeKeyWithUid gwib uid) - | uid == homeUnitId (ue_unsafeHomeUnit unit_env) - = case lookupModuleEnv (eps_PIT eps) (Module (RealUnit $ Definite uid) (gwib_mod gwib)) of - Just iface -> return $ Just iface - Nothing -> moduleNotLoaded "(in EPS)" gwib uid - | otherwise - = return Nothing - - get_mod_key m - | moduleUnitId m == homeUnitId (ue_unsafeHomeUnit unit_env) - = ExternalModuleKey (mkModuleNk m) - | otherwise = ExternalPackageKey (moduleUnitId m) - - go get_mod_key emgNodeKey (emgReachableLoopMany emg) (map emgProject) get_mod_info_eps + mg <- downsweepInstalledModules hsc_env mods + go mg - -- Reachability on 'ModuleGraph' (for --make mode) | otherwise - = go hmgModKey mkNodeKey (mgReachableLoop hmGraph) (catMaybes . map hmgProject) get_mod_info_hug + = go (hsc_mod_graph hsc_env) where - dflags = hsc_dflags hsc_env unit_env = hsc_unit_env hsc_env mkModuleNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m) - msg mod = - text "need to link module" <+> ppr mod <+> - text "and the modules below it, due to use of Template Haskell" - - hmGraph = hsc_mod_graph hsc_env - hmgModKey m + hmgModKey mg m | let k = NodeKey_Module (mkModuleNk m) - , mgMember hmGraph k = k + , mgMember mg k = k | otherwise = NodeKey_ExternalUnit (moduleUnitId m) - hmgProject = \case - NodeKey_Module with_uid -> Just $ Left with_uid - NodeKey_ExternalUnit uid -> Just $ Right uid - _ -> Nothing - - emgProject = \case - ExternalModuleKey with_uid -> Left with_uid - ExternalPackageKey uid -> Right uid - -- The main driver for getting dependencies, which calls the given -- functions to compute the reachable nodes. - go :: (Module -> key) - -> (node -> key) - -> ([key] -> [node]) - -> ([key] -> [Either ModNodeKeyWithUid UnitId]) - -> (ModNodeKeyWithUid -> IO (Maybe ModIface)) - -> IO ([Module], UniqDSet UnitId) - go modKey nodeKey manyReachable project get_mod_info - | let mod_keys = map modKey mods - = do - let (all_home_mods, pkgs_s) = partitionEithers $ project $ mod_keys ++ map nodeKey (manyReachable mod_keys) - ifaces <- mapMaybeM get_mod_info all_home_mods - let mods_s = map mi_module ifaces + go :: ModuleGraph -> IO ([Module], UniqDSet UnitId) + go mg = do + let mod_keys = map (hmgModKey mg) mods + all_reachable = mod_keys ++ map mkNodeKey (mgReachableLoop mg mod_keys) + (mods_s, pkgs_s) <- partitionEithers <$> mapMaybeM get_mod_info all_reachable return (mods_s, mkUniqDSet pkgs_s) - get_mod_info_hug (ModNodeKeyWithUid gwib uid) = + get_mod_info :: NodeKey -> IO (Maybe (Either Module UnitId)) + get_mod_info (NodeKey_Module m@(ModNodeKeyWithUid gwib uid)) = lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) >>= \case - Just hmi -> return $ Just (hm_iface hmi) - Nothing -> moduleNotLoaded "(in HUG)" gwib uid + Just hmi -> return $ Just (Left (mi_module (hm_iface hmi))) + Nothing -> return (Just (Left (mnkToModule m))) + get_mod_info (NodeKey_ExternalUnit uid) = return (Just (Right uid)) + get_mod_info _ = return Nothing - moduleNotLoaded m gwib uid = throwGhcExceptionIO $ ProgramError $ showSDoc dflags $ - text "getLinkDeps: Home module not loaded" <+> text m <+> ppr (gwib_mod gwib) <+> ppr uid {- ********************************************************************** ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -56,7 +56,6 @@ import GHC.Types.Name.Reader import GHC.Types.Unique.DFM import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) -import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) ) import GHC.Unit.Module.ModIface @@ -343,13 +342,8 @@ lookupRdrNameInModuleForPlugins :: HasDebugCallStack -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - let fc = hsc_FC hsc_env - let unit_env = hsc_unit_env hsc_env - let unit_state = ue_homeUnitState 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 + found_module <- findPluginModule hsc_env mod_name case found_module of Found _ mod -> do -- Find the exports of the module ===================================== compiler/GHC/Unit/External.hs ===================================== @@ -33,7 +33,6 @@ import GHC.Types.TypeEnv import GHC.Types.Unique.DSet import GHC.Linker.Types (Linkable) -import GHC.Unit.Module.External.Graph import Data.IORef @@ -72,7 +71,6 @@ initExternalPackageState = EPS , eps_PIT = emptyPackageIfaceTable , eps_free_holes = emptyInstalledModuleEnv , eps_PTE = emptyTypeEnv - , eps_module_graph = emptyExternalModuleGraph , eps_iface_bytecode = emptyModuleEnv , eps_inst_env = emptyInstEnv , eps_fam_inst_env = emptyFamInstEnv @@ -141,8 +139,6 @@ data ExternalPackageState -- for every import, so cache it here. When the PIT -- gets filled in we can drop these entries. - eps_module_graph :: ExternalModuleGraph, - eps_PTE :: !PackageTypeEnv, -- ^ Result of typechecking all the external package -- interface files we have sucked in. The domain of ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -66,7 +66,6 @@ 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) ) import GHC.Driver.Config.Finder import qualified Data.Set as Set import Data.List.NonEmpty ( NonEmpty (..) ) @@ -224,21 +223,26 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified. -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModule fc fopts units (Just home_unit) mod_name = +findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult +findPluginModuleNoHsc fc fopts units (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 = +findPluginModuleNoHsc fc fopts units Nothing mod_name = findExposedPluginPackageModule fc fopts units 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 --- where the files associated with this module live. It is used when --- reading the interface for a module mentioned by another interface, --- for example (a "system import"). -findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult -findExactModule fc fopts other_fopts unit_state mhome_unit mod is_boot = do +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 + + +-- | A version of findExactModule which takes the exact parts of the HscEnv it needs +-- directly. +findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do res <- case mhome_unit of Just home_unit | isHomeInstalledModule home_unit mod @@ -251,6 +255,21 @@ findExactModule fc fopts other_fopts unit_state mhome_unit mod is_boot = do _ -> return res +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). +findExactModule :: HscEnv -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModule hsc_env mod is_boot = do + let dflags = hsc_dflags hsc_env + let fc = hsc_FC hsc_env + let unit_state = hsc_units hsc_env + let home_unit = hsc_home_unit_maybe hsc_env + let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) + findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot + + -- ----------------------------------------------------------------------------- -- Helpers ===================================== compiler/GHC/Unit/Module/External/Graph.hs deleted ===================================== @@ -1,244 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} - --- | Like @'GHC.Unit.Module.Graph'@ but for the @'ExternalModuleGraph'@ which is --- stored in the EPS. -module GHC.Unit.Module.External.Graph - ( -- * External Module Graph - -- - -- | A module graph for the EPS. - ExternalModuleGraph, ExternalGraphNode(..) - , ExternalKey(..), emptyExternalModuleGraph - , emgNodeKey, emgNodeDeps, emgLookupKey - - -- * Extending - -- - -- | The @'ExternalModuleGraph'@ is a structure which is incrementally - -- updated as the 'ExternalPackageState' (EPS) is updated (when an iface is - -- loaded, in 'loadInterface'). - -- - -- Therefore, there is an operation for extending the 'ExternalModuleGraph', - -- unlike @'GHC.Unit.Module.Graph.ModuleGraph'@, which is constructed once - -- during downsweep and never altered (since all of the home units - -- dependencies are fully known then). - , extendExternalModuleGraph - - -- * Loading - -- - -- | As mentioned in the top-level haddocks for the - -- 'extendExternalModuleGraph', the external module graph is incrementally - -- updated as interfaces are loaded. This module graph keeps an additional - -- cache registering which modules have already been fully loaded. - -- - -- This cache is necessary to quickly check when a full-transitive-closure - -- reachability query would be valid for some module. - -- - -- Such a query may be invalid if ran on a module in the - -- 'ExternalModuleGraph' whose dependencies have /not yet/ been fully loaded - -- into the EPS. - -- (Recall that interfaces are lazily loaded, and the 'ExternalModuleGraph' - -- is only incrementally updated). - -- - -- To guarantee the full transitive closure of a given module is completely - -- loaded into the EPS (i.e. all interfaces of the modules below this one - -- are also loaded), see @'loadExternalGraphBelow'@ in - -- 'GHC.Iface.Load'. - , isFullyLoadedModule - , setFullyLoadedModule - - -- * Reachability - -- - -- | Fast reachability queries on the external module graph. Similar to - -- reachability queries on 'GHC.Unit.Module.Graph'. - , emgReachableLoop - , emgReachableLoopMany - ) where - -import GHC.Prelude -import GHC.Unit.Module.Graph -import GHC.Data.Graph.Directed.Reachability -import GHC.Data.Graph.Directed -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Bifunctor (first, bimap) -import Data.Maybe -import GHC.Utils.Outputable -import GHC.Unit.Types (UnitId, GenWithIsBoot(..), IsBootInterface(..), mkModule) -import GHC.Utils.Misc - - --------------------------------------------------------------------------------- --- * Main --------------------------------------------------------------------------------- - -data ExternalModuleGraph = ExternalModuleGraph - { external_nodes :: [ExternalGraphNode] - -- This transitive dependency query does not contain hs-boot nodes. - , external_trans :: (ReachabilityIndex ExternalNode, ExternalKey -> Maybe ExternalNode) - , external_fully_loaded :: !(S.Set ExternalKey) } - -type ExternalNode = Node Int ExternalGraphNode - -data ExternalGraphNode - -- | A node for a home package module that is inserted in the EPS. - -- - -- INVARIANT: This type of node can only ever exist if compiling in one-shot - -- mode. In --make mode, it is imperative that the EPS doesn't have any home - -- package modules ever. - = NodeHomePackage - { externalNodeKey :: ModNodeKeyWithUid - , externalNodeDeps :: [ExternalKey] } - -- | A node for packages with at least one module loaded in the EPS. - -- - -- Edge from A to NodeExternalPackage p when A has p as a direct package - -- dependency. - | NodeExternalPackage - { externalPkgKey :: UnitId - , externalPkgDeps :: S.Set UnitId - } - -data ExternalKey - = ExternalModuleKey ModNodeKeyWithUid - | ExternalPackageKey UnitId - deriving (Eq, Ord) - -emptyExternalModuleGraph :: ExternalModuleGraph -emptyExternalModuleGraph = ExternalModuleGraph [] (graphReachability emptyGraph, const Nothing) S.empty - --- | Get the dependencies of an 'ExternalNode' -emgNodeDeps :: Bool -> ExternalGraphNode -> [ExternalKey] -emgNodeDeps drop_hs_boot_nodes = \case - NodeHomePackage _ dps -> map drop_hs_boot dps - NodeExternalPackage _ dps -> map ExternalPackageKey $ S.toList dps - where - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature - | otherwise = IsBoot - - drop_hs_boot (ExternalModuleKey (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (ExternalModuleKey (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid)) - drop_hs_boot x = x - --- | The graph key for a given node -emgNodeKey :: ExternalGraphNode -> ExternalKey -emgNodeKey (NodeHomePackage k _) = ExternalModuleKey k -emgNodeKey (NodeExternalPackage k _) = ExternalPackageKey k - --- | Lookup a key in the EMG. -emgLookupKey :: ExternalKey -> ExternalModuleGraph -> Maybe ExternalGraphNode -emgLookupKey k emg = node_payload <$> (snd (external_trans emg)) k - --------------------------------------------------------------------------------- --- * Extending --------------------------------------------------------------------------------- - -extendExternalModuleGraph :: ExternalGraphNode -> ExternalModuleGraph -> ExternalModuleGraph -extendExternalModuleGraph node ExternalModuleGraph{..} = - ExternalModuleGraph - { external_fully_loaded = external_fully_loaded - , external_nodes = node : external_nodes - , external_trans = first cyclicGraphReachability $ - externalGraphNodes True (node : external_nodes) - } - --------------------------------------------------------------------------------- --- * Loading --------------------------------------------------------------------------------- - -isFullyLoadedModule :: ExternalKey -> ExternalModuleGraph -> Bool -isFullyLoadedModule key graph = S.member key (external_fully_loaded graph) - -setFullyLoadedModule :: ExternalKey -> ExternalModuleGraph -> ExternalModuleGraph -setFullyLoadedModule key graph = graph { external_fully_loaded = S.insert key (external_fully_loaded graph)} - --------------------------------------------------------------------------------- --- * Reachability --------------------------------------------------------------------------------- - --- | Return all nodes reachable from the given key, also known as its full --- transitive closure. --- --- @Nothing@ if the key couldn't be found in the graph. -emgReachableLoop :: ExternalModuleGraph -> ExternalKey -> Maybe [ExternalGraphNode] -emgReachableLoop mg nk = map node_payload <$> modules_below where - (td_map, lookup_node) = external_trans mg - modules_below = - allReachable td_map <$> lookup_node nk - --- | Return all nodes reachable from all of the given keys. -emgReachableLoopMany :: ExternalModuleGraph -> [ExternalKey] -> [ExternalGraphNode] -emgReachableLoopMany mg nk = map node_payload modules_below where - (td_map, lookup_node) = external_trans mg - modules_below = - allReachableMany td_map (mapMaybe lookup_node nk) - --------------------------------------------------------------------------------- --- * Internals --------------------------------------------------------------------------------- - --- | Turn a list of graph nodes into an efficient queriable graph. --- The first boolean parameter indicates whether nodes corresponding to hs-boot files --- should be collapsed into their relevant hs nodes. -externalGraphNodes :: Bool - -> [ExternalGraphNode] - -> (Graph ExternalNode, ExternalKey -> Maybe ExternalNode) -externalGraphNodes drop_hs_boot_nodes summaries = - (graphFromEdgedVerticesUniq nodes, lookup_node) - where - -- Map from module to extra boot summary dependencies which need to be merged in - (boot_summaries, nodes) = bimap M.fromList id $ partitionWith go numbered_summaries - - where - go (s, key) = - case s of - NodeHomePackage (ModNodeKeyWithUid (GWIB mn IsBoot) uid) _deps | drop_hs_boot_nodes - -- Using emgNodeDeps here converts dependencies on other - -- boot files to dependencies on dependencies on non-boot files. - -> Left (mkModule uid mn, emgNodeDeps drop_hs_boot_nodes s) - _ -> normal_case - where - normal_case = - let lkup_key = - case s of - NodeHomePackage (ModNodeKeyWithUid (GWIB mn IsBoot) uid) _deps - -> Just $ mkModule uid mn - _ -> Nothing - - extra = (lkup_key >>= \key -> M.lookup key boot_summaries) - - in Right $ DigraphNode s key $ out_edge_keys $ - (fromMaybe [] extra - ++ emgNodeDeps drop_hs_boot_nodes s) - - numbered_summaries = zip summaries [1..] - - lookup_node :: ExternalKey -> Maybe ExternalNode - lookup_node key = M.lookup key node_map - - lookup_key :: ExternalKey -> Maybe Int - lookup_key = fmap node_key . lookup_node - - node_map :: M.Map ExternalKey ExternalNode - node_map = - M.fromList [ (emgNodeKey s, node) - | node <- nodes - , let s = node_payload node - ] - - out_edge_keys :: [ExternalKey] -> [Int] - out_edge_keys = mapMaybe lookup_key - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- IsBoot; else False - -instance Outputable ExternalGraphNode where - ppr = \case - NodeHomePackage mk ds -> text "NodeHomePackage" <+> ppr mk <+> ppr ds - NodeExternalPackage mk ds -> text "NodeExternalPackage" <+> ppr mk <+> ppr ds - -instance Outputable ExternalKey where - ppr = \case - ExternalModuleKey mk -> text "ExternalModuleKey" <+> ppr mk - ExternalPackageKey uid -> text "ExternalPackageKey" <+> ppr uid - -instance Outputable ExternalModuleGraph where - ppr ExternalModuleGraph{external_nodes, external_fully_loaded} - = text "ExternalModuleGraph" <+> ppr external_nodes <+> ppr external_fully_loaded ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -41,6 +41,8 @@ module GHC.Unit.Module.Graph , ModuleNodeInfo(..) , moduleNodeInfoModule + , moduleNodeInfoUnitId + , moduleNodeInfoMnwib , moduleNodeInfoModuleName , moduleNodeInfoModNodeKeyWithUid , moduleNodeInfoHscSource @@ -48,7 +50,7 @@ module GHC.Unit.Module.Graph , isBootModuleNodeInfo -- * Module graph operations , lengthMG - + , isEmptyMG -- ** 'ModSummary' operations -- -- | A couple of operations on the module graph allow access to the @@ -100,6 +102,10 @@ module GHC.Unit.Module.Graph , ModNodeKey , ModNodeKeyWithUid(..) , mnkToModule + , moduleToMnk + , mnkToInstalledModule + , installedModuleToMnk + , mnkIsBoot , msKey , mnKey , miKey @@ -310,7 +316,7 @@ checkFixedModuleInvariant node_types node = case node of _ -> Nothing -{- Note [Modules Types in the ModuleGraph] +{- Note [Module Types in the ModuleGraph] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Modules can be one of two different types in the module graph. @@ -365,6 +371,14 @@ isBootModuleNodeInfo (ModuleNodeCompile ms) = isBootSummary ms moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName moduleNodeInfoModuleName m = moduleName (moduleNodeInfoModule m) +moduleNodeInfoUnitId :: ModuleNodeInfo -> UnitId +moduleNodeInfoUnitId (ModuleNodeFixed key _) = mnkUnitId key +moduleNodeInfoUnitId (ModuleNodeCompile ms) = ms_unitid ms + +moduleNodeInfoMnwib :: ModuleNodeInfo -> ModuleNameWithIsBoot +moduleNodeInfoMnwib (ModuleNodeFixed key _) = mnkModuleName key +moduleNodeInfoMnwib (ModuleNodeCompile ms) = ms_mnwib ms + -- | Collect the immediate dependencies of a ModuleGraphNode, -- optionally avoiding hs-boot dependencies. -- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is @@ -425,6 +439,9 @@ instance Ord ModuleGraphNode where lengthMG :: ModuleGraph -> Int lengthMG = length . mg_mss +isEmptyMG :: ModuleGraph -> Bool +isEmptyMG = null . mg_mss + -------------------------------------------------------------------------------- -- ** ModSummaries -------------------------------------------------------------------------------- ===================================== compiler/GHC/Unit/Module/ModNodeKey.hs ===================================== @@ -1,4 +1,11 @@ -module GHC.Unit.Module.ModNodeKey ( ModNodeKeyWithUid(..), mnkToModule, mnkIsBoot ) where +module GHC.Unit.Module.ModNodeKey + ( ModNodeKeyWithUid(..) + , mnkToModule + , moduleToMnk + , mnkIsBoot + , mnkToInstalledModule + , installedModuleToMnk + ) where import GHC.Prelude import GHC.Utils.Outputable @@ -7,12 +14,22 @@ import GHC.Unit.Types data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot , mnkUnitId :: !UnitId } deriving (Eq, Ord) -mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface -mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib - mnkToModule :: ModNodeKeyWithUid -> Module mnkToModule (ModNodeKeyWithUid mnwib uid) = Module (RealUnit (Definite uid)) (gwib_mod mnwib) +mnkToInstalledModule :: ModNodeKeyWithUid -> InstalledModule +mnkToInstalledModule (ModNodeKeyWithUid mnwib uid) = Module uid (gwib_mod mnwib) + +-- | Already InstalledModules are always NotBoot +installedModuleToMnk :: InstalledModule -> ModNodeKeyWithUid +installedModuleToMnk mod = ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnit mod) + +moduleToMnk :: Module -> IsBootInterface -> ModNodeKeyWithUid +moduleToMnk mod is_boot = ModNodeKeyWithUid (GWIB (moduleName mod) is_boot) (moduleUnitId mod) + +mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface +mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib + instance Outputable ModNodeKeyWithUid where ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib ===================================== compiler/ghc.cabal.in ===================================== @@ -526,6 +526,7 @@ Library GHC.Driver.MakeSem GHC.Driver.Main GHC.Driver.Make + GHC.Driver.Messager GHC.Driver.MakeAction GHC.Driver.MakeFile GHC.Driver.Monad @@ -956,7 +957,6 @@ Library GHC.Unit.Module.Env GHC.Unit.Module.Graph GHC.Unit.Module.ModNodeKey - GHC.Unit.Module.External.Graph GHC.Unit.Module.Imported GHC.Unit.Module.Location GHC.Unit.Module.ModDetails ===================================== testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs ===================================== @@ -0,0 +1,102 @@ +{-# LANGUAGE RecordWildCards #-} +module Main where + +import GHC +import GHC.Driver.Session +import GHC.Driver.Monad +import GHC.Driver.Env +import GHC.Driver.Make (summariseFile) +import GHC.Driver.Downsweep +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary +import GHC.Unit.Types +import GHC.Unit.Module +import GHC.Unit.Module.ModNodeKey +import GHC.Types.SourceFile +import System.Environment +import Control.Monad (void, when) +import Data.Maybe (fromJust) +import Control.Exception (ExceptionWithContext(..), SomeException) +import Control.Monad.Catch (handle, throwM) +import Control.Exception.Context +import GHC.Utils.Outputable +import Data.List +import GHC.Unit.Env +import GHC.Unit.State +import GHC.Tc.Utils.Monad +import GHC.Iface.Env +import GHC.Driver.Ppr +import GHC.Unit.Home + + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ handle (\(ExceptionWithContext c e :: ExceptionWithContext SomeException) -> + liftIO $ putStrLn (displayExceptionContext c) >> print e >> throwM e) $ do + + -- Set up session + dflags <- getSessionDynFlags + setSessionDynFlags (dflags { verbosity = 1 }) + hsc_env <- getSession + setSession $ hscSetActiveUnitId mainUnitId hsc_env + + -- Get ModSummaries for our test modules + msA <- getModSummaryFromTarget "T1A.hs" + msB <- getModSummaryFromTarget "T1B.hs" + msC <- getModSummaryFromTarget "T1C.hs" + + let targets = [ Target (TargetModule (ms_mod_name msA)) True (moduleUnitId $ ms_mod msA) Nothing + , Target (TargetModule (ms_mod_name msB)) True (moduleUnitId $ ms_mod msB) Nothing + , Target (TargetModule (ms_mod_name msC)) True (moduleUnitId $ ms_mod msC) Nothing + ] + + setTargets targets + + -- Compile interfaces for our modules + load LoadAllTargets + + hsc_env <- getSession + setSession $ hsc_env { hsc_dflags = (hsc_dflags hsc_env) { ghcMode = OneShot } } + hsc_env <- getSession + + + -- Create ModNodeKeys with unit IDs + let keyA = msKey msA + keyB = msKey msB + keyC = msKey msC + + let mkGraph s = do + ([], nodes) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed s [] + return $ mkModuleGraph nodes + + graph <- liftIO $ mkGraph [ModuleNodeCompile msC] + + liftIO $ putStrLn "loaded" + -- 1. Check that the module graph is valid + let invariantErrors = checkModuleGraph graph + + case invariantErrors of + [] -> liftIO $ putStrLn "PASS Test passed" + errors -> do + liftIO $ putStrLn "FAIL Test failed - invariant violations" + liftIO $ putStrLn $ showSDoc dflags $ vcat (map ppr errors) + + -- 2. Check that from the root, we can reach the "ghc-internal" package. + let ghcInternalPackage = NodeKey_ExternalUnit ghcInternalUnitId + let root = NodeKey_Module keyC + let reached = mgQuery graph root ghcInternalPackage + if not reached + then liftIO $ putStrLn "FAIL Test failed - cannot reach ghc-internal" + else liftIO $ putStrLn "PASS Test passed" + + + + where + + -- Helper to get ModSummary from a target file + getModSummaryFromTarget :: FilePath -> Ghc ModSummary + getModSummaryFromTarget file = do + hsc_env <- getSession + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + return ms ===================================== testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.stdout ===================================== @@ -0,0 +1,6 @@ +[1 of 3] Compiling T1A ( T1A.hs, T1A.o ) +[2 of 3] Compiling T1B ( T1B.hs, T1B.o ) +[3 of 3] Compiling T1C ( T1C.hs, T1C.o ) +loaded +PASS Test passed +PASS Test passed ===================================== testsuite/tests/ghc-api/fixed-nodes/all.T ===================================== @@ -13,3 +13,11 @@ test('ModuleGraphInvariants', ], compile_and_run, ['-package ghc']) + +test('InterfaceModuleGraph', + [extra_run_opts(f'"{config.libdir}"'), + extra_files(['T1A.hs', 'T1B.hs', 'T1C.hs']), + wasm_broken(25953) + ], + compile_and_run, + ['-package ghc']) ===================================== testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs ===================================== @@ -46,13 +46,8 @@ lookupModule :: ModuleName -- ^ Name of the module -> TcPluginM Module lookupModule mod_nm = do hsc_env <- getTopEnv - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - let fc = hsc_FC hsc_env - let units = hsc_units hsc_env let home_unit = hsc_home_unit hsc_env - -- found_module <- findPluginModule fc fopts units home_unit mod_name - found_module <- tcPluginIO $ findPluginModule fc fopts units (Just home_unit) mod_nm + found_module <- tcPluginIO $ findPluginModule hsc_env mod_nm case found_module of FoundModule h -> return (fr_mod h) _ -> do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d47bf7769758a1c8f65b66bb41b926c2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d47bf7769758a1c8f65b66bb41b926c2... You're receiving this email because of your account on gitlab.haskell.org.