Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC Commits: e124b9ef by Matthew Pickering at 2025-04-23T14:42:53+01:00 downsweep: Move functions to top level and use DownsweepM monad This refactoring moves the functions in GHC.Driver.Downsweep to the top-level (rather than a very long where clause), and uses a monad to thread around the relevant configuration options. In the splice improrts patch, I need to use a different entry point into these functions, so I have separated this refactoring into a separate commit. - - - - - a55ce077 by Matthew Pickering at 2025-04-23T15:20:56+01:00 GHCi and tests - - - - - 4b4b4c5a by Matthew Pickering at 2025-04-23T16:35:03+01:00 Test self-edges - - - - - 19 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/Stage.hs - ghc/GHCi/UI.hs - + testsuite/tests/splice-imports/SI30.stdout - + testsuite/tests/splice-imports/SI31.script - + testsuite/tests/splice-imports/SI31.stderr - + testsuite/tests/splice-imports/SI32.script - + testsuite/tests/splice-imports/SI32.stdout - + testsuite/tests/splice-imports/SI33.script - + testsuite/tests/splice-imports/SI33.stdout - + testsuite/tests/splice-imports/SI34.hs - + testsuite/tests/splice-imports/SI34.stderr - + testsuite/tests/splice-imports/SI34M1.hs - + testsuite/tests/splice-imports/SI34M2.hs - + testsuite/tests/splice-imports/SI35.hs - + testsuite/tests/splice-imports/SI35A.hs - testsuite/tests/splice-imports/all.T Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -13,6 +13,7 @@ module GHC.Driver.Downsweep , downsweepThunk , downsweepInstalledModules , downsweepFromRootNodes + , downsweepInteractiveImports , DownsweepMode(..) -- * Summary functions , summariseModule @@ -49,6 +50,9 @@ import GHC.Iface.Load import GHC.Parser.Header import GHC.Rename.Names import GHC.Tc.Utils.Backpack +import GHC.Runtime.Context + +import Language.Haskell.Syntax.ImpExp import GHC.Data.Graph.Directed import GHC.Data.FastString @@ -76,6 +80,8 @@ import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.Map import GHC.Types.PkgQual +import GHC.Types.Basic + import GHC.Unit import GHC.Unit.Env @@ -236,6 +242,46 @@ downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do (GhcDriverMessage <$> unionManyMessages errs) return (mkModuleGraph mg) +-- | Construct a module graph starting from the interactive context. +-- Produces, a thunk, which when forced will perform the downsweep. +-- This graph contains the current interactive module, and its dependencies. + +-- This is a first approximation for this function. +downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph +downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do + let imps = ic_imports (hsc_IC hsc_env) + + let mn = icInteractiveModule ic + let ml = pprPanic "withInteractiveModuleNode" (ppr mn <+> ppr imps) + let key = moduleToMnk mn NotBoot + let node_type = ModuleNodeFixed key ml + + let edges = map mkEdge imps + let env = DownsweepEnv hsc_env DownsweepUseCompile mempty [] + (module_edges, graph, _) <- runDownsweepM env $ loopImports edges M.empty Map.empty + let node = ModuleNode module_edges node_type + + let all_nodes = M.elems graph + let graph = mkModuleGraph (node : all_nodes) + + return graph + + where + -- + mkEdge :: InteractiveImport -> (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) + -- A simple edge to a module from the same home unit + mkEdge (IIModule n) = + let unitId = homeUnitId $ hsc_home_unit hsc_env + in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc n) NotBoot) + -- A complete import statement + mkEdge (IIDecl i) = + let lvl = convImportLevel (ideclLevelSpec i) + wanted_mod = unLoc (ideclName i) + is_boot = ideclSource i + mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i) + unitId = homeUnitId $ hsc_home_unit hsc_env + in (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) + -- | 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 @@ -298,13 +344,16 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root = do let root_map = mkRootMap root_nodes checkDuplicates root_map - (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map) - let all_deps = loopUnit hsc_env module_deps root_uids + let env = DownsweepEnv hsc_env mode old_summaries excl_mods + (deps', map0) <- runDownsweepM env $ do + (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 + deps' <- loopInstantiations all_instantiations all_deps + return (deps', map0) - let all_instantiations = getHomeUnitInstantiations hsc_env - let deps' = loopInstantiations all_instantiations all_deps - downsweep_errs = lefts $ concat $ M.elems map0 + let downsweep_errs = lefts $ concat $ M.elems map0 downsweep_nodes = M.elems deps' return (downsweep_errs, downsweep_nodes) @@ -312,14 +361,6 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) - - calcDeps ms = - -- Add a dependency on the HsBoot file if it exists - -- This gets passed to the loopImports function which just ignores it if it - -- can't be found. - [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ - [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ] - -- 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 @@ -335,208 +376,231 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2 dup_roots = filterOut isSingleton $ map rights (M.elems root_map) - loopInstantiations :: [(UnitId, InstantiatedUnit)] - -> M.Map NodeKey ModuleGraphNode - -> M.Map NodeKey ModuleGraphNode - loopInstantiations [] done = done - loopInstantiations ((home_uid, iud) :xs) done = - let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env - done' = loopUnit hsc_env' done [instUnitInstanceOf iud] - payload = InstantiationNode home_uid iud - in loopInstantiations xs (M.insert (mkNodeKey payload) payload done') - - where - home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) - - - -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit - loopSummaries :: [ModSummary] - -> (M.Map NodeKey ModuleGraphNode, - DownsweepCache) - -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache) - loopSummaries [] done = return done - loopSummaries (ms:next) (done, summarised) - | Just {} <- M.lookup k done - = loopSummaries next (done, summarised) - -- Didn't work out what the imports mean yet, now do that. - | otherwise = do - (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised - -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. - (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' - loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') - where - k = NodeKey_Module (msKey ms) - - hs_file_for_boot - | HsBootFile <- ms_hsc_src ms - = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) - | 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 mkFixedEdge node_deps - node = ModuleNode edges (ModuleNodeFixed key loc) - foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> 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] - - mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge - mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) - mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid) - - ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)] - ifaceDeps deps = - [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid) - | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps) - ] ++ - [ Right (tcImportLevel lvl, uid) - | (lvl, 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. - loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] - -- Work list: process these modules - -> M.Map NodeKey ModuleGraphNode - -> DownsweepCache - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> IO ([ModuleNodeEdge], - M.Map NodeKey ModuleGraphNode, DownsweepCache) - -- The result is the completed NodeMap - loopImports [] done summarised = return ([], done, summarised) - loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised - | Just summs <- M.lookup cache_key summarised - = case summs of - [Right ms] -> do - let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms)) - (rest, summarised', done') <- loopImports ss done summarised - return (nk: rest, summarised', done') - [Left _err] -> - loopImports ss done summarised - _errs -> do - loopImports ss done summarised - | otherwise - = do - mb_s <- downsweepSummarise hsc_env home_unit old_summaries - is_boot wanted_mod mb_pkg - Nothing excl_mods - case mb_s of - NotThere -> loopImports ss done summarised - External uid -> do - -- Pass an updated hsc_env to loopUnit, as each unit might - -- have a different visible package database. - let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env - let done' = loopUnit hsc_env' done [uid] - (other_deps, done'', summarised') <- loopImports ss done' summarised - return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised') - FoundInstantiation iud -> do - (other_deps, done', summarised') <- loopImports ss done summarised - return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised') - FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) - FoundHome s -> do - (done', 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 (mkModuleEdge imp (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) - GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib - wanted_mod = L loc mod - - loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode - loopUnit _ cache [] = cache - loopUnit lcl_hsc_env cache (u:uxs) = do - let nk = (NodeKey_ExternalUnit u) - case Map.lookup nk cache of - Just {} -> loopUnit lcl_hsc_env cache uxs - Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of - 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) + +calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] +calcDeps ms = + -- Add a dependency on the HsBoot file if it exists + -- This gets passed to the loopImports function which just ignores it if it + -- can't be found. + [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ + [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ] + + +type DownsweepM a = ReaderT DownsweepEnv IO a +data DownsweepEnv = DownsweepEnv { + downsweep_hsc_env :: HscEnv + , _downsweep_mode :: DownsweepMode + , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary + , _downsweep_excl_mods :: [ModuleName] +} + +runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a +runDownsweepM env act = runReaderT act env + + +loopInstantiations :: [(UnitId, InstantiatedUnit)] + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopInstantiations [] done = pure done +loopInstantiations ((home_uid, iud) :xs) done = do + hsc_env <- asks downsweep_hsc_env + let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + done' = loopUnit hsc_env' done [instUnitInstanceOf iud] + payload = InstantiationNode home_uid iud + loopInstantiations xs (M.insert (mkNodeKey payload) payload done') + + +-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit +loopSummaries :: [ModSummary] + -> (M.Map NodeKey ModuleGraphNode, + DownsweepCache) + -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache) +loopSummaries [] done = pure done +loopSummaries (ms:next) (done, summarised) + | Just {} <- M.lookup k done + = loopSummaries next (done, summarised) + -- Didn't work out what the imports mean yet, now do that. + | otherwise = do + (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised + -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. + (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' + loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') + where + k = NodeKey_Module (msKey ms) + + hs_file_for_boot + | HsBootFile <- ms_hsc_src ms + = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) + | otherwise + = Nothing + +loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) +loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is + +loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (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 + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedModule key loc done = do + let nk = NodeKey_Module key + hsc_env <- asks downsweep_hsc_env + 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 <- liftIO $ + -- 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 mkFixedEdge node_deps + node = ModuleNode edges (ModuleNodeFixed key loc) + foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> 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 -> DownsweepM (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. + hsc_env <- asks downsweep_hsc_env + let hsc_env' = hscSetActiveUnitId home_uid hsc_env + return $ loopUnit hsc_env' done [uid] + +mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge +mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) +mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid) + +ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)] +ifaceDeps deps = + [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid) + | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps) + ] ++ + [ Right (tcImportLevel lvl, uid) + | (lvl, 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 + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedImports [] done = pure done +loopFixedImports (key:keys) done = do + let nk = NodeKey_Module key + hsc_env <- asks downsweep_hsc_env + case M.lookup nk done of + Just {} -> loopFixedImports keys done + Nothing -> do + read_result <- liftIO $ 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 :: HomeUnit + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> DownsweepM SummariseResult +downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do + DownsweepEnv hsc_env mode old_summaries excl_mods <- ask + case mode of + DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods + DownsweepUseFixed -> liftIO $ 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. +loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + -- Work list: process these modules + -> M.Map NodeKey ModuleGraphNode + -> DownsweepCache + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> DownsweepM ([ModuleNodeEdge], + M.Map NodeKey ModuleGraphNode, DownsweepCache) + -- The result is the completed NodeMap +loopImports [] done summarised = return ([], done, summarised) +loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised + | Just summs <- M.lookup cache_key summarised + = case summs of + [Right ms] -> do + let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms)) + (rest, summarised', done') <- loopImports ss done summarised + return (nk: rest, summarised', done') + [Left _err] -> + loopImports ss done summarised + _errs -> do + loopImports ss done summarised + | otherwise + = do + hsc_env <- asks downsweep_hsc_env + let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + mb_s <- downsweepSummarise home_unit + is_boot wanted_mod mb_pkg + Nothing + case mb_s of + NotThere -> loopImports ss done summarised + External uid -> do + -- Pass an updated hsc_env to loopUnit, as each unit might + -- have a different visible package database. + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + let done' = loopUnit hsc_env' done [uid] + (other_deps, done'', summarised') <- loopImports ss done' summarised + return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised') + FoundInstantiation iud -> do + (other_deps, done', summarised') <- loopImports ss done summarised + return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised') + FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) + FoundHome s -> do + (done', 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 (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised) + where + cache_key = (home_uid, mb_pkg, unLoc <$> gwib) + GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib + wanted_mod = L loc mod + +loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode +loopUnit _ cache [] = cache +loopUnit lcl_hsc_env cache (u:uxs) = do + let nk = (NodeKey_ExternalUnit u) + case Map.lookup nk cache of + Just {} -> loopUnit lcl_hsc_env cache uxs + Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of + 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 :: [ModuleNodeInfo] -> IO () multiRootsErr [] = panic "multiRootsErr" ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -164,6 +164,7 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Deps +import GHC.Driver.Downsweep import GHC.Data.FastString import GHC.Data.Maybe @@ -2077,12 +2078,25 @@ was added for External Core which faced a similar issue. ********************************************************* -} +-- This function is essentially a single-level downsweep +-- for an interactive module. There is no source file, so we create a fixed node. +withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a +withInteractiveModuleNode hsc_env thing_inside = do + mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env) + updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside + + + + + + runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ + withInteractiveModuleNode hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -101,6 +101,9 @@ module GHC.Unit.Module.Graph -- time it's called. , filterToposortToModules , moduleGraphNodesZero + , StageSummaryNode + , stageSummaryNodeSummary + , stageSummaryNodeKey , mkStageDeps -- * Keys into the 'ModuleGraph' @@ -930,6 +933,9 @@ stageSummaryNodeSummary = node_payload -- * If NoImplicitStagePersistence then Quote/Splice/Normal imports offset the required stage -- * If ImplicitStagePersistence and TemplateHaskell then imported module are needed at all stages. -- * Otherwise, an imported module is just needed at the normal stage. +-- +-- * A module using TemplateHaskellQuotes required at C stage is also required at R +-- stage. moduleGraphNodesStages :: [ModuleGraphNode] -> (Graph StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode) @@ -945,7 +951,7 @@ moduleGraphNodesStages summaries = normal_case :: (ModuleGraphNode, ModuleStage) -> StageSummaryNode normal_case ((m@(ModuleNode nks ms), s)) = DigraphNode ((mkNodeKey m, s)) key $ out_edge_keys $ - concatMap (classifyDeps ms s) nks + selfEdges ms s (mkNodeKey m) ++ concatMap (classifyDeps ms s) nks normal_case (m, s) = DigraphNode (mkNodeKey m, s) key (out_edge_keys . map (, s) $ mgNodeDependencies False m) @@ -955,6 +961,16 @@ moduleGraphNodesStages summaries = isTemplateHaskellQuotesMS :: ModSummary -> Bool isTemplateHaskellQuotesMS ms = xopt LangExt.TemplateHaskellQuotes (ms_hspp_opts ms) + -- Accounting for persistence within a module. + -- If a module is required @ C and it persists an idenfifier, it's also required + -- at R. + selfEdges (ModuleNodeCompile ms) s self_key + | not (isExplicitStageMS ms) + && (isTemplateHaskellQuotesMS ms + || isTemplateHaskellOrQQNonBoot ms) + = [(self_key, s') | s' <- onlyFutureStages s] + selfEdges _ _ _ = [] + -- Case 1. No implicit stage persistnce is enabled classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge il k) | isExplicitStageMS ms = case il of @@ -966,7 +982,7 @@ moduleGraphNodesStages summaries = | not (isExplicitStageMS ms) , not (isTemplateHaskellOrQQNonBoot ms) , isTemplateHaskellQuotesMS ms - = [(k, s') | s' <- futureStages s] + = [(k, s') | s' <- nowAndFutureStages s] -- Case 2b. Template haskell is enabled, with implicit stage persistence classifyDeps (ModuleNodeCompile ms) _ (ModuleNodeEdge _ k) | isTemplateHaskellOrQQNonBoot ms @@ -977,7 +993,7 @@ moduleGraphNodesStages summaries = numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)] - numbered_summaries = zip (([(s, l) | s <- summaries, l <- [CompileStage, RunStage]])) [0..] + numbered_summaries = zip (([(s, l) | s <- summaries, l <- allStages])) [0..] lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode lookup_node key = Map.lookup key node_map ===================================== compiler/GHC/Unit/Module/Stage.hs ===================================== @@ -1,6 +1,7 @@ module GHC.Unit.Module.Stage ( ModuleStage(..) , allStages - , futureStages + , nowAndFutureStages + , onlyFutureStages , minStage , maxStage , zeroStage @@ -56,8 +57,12 @@ data ModuleStage = CompileStage | RunStage deriving (Eq, Ord, Enum, Bounded) allStages :: [ModuleStage] allStages = [minBound .. maxBound] -futureStages :: ModuleStage -> [ModuleStage] -futureStages cur_st = [cur_st .. ] +nowAndFutureStages :: ModuleStage -> [ModuleStage] +nowAndFutureStages cur_st = [cur_st .. ] + +onlyFutureStages :: ModuleStage -> [ModuleStage] +onlyFutureStages cur_st | cur_st == maxBound = [] +onlyFutureStages cur_st = [succ cur_st .. ] minStage :: ModuleStage minStage = minBound ===================================== ghc/GHCi/UI.hs ===================================== @@ -2928,6 +2928,7 @@ iiSubsumes (IIModule m1) (IIModule m2) = m1==m2 iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude = unLoc (ideclName d1) == unLoc (ideclName d2) && ideclAs d1 == ideclAs d2 + && convImportLevel (ideclLevelSpec d1) == convImportLevel (ideclLevelSpec d2) && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2)) && (ideclImportList d1 `hidingSubsumes` ideclImportList d2) where ===================================== testsuite/tests/splice-imports/SI30.stdout ===================================== @@ -0,0 +1 @@ +2 ===================================== testsuite/tests/splice-imports/SI31.script ===================================== @@ -0,0 +1,2 @@ +-- Failure, since explicit level imports is on +$(id [| () |]) \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI31.stderr ===================================== @@ -0,0 +1,7 @@ +<interactive>:2:3: error: [GHC-28914] + • Level error: ‘id’ is bound at level 0 but used at level -1 + Hint: quoting [| id |] or an enclosing expression + would allow the quotation to be used at an earlier level + From imports {imported from ‘Prelude’} + • In the untyped splice: $(id [| () |]) + ===================================== testsuite/tests/splice-imports/SI32.script ===================================== @@ -0,0 +1,5 @@ +-- Success case with explicit level imports +import Language.Haskell.TH +import splice Data.Function (id) + +$(id [| () |]) \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI32.stdout ===================================== @@ -0,0 +1 @@ +() ===================================== testsuite/tests/splice-imports/SI33.script ===================================== @@ -0,0 +1,8 @@ +-- Test using both normal and splice level imports with Template Haskell +import Language.Haskell.TH +-- Using two imports here tests the iiSubsumes function +import splice Data.Function (id) +import Data.Function (id) + +-- Use the splice-level 'id' in the splice and normal-level 'on' in the quote +$(id [| id () |]) \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI33.stdout ===================================== @@ -0,0 +1 @@ +() ===================================== testsuite/tests/splice-imports/SI34.hs ===================================== @@ -0,0 +1,11 @@ +module SI34 where + +-- Compiling SI34 @ R, requires SI34M2 @ R, which requires SI34M1 @ R, +-- but NOT SI34M1 @ C or SI34M2 @ C due to ImplicitStagePersistence + TemplateHaskellQuotes +import SI34M2 + +-- Uses the MkT constructor indirectly through SI34M2.makeMkT +foo = makeMkT 42 + +-- Uses the wrapper type from SI34M2 +bar = wrapT (makeMkT 100) \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI34.stderr ===================================== @@ -0,0 +1,3 @@ +[1 of 3] Compiling SI34M1 ( SI34M1.hs, nothing ) +[2 of 3] Compiling SI34M2 ( SI34M2.hs, nothing ) +[3 of 3] Compiling SI34 ( SI34.hs, nothing ) ===================================== testsuite/tests/splice-imports/SI34M1.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE ImplicitStagePersistence #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module SI34M1 where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data T = MkT Int + deriving Show + +instance Lift T where + lift (MkT n) = [| MkT $(lift n) |] + liftTyped (MkT n) = [|| MkT $$(liftTyped n) ||] ===================================== testsuite/tests/splice-imports/SI34M2.hs ===================================== @@ -0,0 +1,28 @@ +{-# LANGUAGE ImplicitStagePersistence #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module SI34M2 ( + makeMkT, + TWrapper(..), + wrapT +) where + +import SI34M1 +import Language.Haskell.TH.Syntax + +-- A wrapper for T +data TWrapper = WrapT T + deriving Show + +-- Create a MkT with the given Int +makeMkT :: Int -> T +makeMkT = MkT + +-- Wrap a T in a TWrapper +wrapT :: T -> TWrapper +wrapT = WrapT + +-- Quote functions for TWrapper +instance Lift TWrapper where + lift (WrapT t) = [| WrapT $(lift t) |] + liftTyped (WrapT t) = [|| WrapT $$(liftTyped t) ||] ===================================== testsuite/tests/splice-imports/SI35.hs ===================================== @@ -0,0 +1,79 @@ +{-# LANGUAGE RecordWildCards #-} +module Main where + +import GHC +import GHC.Driver.Session +import GHC.Driver.Monad +import GHC.Driver.Make (load', summariseFile) +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary +import GHC.Unit.Types +import GHC.Unit.Module.ModIface +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 GHC.Unit.Home +import GHC.Driver.Env +import Data.List (sort) +import GHC.Driver.MakeFile +import GHC.Data.Maybe +import GHC.Unit.Module.Stage +import GHC.Data.Graph.Directed.Reachability +import GHC.Utils.Trace +import GHC.Unit.Module.Graph + +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 + hsc_env <- getSession + setSession $ hscSetActiveUnitId mainUnitId hsc_env + + -- Get ModSummary for our test module + msA <- getModSummaryFromTarget "SI35A.hs" + + -- Define NodeKey + let keyA = NodeKey_Module (msKey msA) + edgeA = mkNormalEdge keyA + + -- Define ModuleNodeInfo + let infoA_compile = ModuleNodeCompile msA + + -- Define the complete node + let nodeA_compile = ModuleNode [] infoA_compile + + -- This test checks that a module required at compile stage invokes a + -- depedency on the runstage of itself when using TemplateHaskellQuotes. + + -- This is hard to test with a normal compiler invocation as GHC does not + -- not distinguish very easily these two stages. + let (ri, to_node) = mkStageDeps [nodeA_compile] + let reachable = allReachable ri (expectJust $ to_node (keyA, CompileStage)) + let reachable_nodes = map stageSummaryNodeSummary reachable + + if (keyA, RunStage) `elem` reachable_nodes + then return () + else do + liftIO $ putStrLn "Test failed -- (keyA, RunStage) not reachable" + pprTraceM "reachable_nodes" (ppr reachable_nodes) + pprTraceM "reachable" (ppr (reachabilityIndexMembers ri)) + + 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 \ No newline at end of file ===================================== testsuite/tests/splice-imports/SI35A.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module SI35A where + +-- Define a type for use in Template Haskell +data T = MkT Int + +-- Helper function to construct a T +mkT :: Int -> T +mkT = MkT + +-- A function that creates a quoted expression using T +quotedT :: Int -> Q Exp +quotedT n = [| mkT n |] + +-- Another quoted expression function +quotedAdd :: Q Exp +quotedAdd = [| \x y -> x + y :: Int |] + +-- Show instance +instance Show T where + show (MkT n) = "MkT " ++ show n \ No newline at end of file ===================================== testsuite/tests/splice-imports/all.T ===================================== @@ -36,3 +36,12 @@ test('SI27', normal, compile_fail, ['']) test('SI28', normal, compile_fail, ['']) test('SI29', normal, compile_fail, ['']) test('SI30', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports")], ghci_script, ['SI30.script']) +test('SI31', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI31.script']) +test('SI32', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI32.script']) +test('SI33', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI33.script']) +test('SI34', [extra_files(["SI34M1.hs", "SI34M2.hs"])], multimod_compile, ['SI34', '-fno-code']) +test('SI35', + [extra_run_opts(f'"{config.libdir}"'), + extra_files(['SI35A.hs'])], + compile_and_run, + ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e44ea99aafb6f70c4618bfb3c2c565f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e44ea99aafb6f70c4618bfb3c2c565f... You're receiving this email because of your account on gitlab.haskell.org.