Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC Commits: d0a36c84 by fendor at 2025-04-17T17:31:58+02:00 Use Module in IIModule - - - - - 8 changed files: - compiler/GHC.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Home/Graph.hs - ghc/GHCi/UI.hs - testsuite/tests/ghci/linking/dyn/T3372.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -157,7 +157,7 @@ module GHC ( getBindings, getInsts, getNamePprCtx, findModule, lookupModule, findQualifiedModule, lookupQualifiedModule, - lookupLoadedHomeModuleByModuleName, lookupAnyQualifiedModule, + lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames, renamePkgQualM, renameRawPkgQualM, isModuleTrusted, moduleTrustReqs, getNamesInScope, @@ -1496,8 +1496,8 @@ getModuleGraph = liftM hsc_mod_graph getSession -- TODO: this function should likely be deleted. isLoaded :: GhcMonad m => ModuleName -> m Bool isLoaded m = withSession $ \hsc_env -> liftIO $ do - hmi <- HUG.lookupAnyHug (hsc_HUG hsc_env) m - return $! isJust hmi + hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m + return $! not (null hmis) isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do @@ -1896,17 +1896,16 @@ lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do _not_a_home_module -> return Nothing -- TODO: this is incorrect, what if we have mulitple 'ModuleName's in our HPTs? -lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module]) lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name) - HUG.lookupAnyHug (hsc_HUG hsc_env) mod_name >>= \case - Just mod_info -> return (Just (mi_module (hm_iface mod_info))) - _not_a_home_module -> return Nothing + HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case + [] -> return Nothing + mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos)) -lookupAnyQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module -lookupAnyQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do +lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module] +lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do home <- lookupLoadedHomeModuleByModuleName mod_name - liftIO $ trace_if (hsc_logger hsc_env) (ppr home <+> ppr (fmap moduleUnitId home)) case home of Just m -> return m Nothing -> liftIO $ do @@ -1916,11 +1915,12 @@ lookupAnyQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do let fopts = initFinderOpts dflags res <- findExposedPackageModule fc fopts units mod_name NoPkgQual case res of - Found _ m -> return m + Found _ m -> return [m] err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err -lookupAnyQualifiedModule pkgqual mod_name = +lookupAllQualifiedModuleNames pkgqual mod_name = do -- TODO: definitely wrong. - findQualifiedModule pkgqual mod_name + m <- findQualifiedModule pkgqual mod_name + pure [m] -- | Check that a module is safe to import (according to Safe Haskell). -- ===================================== compiler/GHC/Rename/Unbound.hs ===================================== @@ -364,7 +364,7 @@ importSuggestions looking_for ic currMod imports rdr_name pick_interactive :: InteractiveImport -> Bool pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True | mod_name == fmap unLoc (ideclAs d) = True - pick_interactive (IIModule m) | mod_name == Just m = True + pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True pick_interactive _ = False -- We want to keep only one for each original module; preferably one with an ===================================== compiler/GHC/Runtime/Context.hs ===================================== @@ -296,9 +296,7 @@ data InteractiveImport -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope - | IIModule ModuleName - -- TODO: change this to 'Module', does this work? - -- Much more precise + | IIModule Module -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -822,17 +822,12 @@ findGlobalRdrEnv hsc_env imports idecls :: [LImportDecl GhcPs] idecls = [noLocA d | IIDecl d <- imports] - imods :: [ModuleName] + imods :: [Module] imods = [m | IIModule m <- imports] - mkEnv modl = do - -- TODO: revisit this, is this how we want to do it? - mMod <- HUG.lookupAnyHug (hsc_HUG hsc_env) modl - let mod = case mMod of - Nothing -> mkModule (RealUnit $ Definite $ hscActiveUnitId hsc_env) modl - Just m -> mi_module $ hm_iface m + mkEnv mod = do mkTopLevEnv hsc_env mod >>= \case - Left err -> pure $ Left (modl, err) + Left err -> pure $ Left (moduleName mod, err) Right env -> pure $ Right env mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2098,7 +2098,7 @@ runTcInteractive hsc_env thing_inside ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111 - IIModule n -> getOrphans n NoPkgQual + IIModule n -> getOrphans (moduleName n) NoPkgQual -- TODO: wrong IIDecl i -> getOrphans (unLoc (ideclName i)) (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -34,7 +34,7 @@ module GHC.Unit.Home.Graph , lookupHug , lookupHugByModule , lookupHugUnit - , lookupAnyHug + , lookupAllHug , memberHugHomeModule , memberHugHomeInstalledModule @@ -91,6 +91,7 @@ import GHC.Data.Graph.Directed import GHC.Types.Annotations import GHC.Types.CompleteMatch import GHC.Core.InstEnv +import GHC.Utils.Monad (mapMaybeM) -- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across @@ -255,21 +256,14 @@ lookupHug hug uid mod = do Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod -- TODO: this should not be merged, where else could we try to search for modules? -lookupAnyHug :: HomeUnitGraph -> ModuleName -> IO (Maybe HomeModInfo) -lookupAnyHug hug mod = firstJustM $ flip fmap (Set.toList $ unitEnv_keys hug) $ \uid -> do - case unitEnv_lookup_maybe uid hug of - -- Really, here we want "lookup HPT" rather than unitEnvLookup - Nothing -> pure Nothing - Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod +lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo] +lookupAllHug hug mod = mapMaybeM lookupModuleName (Set.toList $ unitEnv_keys hug) where - firstJustM :: Monad f => [f (Maybe a)] -> f (Maybe a) - firstJustM [] = pure Nothing - firstJustM (x:xs) = do - ma <- x - case ma of - Nothing -> firstJustM xs - Just a -> pure $ Just a - + lookupModuleName uid = + case unitEnv_lookup_maybe uid hug of + -- Really, here we want "lookup HPT" rather than unitEnvLookup + Nothing -> pure Nothing + Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod -- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit) lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo) ===================================== ghc/GHCi/UI.hs ===================================== @@ -558,7 +558,7 @@ interactiveUI config srcs maybe_exprs = do hsc_env <- GHC.getSession let !in_multi = length (hsc_all_home_unit_ids hsc_env) > 3 -- We force this to make sure we don't retain the hsc_env when reloading - -- The check is `> 2`, since we now always have at least two home units. + -- The check is `> 3`, since we now always have at least two home units. -- TODO: if everything goes well, this check should be deleted once -- this PR has lifted the multiple home unit restrictions empty_cache <- liftIO newIfaceCache @@ -1023,7 +1023,7 @@ getInfoForPrompt = do | otherwise = unLoc (ideclName d) modules_names = - ['*':(moduleNameString m) | IIModule m <- rev_imports] ++ + ['*':(moduleNameString (moduleName m)) | IIModule m <- rev_imports] ++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports] line = 1 + line_number st @@ -2279,7 +2279,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do -- We import the module with a * iff -- - it is interpreted, and -- - -XSafe is off (it doesn't allow *-imports) - let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)] + let new_ctx | star_ok = [mkIIModule m] | otherwise = [mkIIDecl (GHC.moduleName m)] setContextKeepingPackageModules keep_ctxt new_ctx @@ -2699,7 +2699,7 @@ guessCurrentModule cmd = do imports <- GHC.getContext case imports of [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module") - IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m + IIModule m : _ -> pure m IIDecl d : _ -> do pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d) GHC.findQualifiedModule pkgqual (unLoc (ideclName d)) @@ -2829,8 +2829,9 @@ addModulesToContext starred unstarred = restoreContextOnFailure $ do addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m () addModulesToContext_ starred unstarred = do - mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred) - setGHCContextFromGHCiState + starredModules <- traverse lookupModuleName starred + mapM_ addII (map mkIIModule starredModules ++ map mkIIDecl unstarred) + setGHCContextFromGHCiState remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m () remModulesFromContext starred unstarred = do @@ -2896,9 +2897,9 @@ checkAdd ii = do dflags <- getDynFlags let safe = safeLanguageOn dflags case ii of - IIModule modname + IIModule mod | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell" - | otherwise -> wantInterpretedModuleName modname >> return () + | otherwise -> checkInterpretedModule mod >> return () IIDecl d -> do let modname = unLoc (ideclName d) @@ -2966,13 +2967,13 @@ getImplicitPreludeImports iidecls = do -- ----------------------------------------------------------------------------- -- Utils on InteractiveImport -mkIIModule :: ModuleName -> InteractiveImport +mkIIModule :: Module -> InteractiveImport mkIIModule = IIModule mkIIDecl :: ModuleName -> InteractiveImport mkIIDecl = IIDecl . simpleImportDecl -iiModules :: [InteractiveImport] -> [ModuleName] +iiModules :: [InteractiveImport] -> [Module] iiModules is = [m | IIModule m <- is] isIIModule :: InteractiveImport -> Bool @@ -2980,7 +2981,7 @@ isIIModule (IIModule _) = True isIIModule _ = False iiModuleName :: InteractiveImport -> ModuleName -iiModuleName (IIModule m) = m +iiModuleName (IIModule m) = moduleName m iiModuleName (IIDecl d) = unLoc (ideclName d) preludeModuleName :: ModuleName @@ -3428,7 +3429,7 @@ showImports = do trans_ctx = transient_ctx st show_one (IIModule star_m) - = ":module +*" ++ moduleNameString star_m + = ":module +*" ++ moduleNameString (moduleName star_m) show_one (IIDecl imp) = showPpr dflags imp prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx) @@ -3734,11 +3735,11 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 filterM GHC.moduleIsInterpreted hmods -- Return all possible bids for a given Module - bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String] + bidsByModule :: GhciMonad m => [Module] -> Module -> m [String] bidsByModule nonquals mod = do (_, decls) <- getModBreak mod let bids = nub $ declPath <$> elems decls - pure $ case (moduleName mod) `elem` nonquals of + pure $ case mod `elem` nonquals of True -> bids False -> (combineModIdent (showModule mod)) <$> bids @@ -4143,8 +4144,7 @@ breakSwitch (arg1:rest) | all isDigit arg1 = do imports <- GHC.getContext case iiModules imports of - (mn : _) -> do - md <- lookupModuleName mn + (md : _) -> do breakByModuleLine md (read arg1) rest [] -> do liftIO $ putStrLn "No modules are loaded with debugging support." @@ -4276,8 +4276,7 @@ list2 [arg] | all isDigit arg = do case iiModules imports of [] -> liftIO $ putStrLn "No module to list" (mn : _) -> do - md <- lookupModuleName mn - listModuleLine md (read arg) + listModuleLine mn (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do md <- wantInterpretedModule arg1 listModuleLine md (read arg2) @@ -4536,7 +4535,17 @@ lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module -lookupQualifiedModuleName = GHC.lookupAnyQualifiedModule +lookupQualifiedModuleName qual modl = do + GHC.lookupAllQualifiedModuleNames qual modl >>= \case + [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found.")) + [m] -> pure m + ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous;\n" ++ errorMsg ms)) + where + str = moduleNameString modl + errorMsg ms = intercalate "\n" + [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) + | m <- ms + ] isMainUnitModule :: Module -> Bool isMainUnitModule m = GHC.moduleUnit m == mainUnit @@ -4586,15 +4595,19 @@ wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module wantInterpretedModuleName modname = do - modl <- lookupModuleName modname - let str = moduleNameString modname - hug <- hsc_HUG <$> GHC.getSession - unless (HUG.memberHugHomeModule modl hug) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) - is_interpreted <- GHC.moduleIsInterpreted modl - when (not is_interpreted) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) - return modl + modl <- lookupModuleName modname + checkInterpretedModule modl + +checkInterpretedModule :: GHC.GhcMonad m => Module -> m Module +checkInterpretedModule modl = do + let str = moduleNameString $ moduleName modl + hug <- hsc_HUG <$> GHC.getSession + unless (HUG.memberHugHomeModule modl hug) $ + throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) + is_interpreted <- GHC.moduleIsInterpreted modl + when (not is_interpreted) $ + throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) + return modl wantNameFromInterpretedModule :: GHC.GhcMonad m => (Name -> SDoc -> m ()) ===================================== testsuite/tests/ghci/linking/dyn/T3372.hs ===================================== @@ -60,7 +60,7 @@ load (f,mn) = do target <- GHC.guessTarget f Nothing Nothing GHC.liftIO $ putStrLn ("Load " ++ showSuccessFlag res) -- m <- GHC.findModule (GHC.mkModuleName mn) Nothing - GHC.setContext [GHC.IIModule $ GHC.moduleName $ m] + GHC.setContext [GHC.IIModule m] where showSuccessFlag GHC.Succeeded = "succeeded" showSuccessFlag GHC.Failed = "failed" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d0a36c84651dee8ff3dd198a167b334b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d0a36c84651dee8ff3dd198a167b334b... You're receiving this email because of your account on gitlab.haskell.org.