sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: ff3a0fcc by sheaf at 2026-08-25T15:04:16+02:00 2-phase Cache/Search Finder monad - - - - - 18 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Concurrency.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Plugin.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Unit/Finder.hs - ghc/GHCi/UI.hs - ghc/Main.hs - linters/lint-codes/LintCodes/Static.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -1693,14 +1693,14 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do case home of Just m -> return m Nothing -> liftIO $ do - res <- findImportedModule hsc_env LookupUser mod_name pkgqual + res <- runFinderM $ findImportedModule hsc_env LookupUser mod_name pkgqual case res of Found loc m | notHomeModuleMaybe mhome_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err _ -> liftIO $ do - res <- findImportedModule hsc_env LookupUser mod_name pkgqual + res <- runFinderM $ findImportedModule hsc_env LookupUser mod_name pkgqual case res of Found _ m -> return m err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err @@ -1741,7 +1741,7 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env let sec = initSourceErrorContext dflags let fopts = initFinderOpts dflags - res <- findExposedPackageModule fc fopts units LookupUser mod_name NoPkgQual + res <- runFinderM $ findExposedPackageModule fc fopts units LookupUser mod_name NoPkgQual case res of Found _ m -> return m err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err @@ -1791,7 +1791,7 @@ lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env let sec = initSourceErrorContext dflags let fopts = initFinderOpts dflags - res <- findExposedPackageModule fc fopts units LookupUser mod_name NoPkgQual + res <- runFinderM $ findExposedPackageModule fc fopts units LookupUser mod_name NoPkgQual case res of Found _ m -> return [m] err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Driver/Concurrency.hs ===================================== @@ -3,7 +3,7 @@ {-# LANGUAGE BlockArguments #-} module GHC.Driver.Concurrency - ( -- * Worker limit and concurrency + ( -- * Worker limit WorkerLimit(..) -- * Concurrent worker scheduling @@ -17,7 +17,7 @@ module GHC.Driver.Concurrency , runCoordinatingWorkers , WorkerCoordination(runBlockingAction) - -- ** Demand-driven work + -- ** Demand-driven work (push-based concurrency) , Demand , Rule , RuleAnswer(..) ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -348,7 +348,7 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do home_uid = homeUnitId (hsc_home_unit hsc_env) env = DownsweepEnv { ds_hsc_env = hsc_env - , ds_mode = DownsweepUseGiven + , ds_mode = DownsweepUseFixed , ds_prior = Map.empty , ds_excl_mods = [] } @@ -407,7 +407,7 @@ downsweepInstalledModules hsc_env mods = do -- to this function should already know that we can find the modules we need -- to load. for_ installed_mods $ \ i -> - findExactModule hsc_env i NotBoot >>= \case + runFinderM (findExactModule hsc_env i NotBoot) >>= \case InstalledFound {} -> return () _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i @@ -543,13 +543,14 @@ instance Outputable (Some DownsweepQuery) where data DownsweepMode -- | @--make@: home modules are summarised from source and compiled. = DownsweepUseCompile - -- | One-shot mode: home modules are taken from their interface files, which - -- must already exist on disk. + -- | Home modules are taken from their interface files (one-shot mode), or + -- from the module graph when already present there (GHCi's interactive + -- imports, see Note [runTcInteractive module graph]). + -- + -- Whether a module actually exists is decided by its 'Fixed' query: a + -- module whose interface cannot be found or read produces no graph node, + -- and imports resolving to it produce no edge. | DownsweepUseFixed - -- | GHCi's interactive imports: home modules are assumed to be in the module - -- graph already, so their interfaces are taken as given rather than looked - -- for on disk. See Note [runTcInteractive module graph]. - | DownsweepUseGiven -- | A 'ModSummary's provenance during downsweep: an old previously constructed -- ModSummary, that might be potentially outdated, or a freshly constructed one @@ -725,13 +726,19 @@ downsweepRule :: DownsweepEnv -> Demand DownsweepQuery -> Rule DownsweepQuery downsweepRule env demand query = case query of - Resolve home_uid lkp -> pure $ AnswerDefer \ worker_env -> do - -- NB: it might be worth answering inline when the resolution is - -- immediately available from the finder cache. - resolution <- - resolveDownsweepImport (worker_local_env worker_env) home_uid lkp - demandResolution demand home_uid resolution - return resolution + Resolve home_uid lkp -> do + mbCached <- runFinderCacheM $ resolveDownsweepImport env home_uid lkp + case mbCached of + InCache resolution -> do + demandResolution demand home_uid resolution + return $ AnswerInline resolution + NotInCache search -> return $ AnswerDefer \ _worker_env -> do + -- The search closes over the downsweep environment rather than the + -- worker-local one; that is fine because it neither logs nor uses + -- temporary files. + resolution <- search + demandResolution demand home_uid resolution + return resolution Summarise uid path -> pure $ AnswerDefer \ worker_env -> do result <- summariseHomeSourceFile (worker_local_env worker_env) uid path @@ -805,41 +812,41 @@ moduleDiscoveries ms = moduleEdgeImports ms ++ boot_source | IsBoot <- [isBootSummary ms] ] -- | Resolve a module lookup made from the given home unit. -resolveDownsweepImport :: DownsweepEnv -> UnitId -> UnresolvedImport PkgQual -> IO ImportResolution +resolveDownsweepImport :: DownsweepEnv -> UnitId -> UnresolvedImport PkgQual -> FinderM ImportResolution resolveDownsweepImport env home_uid lkp | ui_mod_name lkp `elem` ds_excl_mods env - = return ResolvedNotFound + = pure ResolvedNotFound | otherwise - = do - found <- resolveImport hsc_env lkp - case found of - Found location mod - | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env - -> home_module location mod - | VirtUnit iud <- moduleUnit mod - , not (isHomeModule home_unit mod) - -> return $ ResolvedInstantiation iud - | otherwise - -> return $ ResolvedExternal (moduleUnitId mod) - _ -> return ResolvedNotFound - -- Not found. If it is TRULY not found at all, we'll error when we - -- actually try to compile. + = classify =<< resolveImport hsc_env lkp where home_unit = ue_unitHomeUnit home_uid (hsc_unit_env (ds_hsc_env env)) -- All operations happen relative to the home unit the import was made from. hsc_env = hscSetActiveHomeUnit home_unit (ds_hsc_env env) + classify :: FindResult -> FinderM ImportResolution + classify = \case + Found location mod + | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env + -> home_module location mod + | VirtUnit iud <- moduleUnit mod + , not (isHomeModule home_unit mod) + -> pure $ ResolvedInstantiation iud + | otherwise + -> pure $ ResolvedExternal (moduleUnitId mod) + _ -> pure ResolvedNotFound + -- Not found. If it is TRULY not found at all, we'll error when we + -- actually try to compile. + + home_module :: ModLocation -> Module -> FinderM ImportResolution home_module location mod = case ds_mode env of DownsweepUseCompile -> - return $ case ml_hs_file_ospath location of + pure $ case ml_hs_file_ospath location of Just path -> ResolvedHome key path Nothing -> ResolvedNotFound - DownsweepUseFixed -> do - -- The finder returns a path to the .hi(-boot) file even if it doesn't - -- actually exist, so check before concluding it's there. - exists <- doesFileExist (ml_hi_file location) - return $ if exists then ResolvedFixed key else ResolvedNotFound - DownsweepUseGiven -> return $ ResolvedFixed key + DownsweepUseFixed -> + -- The resulting 'Fixed' query will determine whether the + -- interface file actually exists (see 'DownsweepUseFixed'). + pure $ ResolvedFixed key where key = moduleToMnk mod (ui_boot lkp) @@ -856,7 +863,7 @@ summariseHomeSourceFile env uid path = -- it records. readFixedModule :: DownsweepEnv -> ModNodeKeyWithUid -> IO (Maybe FixedModule) readFixedModule (DownsweepEnv { ds_hsc_env = hsc_env }) key = - findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) >>= \case + runFinderM (findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)) >>= \case InstalledFound loc -> 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) @@ -909,9 +916,16 @@ downsweepEdgeTarget answers home_uid lkp = Nothing -> Nothing Just (Identity resolution) -> case resolution of ResolvedNotFound -> Nothing - ResolvedFixed key -> Just (NodeKey_Module key) ResolvedExternal uid -> Just (NodeKey_ExternalUnit uid) ResolvedInstantiation iud -> Just (NodeKey_Unit iud) + ResolvedFixed key -> + -- Only emit an edge if the target node actually materialised + -- (the interface file of a 'Fixed' node might turn out not to exist, + -- e.g. due to the self-boot check). + case lookupDMap (Fixed key) answers of + Just (Identity (Just {})) + -> Just (NodeKey_Module key) + _ -> Nothing ResolvedHome key path -> case lookupDMap (Summarise (mnkUnitId key) path) answers of Just (Identity (SummariseFound ms)) | msKey ms == key @@ -1043,7 +1057,7 @@ getRootSummary env target = { ui_pkg_qual = ThisPkg (homeUnitId home_unit) } -- A module target has to name a home module we can compile. not_found = return $ Left (moduleNotFoundErr uid modl) - resolution <- resolveDownsweepImport env uid root_imp + resolution <- runFinderM $ resolveDownsweepImport env uid root_imp case resolution of ResolvedHome key path -> summarise (Just (uid, root_imp, resolution)) (mnkUnitId key) path ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -318,7 +318,7 @@ warnUnknownModules hsc_env dflags mod_graph = do hidden_warns = hidden_mods `minusUniqSet` unit_mods - lookupModule mn = findImportedModule hsc_env LookupUser mn NoPkgQual + lookupModule mn = runFinderM $ findImportedModule hsc_env LookupUser mn NoPkgQual check_reexport mn = do fr <- lookupModule (reexportFrom mn) ===================================== compiler/GHC/Driver/MakeFile.hs ===================================== @@ -300,7 +300,7 @@ findDependency :: HscEnv findDependency hsc_env (L srcloc imp) include_pkg_deps = do -- Find the module; this will be fast because -- we've done it once during downsweep. - r <- resolveImport hsc_env imp + r <- runFinderM $ resolveImport hsc_env imp case r of Found loc _ -- Home package: just depend on the .hi or hi-boot file ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -293,7 +293,7 @@ lookupKnownName kk_ns name loadKnownKeyOccMaps :: IfM lcl (MaybeErr IfaceMessage KnownKeyNameMaps) loadKnownKeyOccMaps = do { hsc_env <- getTopEnv - ; fr <- liftIO $ + ; fr <- liftIO $ runFinderM $ findImportedModule hsc_env LookupSystem eSSENTIALS_NAME NoPkgQual ; case fr of Found _ mod -> Succeeded <$> known_key_maps mod @@ -650,7 +650,7 @@ loadSrcInterface_maybe doc scope mod want_boot maybe_pkg -- interface; it will call the Finder again, but the ModLocation will be -- cached from the first search. = do hsc_env <- getTopEnv - res <- liftIO $ findImportedModule hsc_env scope mod maybe_pkg + res <- liftIO $ runFinderM $ findImportedModule hsc_env scope mod maybe_pkg case res of Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) -- TODO: Make sure this error message is good @@ -1237,7 +1237,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do nest 4 (text "reason:" <+> doc_str)]) -- Look for the file - mb_found <- liftIO (findExactModule hsc_env mod hi_boot_file) + mb_found <- liftIO $ runFinderM $ findExactModule hsc_env mod hi_boot_file case mb_found of InstalledFound loc -> do -- See Note [Home module load error] ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -658,7 +658,7 @@ checkDependencies hsc_env summary iface classify_imports imports = liftIO $ traverse (\ (L _ e) -> let reason = ModuleChanged (ui_mod_name e) - in classify (ui_level e) reason <$> resolveImport hsc_env e) + in classify (ui_level e) reason <$> runFinderM (resolveImport hsc_env e)) imports logger = hsc_logger hsc_env ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -168,7 +168,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do let fc = ldFinderCache opts let fopts = ldFinderOpts opts - mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) + mb_stuff <- runFinderM $ findHomeModule fc fopts home_unit (moduleName mod) case mb_stuff of Found loc _ -> do from_bc <- ldLoadByteCode opts mod loc @@ -179,7 +179,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do fallback_no_bytecode home_unit mod = do let fc = ldFinderCache opts let fopts = ldFinderOpts opts - mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) + mb_stuff <- runFinderM $ findHomeModule fc fopts home_unit (moduleName mod) case mb_stuff of Found loc _ -> do mb_lnk <- findObjectLinkableMaybe mod loc ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -57,7 +57,7 @@ import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS ) import GHC.Types.Name.Reader import GHC.Types.Unique.DFM -import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) +import GHC.Unit.Finder ( FindResult(..), runFinderM, findPluginModule ) import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) ) import GHC.Unit.Module.ModIface @@ -345,7 +345,7 @@ lookupRdrNameInModuleForPlugins :: HasDebugCallStack lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let dflags = hsc_dflags hsc_env -- First find the unit the module resides in by searching exposed units and home modules - found_module <- findPluginModule hsc_env mod_name + found_module <- runFinderM $ findPluginModule hsc_env mod_name case found_module of Found _ mod -> do -- Find the exports of the module ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -118,7 +118,7 @@ import System.Directory ( createDirectoryIfMissing ) import GHC.Unit.Finder.Types -import GHC.Unit.Finder (findObjectLinkableMaybe, findHomeModule) +import GHC.Unit.Finder (findObjectLinkableMaybe, findHomeModule, runFinderM) import GHC.Driver.Config.Finder (initFinderOpts) import qualified GHC.Unit.Home.Graph as HUG @@ -491,7 +491,7 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache case ue_homeUnit unit_env of Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod) Just home_unit -> do - mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) + mb_stuff <- runFinderM $ findHomeModule finder_cache finder_opts home_unit (moduleName mod) case mb_stuff of Found loc mod -> found loc mod _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod) ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1633,7 +1633,7 @@ metaHandlersTcM runInIO = TH.MetaHandlers { let home_unit = hsc_home_unit hsc_env let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags - r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) + r <- liftIO $ runFinderM $ findHomeModule fc fopts home_unit (mkModuleName plugin) let err = TcRnTHError $ AddInvalidCorePlugin plugin case r of Found {} -> addErr err ===================================== compiler/GHC/Tc/Plugin.hs ===================================== @@ -104,7 +104,8 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do hsc_env <- getTopEnv - tcPluginIO $ Finder.findImportedModule hsc_env Finder.LookupUser mod_name mb_pkg + tcPluginIO $ Finder.runFinderM $ + Finder.findImportedModule hsc_env Finder.LookupUser mod_name mb_pkg lookupOrig :: Module -> OccName -> TcPluginM Name lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod ===================================== compiler/GHC/Tc/Utils/Backpack.hs ===================================== @@ -284,7 +284,7 @@ implicitRequirements :: HscEnv implicitRequirements hsc_env normal_imports = fmap concat $ forM normal_imports $ \e -> do - found <- resolveImport hsc_env e + found <- runFinderM $ resolveImport hsc_env e case found of Found _ mod | notHomeModuleMaybe mhome_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) @@ -306,7 +306,7 @@ implicitRequirementsShallow hsc_env normal_imports = go [] normal_imports go acc [] = pure acc go accR (e:imports) = do - found <- resolveImport hsc_env e + found <- runFinderM $ resolveImport hsc_env e let acc' = case found of Found _ mod | notHomeModuleMaybe mhome_unit mod -> case moduleUnit mod of ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -4,18 +4,28 @@ -} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} -- | Module finder module GHC.Unit.Finder ( + + -- * Finder result FindResult(..), InstalledFindResult(..), + + -- * Finder cache FinderOpts(..), FinderCache(..), initFinderCache, + + -- ** Finder monad + FinderM, runFinderCacheM, runFinderM, + InCache(..), + + -- * Finder operations + ModuleLookupScope(..), findImportedModule, resolveImport, - ModuleLookupScope(..), findPluginModule, findExactModule, findHomeModule, @@ -85,6 +95,9 @@ import qualified System.Directory as SD import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE +import GHC.TypeError (ErrorMessage(..), Unsatisfiable, unsatisfiable) +import Control.Monad.IO.Class + type FileExt = OsString -- Filename extension type BaseName = OsPath -- Basename of file @@ -173,6 +186,96 @@ getDirHash dir = do let hash = fingerprintFingerprints s_hashes return hash +-- ----------------------------------------------------------------------------- +-- Finder monad, handling finder cache hits + +-- | The result of a lookup that consults the finder caches before searching +-- the file system. +data InCache a + -- | The result was in a cache; no filesystem access was performed. + = InCache !a + -- | The result was not cached. + | NotInCache (IO a) -- ^ search action to compute the result + -- (may perform filesystem access) + deriving stock Functor + +-- | Monad for finder operations. +-- +-- A finder operation is split into two phases: +-- +-- - a cache-only phase with no filesystem access, +-- - from the first cache miss onwards, a residual 'IO' computation that may +-- access the filesystem. +newtype FinderM a = + FinderM (IO (InCache a)) + -- ^ Invariant: the I/O action only performs benign I/O (such as reading + -- from the finder cache, i.e. 'lookupFinderCache'). + -- + -- It is not allowed to perform any filesystem access. + +-- | Like 'runFinderM', but separates the finder action into the cache lookup +-- and the search action. +runFinderCacheM :: FinderM a -> IO (InCache a) +runFinderCacheM (FinderM f) = f + +-- | Run a finder action. +runFinderM :: FinderM a -> IO a +runFinderM = inCache_result <=< runFinderCacheM + +instance Functor FinderM where + fmap f (FinderM io) = FinderM $ fmap (fmap f) io + +instance Applicative FinderM where + pure = FinderM . pure . InCache + (<*>) = ap + +-- | Sequencing of finder computations: the overall computation remains +-- "in the cache" as long as every individual step completes "in the cache". +-- +-- After the first cache miss, all residual operations (including further +-- cache lookups) move into the search action. +instance Monad FinderM where + FinderM io >>= f = FinderM $ io >>= \ case + InCache a -> runFinderCacheM (f a) + NotInCache go -> pure $ NotInCache $ + go >>= \ a -> inCache_result =<< runFinderCacheM (f a) + +-- | There is no lawful 'MonadIO' instance for 'FinderM': to guarantee that +-- @liftIO . pure = pure@, 'liftIO' would have to run the action in the +-- cache-only phase, defeating the guarantee that 'InCache' results involve +-- no filesystem access. +-- +-- All I/O in 'FinderM' enters through 'withCacheOrElse'. +instance + Unsatisfiable + ( Text "No (lawful) 'MonadIO' instance for 'FinderM'." + :$$: Text "Use 'withCacheOrElse' to embed an I/O operation into the search phase of 'FinderM'." + ) + => MonadIO FinderM where + liftIO = unsatisfiable + +-- | Obtain the result from an 'InCache' value, running the inner search +-- operation in case of a cache miss. +inCache_result :: InCache a -> IO a +inCache_result (InCache a) = pure a +inCache_result (NotInCache go) = go + +-- | Look up an 'InstalledModule' in the finder cache, falling back to the +-- given search action in case of cache miss (recording its result in the cache). +withCacheOrElse + :: FinderCache + -> InstalledModule + -> IO InstalledFindResult -- ^ search action (only executed on cache miss) + -> FinderM InstalledFindResult +withCacheOrElse fc mod search = FinderM $ do + m <- lookupFinderCache fc mod + case m of + Just result -> pure $ InCache result + Nothing -> pure $ NotInCache $ do + result <- search + addToFinderCache fc mod result + return result + -- ----------------------------------------------------------------------------- --External entry points @@ -180,7 +283,7 @@ getDirHash dir = do -- -- Handles user-written module imports, @SOURCE@ imports, plugin module imports, -- system imports, etc. -resolveImport :: HscEnv -> UnresolvedImport PkgQual -> IO FindResult +resolveImport :: HscEnv -> UnresolvedImport PkgQual -> FinderM FindResult resolveImport hsc_env (UnresolvedImport { ui_scope, ui_pkg_qual, ui_boot, ui_mod_name }) = do res <- findImportedModule hsc_env ui_scope ui_mod_name ui_pkg_qual case (res, ui_boot) of @@ -196,7 +299,7 @@ findImportedModule -- ^ The module name to look up -> PkgQual -- ^ Optional PackageImports package name - -> IO FindResult + -> FinderM FindResult findImportedModule hsc_env scope mod pkg_qual = let fc = hsc_FC hsc_env mb_home_unit = hsc_home_unit_maybe hsc_env @@ -223,7 +326,7 @@ findImportedModuleNoHsc -> ModuleLookupScope -> ModuleName -> PkgQual - -> IO FindResult + -> FinderM FindResult findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name mb_pkg | LookupPlugin <- scope = findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit mod_name @@ -254,19 +357,19 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit Nothing -> other_fopts Just home_unit_id -> (home_unit_id, fopts) : other_fopts - home_import :: IO FindResult + home_import :: FinderM FindResult home_import = case mb_home_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit") - home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult + home_pkg_import :: (UnitId, FinderOpts) -> FinderM FindResult home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name - pkg_import :: IO FindResult + pkg_import :: FinderM FindResult pkg_import = findExposedPackageModule fc fopts unit_state scope mod_name mb_pkg - unqual_import :: IO FindResult + unqual_import :: FinderM FindResult unqual_import = findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name @@ -291,7 +394,7 @@ findPluginModuleNoHsc -> HomeModuleNameProvidersMap -> Maybe HomeUnit -> ModuleName - -> IO FindResult + -> FinderM FindResult findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name = findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit LookupUser mod_name @@ -303,7 +406,7 @@ findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(J findPluginModuleNoHsc fc fopts ue _ Nothing mod_name = findExposedPluginPackageModule fc fopts (ue_homeUnitState ue) mod_name -findPluginModule :: HscEnv -> ModuleName -> IO FindResult +findPluginModule :: HscEnv -> ModuleName -> FinderM FindResult findPluginModule hsc_env mod_name = do let fc = hsc_FC hsc_env mb_home_unit = hsc_home_unit_maybe hsc_env @@ -375,7 +478,7 @@ findHomeUnitDepModule -> ModuleLookupScope -> ModuleName -> (UnitId, FinderOpts) - -> IO FindResult + -> FinderM FindResult findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name (uid, opts) -- If the module is reexported, then look for it as if it was from the -- perspective of the package which reexports it. @@ -402,7 +505,7 @@ findHomeModuleAmongDeps -> Maybe HomeUnit -> ModuleLookupScope -> ModuleName - -> IO FindResult + -> FinderM FindResult findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) -- Do not try to be smart and change this to `foldr orIfNotFound home_import @@ -433,7 +536,7 @@ findHomeOrRegularPackageModule -> Maybe HomeUnit -> ModuleLookupScope -> ModuleName - -> IO FindResult + -> FinderM FindResult findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name = findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name @@ -448,7 +551,15 @@ findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_hom -- | 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 + :: FinderCache + -> FinderOpts + -> UnitEnvGraph FinderOpts + -> UnitState + -> Maybe HomeUnit + -> InstalledModule + -> IsBootInterface + -> FinderM InstalledFindResult findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do res <- case mb_home_unit of Just home_unit @@ -461,13 +572,12 @@ findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc)) _ -> 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 :: HscEnv -> InstalledModule -> IsBootInterface -> FinderM InstalledFindResult findExactModule hsc_env mod is_boot = do let dflags = hsc_dflags hsc_env let fc = hsc_FC hsc_env @@ -476,7 +586,6 @@ findExactModule hsc_env mod is_boot = do let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot - -- ----------------------------------------------------------------------------- -- Helpers @@ -504,28 +613,17 @@ orIfNotFound this or_this = do _other -> return res2 _other -> return res --- | Helper function for 'findHomeModule': this function wraps an IO action --- which would look up @mod_name@ in the file system (the home package), --- and first consults the 'hsc_FC' cache to see if the lookup has already --- been done. Otherwise, do the lookup (with the IO action) and save --- the result in the finder cache and the module location cache (if it --- was successful.) -homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult -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 -> ModuleLookupScope -> ModuleName -> PkgQual -> IO FindResult +findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleLookupScope -> ModuleName -> PkgQual -> FinderM FindResult findExposedPackageModule fc fopts units scope mod_name mb_pkg = findLookupResult fc fopts $ lookupModuleWithSuggestions units scope mod_name mb_pkg -findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult +findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> FinderM FindResult findExposedPluginPackageModule fc fopts units mod_name = findLookupResult fc fopts $ lookupPluginModuleWithSuggestions units LookupUser mod_name NoPkgQual -findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult +findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> FinderM FindResult findLookupResult fc fopts r = case r of LookupFound m pkg_conf -> do let im = fst (getModuleInstantiation m) @@ -570,16 +668,6 @@ findLookupResult fc fopts r = case r of , fr_unusables = [] , fr_suggestions = suggest' }) -modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult -modLocationCache fc mod do_this = do - m <- lookupFinderCache fc mod - case m of - Just result -> return result - Nothing -> do - result <- do_this - addToFinderCache fc mod result - return result - addModuleToFinder :: FinderCache -> Module -> ModLocation -> HscSource -> IO () addModuleToFinder fc mod loc src_flavour = do let imod = toUnitId <$> mod @@ -597,7 +685,7 @@ addHomeModuleToFinder fc home_unit mod_name loc src_flavour = do -- ----------------------------------------------------------------------------- -- The internal workers -findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult +findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> FinderM FindResult findHomeModule fc fopts home_unit mod_name = do let uid = homeUnitAsUnit home_unit r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name @@ -622,7 +710,7 @@ mkHomeHidden uid = , fr_unusables = [] , fr_suggestions = []} -findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult +findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> FinderM FindResult findHomePackageModule fc fopts home_unit mod_name = do let uid = RealUnit (Definite home_unit) r <- findInstalledHomeModule fc fopts home_unit mod_name @@ -655,9 +743,9 @@ findHomePackageModule fc fopts home_unit mod_name = do -- -- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to -- call this.) -findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO InstalledFindResult -findInstalledHomeModule fc fopts home_unit mod_name = do - homeSearchCache fc home_unit mod_name $ +findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> FinderM InstalledFindResult +findInstalledHomeModule fc fopts home_unit mod_name = + withCacheOrElse fc (mkModule home_unit mod_name) $ let maybe_working_dir = finder_workingDirectory fopts home_path = case maybe_working_dir of @@ -701,7 +789,7 @@ augmentImports work_dir (fp:fps) | otherwise = (work_dir </> fp) : augmentImports work_dir fps -- | Search for a module in external packages only. -findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult +findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> FinderM InstalledFindResult findPackageModule fc unit_state fopts mod = do let pkg_id = moduleUnit mod case lookupUnitId unit_state pkg_id of @@ -715,11 +803,11 @@ findPackageModule fc unit_state fopts mod = do -- the 'UnitInfo' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config. -findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> IO InstalledFindResult +findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> FinderM InstalledFindResult findPackageModule_ fc fopts mod pkg_conf = do massertPpr (moduleUnit mod == unitId pkg_conf) (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf)) - modLocationCache fc mod $ + withCacheOrElse fc mod $ let tag = waysBuildTag (finder_ways fopts) ===================================== ghc/GHCi/UI.hs ===================================== @@ -2378,7 +2378,7 @@ addModule files = do checkTargetModule :: GhciMonad m => ModuleName -> m Bool checkTargetModule m = do hsc_env <- GHC.getSession - result <- liftIO $ + result <- liftIO $ Finder.runFinderM $ Finder.findImportedModule hsc_env Finder.LookupUser m NoPkgQual case result of Found _ _ -> return True ===================================== ghc/Main.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins ) import GHC.Unit.Module ( ModuleName, mkModuleName ) import GHC.Unit.Module.ModIface import GHC.Unit.State ( pprUnits, pprUnitsSimple ) -import GHC.Unit.Finder ( findImportedModule, FindResult(..) ) +import GHC.Unit.Finder ( findImportedModule, runFinderM, FindResult(..) ) import GHC.Unit.Types ( IsBootInterface(..) ) import GHC.Types.Basic ( failed ) @@ -492,7 +492,7 @@ abiHash strs = do let find_it str = do let modname = mkModuleName str - r <- findImportedModule hsc_env LookupUser modname NoPkgQual + r <- runFinderM $ findImportedModule hsc_env LookupUser modname NoPkgQual case r of Found _ m -> return m _error -> ===================================== linters/lint-codes/LintCodes/Static.hs ===================================== @@ -67,7 +67,7 @@ import GHC.Types.PkgQual import GHC.Tc.Utils.Monad ( initIfaceLoad ) import GHC.Unit.Finder - ( FindResult(..), ModuleLookupScope(..), findImportedModule ) + ( FindResult(..), ModuleLookupScope(..), findImportedModule, runFinderM ) import GHC.Utils.Outputable ( text ) import Language.Haskell.Syntax.Module.Name @@ -157,7 +157,7 @@ ghcDiagnosticCodeTyCon mb_libDir = ; liftIO -- STEP 2: look up the module "GHC.Types.Error.Codes" - do { res <- findImportedModule hsc_env LookupUser (mkModuleName "GHC.Types.Error.Codes") NoPkgQual + do { res <- runFinderM $ findImportedModule hsc_env LookupUser (mkModuleName "GHC.Types.Error.Codes") NoPkgQual ; case res of { Found _ modl -> ===================================== utils/haddock/haddock-api/src/Haddock/Interface.hs ===================================== @@ -69,7 +69,7 @@ import GHC.Tc.Utils.Monad (initIfaceLoad, initIfaceLcl) import GHC.Tc.Utils.Env (lookupGlobal_maybe) import GHC.Types.Error (mkUnknownDiagnostic) import GHC.Types.Name.Occurrence (emptyOccEnv) -import GHC.Unit.Finder (findImportedModule, ModuleLookupScope(..), FindResult(Found)) +import GHC.Unit.Finder (findImportedModule, runFinderM, ModuleLookupScope(..), FindResult(Found)) import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable import GHC.Unit.Module.Graph (ModuleGraphNode (..), ModuleNodeInfo(..)) @@ -386,7 +386,7 @@ createOneShotIface verbosity flags instIfaceMap moduleNameStr = do Nothing -> dflags -- We should find the module here, otherwise there would have been an error earlier. - res <- liftIO $ findImportedModule hsc_env LookupUser moduleNm NoPkgQual + res <- liftIO $ runFinderM $ findImportedModule hsc_env LookupUser moduleNm NoPkgQual let hieFilePath = case res of Found ml _ -> ml_hie_file ml _ -> throwE "createOneShotIface: module not found" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff3a0fccc254ac4f85aff5e394f60cc8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff3a0fccc254ac4f85aff5e394f60cc8... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help