June 2025 - ghc-commits

[Git][ghc/ghc][master] Remove hptAllFamInstances usage during upsweep
by Marge Bot (＠marge-bot) 23 Jun '25

23 Jun '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3bf6720e by soulomoon at 2025-06-23T13:55:52-04:00 Remove hptAllFamInstances usage during upsweep Fixes #26118 This change eliminates the use of hptAllFamInstances during the upsweep phase, as it could access non-below modules from the home package table. The following updates were made: * Updated checkFamInstConsistency to accept an explicit ModuleEnv FamInstEnv parameter and removed the call to hptAllFamInstances. * Adjusted hugInstancesBelow so we can construct ModuleEnv FamInstEnv from its result, * hptAllFamInstances and allFamInstances functions are removed. - - - - - 5 changed files: - compiler/GHC/Driver/Env.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Home/PackageTable.hs Changes: ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -245,7 +245,7 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn -- | Find instances visible from the given set of imports -hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)]) hugInstancesBelow hsc_env uid mnwib = do let mn = gwib_mod mnwib (insts, famInsts) <- @@ -255,7 +255,7 @@ hugInstancesBelow hsc_env uid mnwib = do -- Don't include instances for the current module in if moduleName (mi_module (hm_iface mod_info)) == mn then [] - else [(md_insts details, md_fam_insts details)]) + else [(md_insts details, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)])]) True -- Include -hi-boot hsc_env uid ===================================== compiler/GHC/Tc/Instance/Family.hs ===================================== @@ -286,8 +286,8 @@ why we still do redundant checks. -- We don't need to check the current module, this is done in -- tcExtendLocalFamInstEnv. -- See Note [The type family instance consistency story]. -checkFamInstConsistency :: [Module] -> TcM () -checkFamInstConsistency directlyImpMods +checkFamInstConsistency :: ModuleEnv FamInstEnv -> [Module] -> TcM () +checkFamInstConsistency hpt_fam_insts directlyImpMods = do { (eps, hug) <- getEpsAndHug ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as @@ -317,7 +317,6 @@ checkFamInstConsistency directlyImpMods -- See Note [Order of type family consistency checks] } - ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods ; traceTc "init_consistent_set" (ppr debug_consistent_set) ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set)) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -120,7 +120,7 @@ import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Core.TyCo.Tidy( tidyTopType ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst - , famInstEnvElts, extendFamInstEnvList, normaliseType ) + , famInstEnvElts, extendFamInstEnvList, normaliseType, emptyFamInstEnv, unionFamInstEnv ) import GHC.Parser.Header ( mkPrelImports ) @@ -467,8 +467,8 @@ tcRnImports hsc_env import_decls = do { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls -- Get the default declarations for the classes imported by this module -- and group them by class. - ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)) - <$> tcGetClsDefaults (M.keys $ imp_mods imports) + ; tc_defaults <- NE.groupBy ((==) `on` cd_class) . (concatMap defaultList) + <$> tcGetClsDefaults (M.keys $ imp_mods imports) ; this_mod <- getModule ; gbl_env <- getGblEnv ; let unitId = homeUnitId $ hsc_home_unit hsc_env @@ -480,8 +480,10 @@ tcRnImports hsc_env import_decls -- filtering also ensures that we don't see instances from -- modules batch (@--make@) compiled before this one, but -- which are not below this one. - ; (home_insts, home_fam_insts) <- liftIO $ + ; (home_insts, home_mod_fam_inst_env) <- liftIO $ hugInstancesBelow hsc_env unitId mnwib + ; let home_fam_inst_env = foldl' unionFamInstEnv emptyFamInstEnv $ snd <$> home_mod_fam_inst_env + ; let hpt_fam_insts = mkModuleEnv home_mod_fam_inst_env -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad @@ -507,8 +509,7 @@ tcRnImports hsc_env import_decls tcg_rn_imports = rn_imports, tcg_default = foldMap subsume tc_defaults, tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts + tcg_fam_inst_env = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env }) $ do { ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) @@ -538,7 +539,7 @@ tcRnImports hsc_env import_decls $ imports } ; logger <- getLogger ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) - $ checkFamInstConsistency dir_imp_mods + $ checkFamInstConsistency hpt_fam_insts dir_imp_mods ; traceRn "rn1: } checking family instance consistency" empty ; gbl_env <- getGblEnv ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -43,7 +43,6 @@ module GHC.Unit.Home.Graph -- * Very important queries , allInstances - , allFamInstances , allAnns , allCompleteSigs @@ -110,10 +109,6 @@ allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b')) (hptAllInstances (homeUnitEnv_hpt hue)) -allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv) -allFamInstances hug = foldr go (pure emptyModuleEnv) hug where - go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue)) - allAnns :: HomeUnitGraph -> IO AnnEnv allAnns hug = foldr go (pure emptyAnnEnv) hug where go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue)) ===================================== compiler/GHC/Unit/Home/PackageTable.hs ===================================== @@ -41,7 +41,6 @@ module GHC.Unit.Home.PackageTable -- * Queries about home modules , hptCompleteSigs , hptAllInstances - , hptAllFamInstances , hptAllAnnotations -- ** More Traversal-based queries @@ -208,14 +207,6 @@ hptAllInstances hpt = do let (insts, famInsts) = unzip hits return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) --- | Find all the family instance declarations from the HPT -hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv) -hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)]) - where - hmiModule = mi_module . hm_iface - hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv - . md_fam_insts . hm_details - -- | All annotations from the HPT hptAllAnnotations :: HomePackageTable -> IO AnnEnv hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3bf6720eff5e86e673568e756161e6d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3bf6720eff5e86e673568e756161e6d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Move ModuleGraph into UnitEnv
by Marge Bot (＠marge-bot) 23 Jun '25

23 Jun '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0fb37893 by Matthew Pickering at 2025-06-23T13:55:10-04:00 Move ModuleGraph into UnitEnv The ModuleGraph is a piece of information associated with the ExternalPackageState and HomeUnitGraph. Therefore we should store it inside the HomeUnitEnv. - - - - - 12 changed files: - compiler/GHC.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Env.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -859,6 +859,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_namever = ghcNameVersion dflags1 , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit old_unit_env + , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } @@ -916,6 +917,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit unit_env0 , ue_eps = ue_eps unit_env0 + , ue_module_graph = ue_module_graph unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -996,7 +998,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do -- invalidateModSummaryCache :: GhcMonad m => m () invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } + modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env where inval ms = ms { ms_hs_hash = fingerprint0 } ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -97,10 +97,11 @@ core2core hsc_env guts@(ModGuts { mg_module = mod where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env extra_vars = interactiveInScope (hsc_IC hsc_env) home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot }) - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -457,6 +457,7 @@ addUnit u = do (homeUnitId home_unit) (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env + , ue_module_graph = ue_module_graph old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -2,6 +2,8 @@ module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , hsc_mod_graph + , setModuleGraph , hscUpdateFlags , hscSetFlags , hsc_home_unit @@ -130,6 +132,9 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env +hsc_mod_graph :: HscEnv -> ModuleGraph +hsc_mod_graph = ue_module_graph . hsc_unit_env + hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG @@ -139,6 +144,9 @@ hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env) hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } +setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv +setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } } + {- Note [Target code interpreter] @@ -220,15 +228,15 @@ hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) -- | Find all rules in modules that are in the transitive closure of the given -- module. hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase -hugRulesBelow hsc uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> - hugSomeThingsBelowUs (md_rules . hm_details) False hsc uid mn +hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> + hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn -- | Get annotations from all modules "below" this one (in the dependency -- sense) within the home units. If the module is @Nothing@, returns /all/ -- annotations in the home units. hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv -hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> - hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn +hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> + hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn -- | Find all COMPLETE pragmas in modules that are in the transitive closure of the -- given module. @@ -260,7 +268,8 @@ hugInstancesBelow hsc_env uid mnwib = do hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] -- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk -- These things are currently stored in the EPS for home packages. (See #25795 for --- progress in removing these kind of checks) +-- progress in removing these kind of checks; and making these functions of +-- `UnitEnv` rather than `HscEnv`) -- See Note [Downsweep and the ModuleGraph] hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -18,7 +18,6 @@ import GHC.Types.Name.Cache import GHC.Types.Target import GHC.Types.TypeEnv import GHC.Unit.Finder.Types -import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -65,10 +64,6 @@ data HscEnv hsc_targets :: [Target], -- ^ The targets (or roots) of the current session - hsc_mod_graph :: ModuleGraph, - -- ^ The module graph of the current session - -- See Note [Downsweep and the ModuleGraph] for when this is constructed. - hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements @@ -113,3 +108,4 @@ data HscEnv , hsc_llvm_config :: !LlvmConfigCache -- ^ LLVM configuration cache. } + ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -332,7 +332,6 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do return HscEnv { hsc_dflags = top_dynflags , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) , hsc_targets = [] - , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags , hsc_NC = nc_var , hsc_FC = fc_var ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -190,12 +190,12 @@ depanalE diag_wrapper msg excluded_mods allow_dup_roots = do all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env) logDiagnostics (GhcDriverMessage <$> all_errs) - setSession hsc_env { hsc_mod_graph = mod_graph } + setSession (setModuleGraph mod_graph hsc_env) pure (emptyMessages, mod_graph) else do -- We don't have a complete module dependency graph, -- The graph may be disconnected and is unusable. - setSession hsc_env { hsc_mod_graph = emptyMG } + setSession (setModuleGraph emptyMG hsc_env) pure (errs, emptyMG) @@ -616,7 +616,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- for any client who might interact with GHC via load'. -- See Note [Timing of plugin initialization] initializeSessionPlugins - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } + modifySession (setModuleGraph mod_graph) guessOutputFile hsc_env <- getSession ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -768,8 +768,9 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) - , hsc_mod_graph = mg } + let hsc_env' = + setModuleGraph mg + hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -671,7 +671,7 @@ dontLeakTheHUG thing_inside = do -- oneshot mode does not support backpack -- and we want to avoid prodding the hsc_mod_graph thunk | isOneShot (ghcMode (hsc_dflags hsc_env)) = False - | mgHasHoles (hsc_mod_graph hsc_env) = True + | mgHasHoles (ue_module_graph old_unit_env) = True | otherwise = False pruneHomeUnitEnv hme = do -- NB: These are empty HPTs because Iface/Load first consults the HPT @@ -683,19 +683,19 @@ dontLeakTheHUG thing_inside = do | otherwise = do hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) + let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" + , mg_graph = panic "cleanTopEnv: mg_graph" + , mg_has_holes = keepFor20509 } return old_unit_env { ue_home_unit_graph = hug' + , ue_module_graph = new_mod_graph } in do !unit_env <- unit_env_io -- mg_has_holes will be checked again, but nothing else about the module graph - let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" - , mg_graph = panic "cleanTopEnv: mg_graph" - , mg_has_holes = keepFor20509 } pure $ hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets" - , hsc_mod_graph = new_mod_graph , hsc_IC = panic "cleanTopEnv: hsc_IC" , hsc_type_env_vars = case maybe_type_vars of Just vars -> vars ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2109,7 +2109,7 @@ for the unit portion of the graph, if it's not already been performed. 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 + updTopEnv (setModuleGraph mg) thing_inside runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -23,21 +23,22 @@ -- ┌▽────────────┐ │ │ -- │HomeUnitGraph│ │ │ -- └┬────────────┘ │ │ --- ┌▽─────────────────▽┐ │ --- │UnitEnv │ │ --- └┬──────────────────┘ │ --- ┌▽───────────────────────────────────────▽┐ --- │HscEnv │ --- └─────────────────────────────────────────┘ +-- ┌▽─────────────────▽─────────────────────▽┐ +-- │UnitEnv │ +-- └┬─────────────-──────────────────────────┘ +-- │ +-- │ +-- ┌▽──────────────────────────────────────▽┐ +-- │HscEnv │ +-- └────────────────────────────────────────┘ -- @ -- --- The 'UnitEnv' references both the 'HomeUnitGraph' (with all the home unit --- modules) and the 'ExternalPackageState' (information about all --- non-home/external units). The 'HscEnv' references this 'UnitEnv' and the --- 'ModuleGraph' (which describes the relationship between the modules being --- compiled). The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. --- --- TODO: Arguably, the 'ModuleGraph' should be part of 'UnitEnv' rather than being in the 'HscEnv'. +-- The 'UnitEnv' references the 'HomeUnitGraph' (with all the home unit +-- modules), the 'ExternalPackageState' (information about all +-- non-home/external units), and the 'ModuleGraph' (which describes the +-- relationship between the modules being compiled). +-- The 'HscEnv' references this 'UnitEnv'. +-- The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv @@ -119,6 +120,7 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv) import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Module.Graph import GHC.Platform import GHC.Settings @@ -163,6 +165,10 @@ data UnitEnv = UnitEnv , ue_current_unit :: UnitId + , ue_module_graph :: ModuleGraph + -- ^ The module graph of the current session + -- See Note [Downsweep and the ModuleGraph] for when this is constructed. + , ue_home_unit_graph :: !HomeUnitGraph -- See Note [Multiple Home Units] @@ -182,6 +188,7 @@ initUnitEnv cur_unit hug namever platform = do return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug + , ue_module_graph = emptyMG , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever ===================================== ghc/GHCi/UI.hs ===================================== @@ -4680,7 +4680,7 @@ clearHPTs = do let pruneHomeUnitEnv hme = liftIO $ do emptyHpt <- emptyHomePackageTable pure hme{ homeUnitEnv_hpt = emptyHpt } - discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG } + discardMG hsc = setModuleGraph GHC.emptyMG hsc modifySessionM $ \hsc_env -> do hug' <- traverse pruneHomeUnitEnv $ hsc_HUG hsc_env pure $ discardMG $ discardIC $ hscUpdateHUG (const hug') hsc_env View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fb37893d95bbddec550bee1eb6aee4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fb37893d95bbddec550bee1eb6aee4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-5] 2 commits: debugger: Implement step-out feature
by Rodrigo Mesquita (＠alt-romes) 23 Jun '25

23 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-5 at Glasgow Haskell Compiler / GHC Commits: 13d901d7 by Rodrigo Mesquita at 2025-06-23T17:55:56+01:00 debugger: Implement step-out feature Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. On the other hand, it means the debugger follows the more realistic execution of the program. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key idea is simple: When step-out is enabled, traverse the runtime stack until a continuation BCO is found -- and enable the breakpoint heading that BCO explicitly using its tick-index. The details are specified in `Note [Debugger: Step-out]` in `rts/Interpreter.c`. Since PUSH_ALTS BCOs (representing case continuations) were never headed by a breakpoint (unlike the case alternatives they push), we introduced the BRK_ALTS instruction to allow the debugger to set a case continuation to stop at the breakpoint heading the alternative that is taken. This is further described in `Note [Debugger: BRK_ALTS]`. Fixes #26042 - - - - - b18a4eba by Rodrigo Mesquita at 2025-06-23T17:55:57+01:00 debugger: Filter step-out stops by SrcSpan To implement step-out, the RTS looks for the first continuation frame on the stack and explicitly enables its entry breakpoint. However, some continuations will be contained in the function from which step-out was initiated (trivial example is a case expression). Similarly to steplocal, we will filter the breakpoints at which the RTS yields to the debugger based on the SrcSpan. When doing step-out, only stop if the breakpoint is /not/ contained in the function from which we initiated it. This is especially relevant in monadic statements such as IO which is compiled to a long chain of case expressions. See Note [Debugger: Filtering step-out stops] - - - - - 44 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/StgToByteCode.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Disassembler.c - rts/Interpreter.c - rts/Interpreter.h - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/rts/Bytecodes.h - rts/include/rts/Constants.h - rts/include/rts/storage/Closures.h - + testsuite/tests/ghci.debugger/scripts/T26042b.hs - + testsuite/tests/ghci.debugger/scripts/T26042b.script - + testsuite/tests/ghci.debugger/scripts/T26042b.stdout - + testsuite/tests/ghci.debugger/scripts/T26042c.hs - + testsuite/tests/ghci.debugger/scripts/T26042c.script - + testsuite/tests/ghci.debugger/scripts/T26042c.stdout - + testsuite/tests/ghci.debugger/scripts/T26042d.hs - + testsuite/tests/ghci.debugger/scripts/T26042d.script - + testsuite/tests/ghci.debugger/scripts/T26042d.stdout - + testsuite/tests/ghci.debugger/scripts/T26042e.hs - + testsuite/tests/ghci.debugger/scripts/T26042e.script - + testsuite/tests/ghci.debugger/scripts/T26042e.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f.hs - + testsuite/tests/ghci.debugger/scripts/T26042f.script - + testsuite/tests/ghci.debugger/scripts/T26042f1.stderr - + testsuite/tests/ghci.debugger/scripts/T26042f1.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f2.stdout - + testsuite/tests/ghci.debugger/scripts/T26042g.hs - + testsuite/tests/ghci.debugger/scripts/T26042g.script - + testsuite/tests/ghci.debugger/scripts/T26042g.stdout - testsuite/tests/ghci.debugger/scripts/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d82d42f3b3a20d849cf601801df71… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d82d42f3b3a20d849cf601801df71… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/no-load] 2 commits: Teach `:reload` about multiple home units
by Hannes Siebenhandl (＠fendor) 23 Jun '25

23 Jun '25

Hannes Siebenhandl pushed to branch wip/fendor/no-load at Glasgow Haskell Compiler / GHC Commits: 83255056 by fendor at 2025-06-23T18:29:10+02:00 Teach `:reload` about multiple home units `:reload` needs to lookup the `ModuleName` and must not assume the given `ModuleName` is in the current `HomeUnit`. We add a new utility function which allows us to find a `HomeUnitModule` instead of a `Module`. Further, we introduce the `GhciCommandError` type which can be used to abort the execution of a GHCi command. This error is caught and printed in a human readable fashion. - - - - - d18f1687 by fendor at 2025-06-23T18:34:50+02:00 WIP - - - - - 17 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Unit/Module/Graph.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - ghc/GHCi/UI/Print.hs - testsuite/tests/ghc-e/should_fail/T18441fail5.stderr - testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr - + testsuite/tests/ghci/prog021/A.hs - + testsuite/tests/ghci/prog021/B.hs - + testsuite/tests/ghci/prog021/Makefile - + testsuite/tests/ghci/prog021/prog021.T - + testsuite/tests/ghci/prog021/prog021.script - + testsuite/tests/ghci/prog021/prog021.stderr - + testsuite/tests/ghci/prog021/prog021.stdout - testsuite/tests/ghci/scripts/ghci021.stderr Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -422,6 +422,8 @@ data DynFlags = DynFlags { -- | GHCi scripts specified by -ghci-script, in reverse order ghciScripts :: [String], + -- | Instruct GHCi to not load the targets immediately + ghciDontLoad :: Bool, -- Output style options pprUserLength :: Int, @@ -677,6 +679,7 @@ defaultDynFlags mySettings = customWarningCategories = completeWarningCategorySet, fatalCustomWarningCategories = emptyWarningCategorySet, ghciScripts = [], + ghciDontLoad = False, language = Nothing, safeHaskell = Sf_None, safeInfer = True, ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -135,6 +135,7 @@ import qualified GHC.Data.Maybe as M import GHC.Data.Graph.Directed.Reachability import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable +import qualified Data.List as List -- ----------------------------------------------------------------------------- -- Loading the program @@ -343,8 +344,9 @@ warnUnknownModules hsc_env dflags mod_graph = do data LoadHowMuch = LoadAllTargets -- ^ Load all targets and its dependencies. - | LoadUpTo HomeUnitModule + | LoadUpTo [HomeUnitModule] -- ^ Load only the given module and its dependencies. + -- If empty, we load none of the targets | LoadDependenciesOf HomeUnitModule -- ^ Load only the dependencies of the given module, but not the module -- itself. @@ -517,16 +519,16 @@ countMods (ResolvedCycle ns) = length ns countMods (UnresolvedCycle ns) = length ns -- See Note [Upsweep] for a high-level description. -createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan] +createBuildPlan :: ModuleGraph -> Maybe [HomeUnitModule] -> [BuildPlan] createBuildPlan mod_graph maybe_top_mod = let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles - cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod - + cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + cycle_mod_graph_with_boot_nodes = topSortModuleGraph False mod_graph maybe_top_mod -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles. build_plan :: [BuildPlan] build_plan -- Fast path, if there are no boot modules just do a normal toposort - | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod + | isEmptyModuleEnv boot_modules = collapseAcyclic cycle_mod_graph_with_boot_nodes | otherwise = toBuildPlan cycle_mod_graph [] toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan] @@ -599,13 +601,18 @@ createBuildPlan mod_graph maybe_top_mod = topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing + modGraphSize + | isEmptyModuleEnv boot_modules = lengthMGWithSCC cycle_mod_graph_with_boot_nodes + | otherwise = lengthMGWithSCC cycle_mod_graph in - - assertPpr (sum (map countMods build_plan) == lengthMG mod_graph) - (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMG mod_graph))]) + -- The assertion needs to operate on 'cycle_mod_graph' as we prune the module graph during 'topSortModuleGraph'. + assertPpr (sum (map countMods build_plan) == modGraphSize) + (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr modGraphSize)]) build_plan - + where + lengthMGWithSCC :: [SCC a] -> Int + lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0 -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally @@ -640,16 +647,20 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- check that the module given in HowMuch actually exists, otherwise -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m + let checkHowMuch (LoadUpTo ms) = checkMods ms + checkHowMuch (LoadDependenciesOf m) = checkMods [m] checkHowMuch _ = id - checkMod m and_then - | m `Set.member` all_home_mods = and_then - | otherwise = do - throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan - $ GhcDriverMessage - $ DriverModuleNotFound (moduleUnit m) (moduleName m) + checkMods ms and_then = + case List.partition (`Set.member` all_home_mods) ms of + (_, []) -> and_then + (_, not_found_mods) -> do + let + mkModuleNotFoundError m = + mkPlainErrorMsgEnvelope noSrcSpan + $ GhcDriverMessage + $ DriverModuleNotFound (moduleUnit m) (moduleName m) + throwErrors $ mkMessages $ listToBag [mkModuleNotFoundError not_found | not_found <- not_found_mods] checkHowMuch how_much $ do @@ -662,12 +673,12 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- are definitely unnecessary, then emit a warning. warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps) - let maybe_top_mod = case how_much of + let maybe_top_mods = case how_much of LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m + LoadDependenciesOf m -> Just [m] _ -> Nothing - build_plan = createBuildPlan mod_graph maybe_top_mod + build_plan = createBuildPlan mod_graph maybe_top_mods cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache @@ -1301,7 +1312,7 @@ topSortModuleGraph :: Bool -- ^ Drop hi-boot nodes? (see below) -> ModuleGraph - -> Maybe HomeUnitModule + -> Maybe [HomeUnitModule] -- ^ Root module name. If @Nothing@, use the full graph. -> [SCC ModuleGraphNode] -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes @@ -1351,7 +1362,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod = cmpModuleGraphNodes k1 k2 = compare (moduleGraphNodeRank k1) (moduleGraphNodeRank k2) `mappend` compare k2 k1 -topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode] +topSortModules :: Bool -> [ModuleGraphNode] -> Maybe [HomeUnitModule] -> [SCC ModuleGraphNode] topSortModules drop_hs_boot_nodes summaries mb_root_mod = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph where @@ -1360,17 +1371,20 @@ topSortModules drop_hs_boot_nodes summaries mb_root_mod initial_graph = case mb_root_mod of Nothing -> graph - Just (Module uid root_mod) -> + Just mods -> -- restrict the graph to just those modules reachable from -- the specified module. We do this by building a graph with -- the full set of nodes, and determining the reachable set from -- the specified node. - let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid - , graph `hasVertexG` node - = node - | otherwise - = throwGhcException (ProgramError "module does not exist") - in graphFromEdgedVerticesUniq (seq root (root:allReachable (graphReachability graph) root)) + let + findNodeForModule (Module uid root_mod) + | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid + , graph `hasVertexG` node + = seq node node + | otherwise + = throwGhcException (ProgramError "module does not exist") + roots = fmap findNodeForModule mods + in graphFromEdgedVerticesUniq (seq roots (roots ++ allReachableMany (graphReachability graph) roots)) newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a } deriving (Functor, Traversable, Foldable) ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -764,6 +764,9 @@ addHaddockOpts f d = d { haddockOptions = Just f} addGhciScript f d = d { ghciScripts = f : ghciScripts d} +setDontLoadGhci :: Bool -> DynP () +setDontLoadGhci f = upd $ \d -> d { ghciDontLoad = f } + setInteractivePrint f d = d { interactivePrint = Just f} ----------------------------------------------------------------------------- @@ -1344,6 +1347,8 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) + , make_ord_flag defGhciFlag "ghci-no-load" (NoArg (setDontLoadGhci True)) + , make_ord_flag defGhciFlag "ghci-load" (NoArg (setDontLoadGhci False)) , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) , make_ord_flag defGhcFlag "ticky-allocd" (NoArg (setGeneralFlag Opt_Ticky_Allocd)) ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -67,6 +67,7 @@ module GHC.Unit.Module.Graph , mapMG, mgMapM , mgModSummaries , mgLookupModule + , mgLookupModuleName , mgHasHoles , showModMsg @@ -523,6 +524,17 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss = Just ms go _ = Nothing +-- | +-- TODO @fendor: Docs +mgLookupModuleName :: ModuleGraph -> ModuleName -> [ModuleNodeInfo] +mgLookupModuleName ModuleGraph{..} m = mapMaybe go mg_mss + where + go (ModuleNode _ ms) + | NotBoot <- isBootModuleNodeInfo ms + , moduleName (moduleNodeInfoModule ms) == m + = Just ms + go _ = Nothing + mgMember :: ModuleGraph -> NodeKey -> Bool mgMember graph k = isJust $ snd (mg_graph graph) k ===================================== ghc/GHCi/UI.hs ===================================== @@ -948,7 +948,7 @@ runGHCi paths maybe_exprs = do -- immediately rather than going on to evaluate the expression. when (not (null paths)) $ do ok <- ghciHandle (\e -> do showException e; return Failed) $ - loadModule paths + initialLoadModule paths when (isJust maybe_exprs && failed ok) $ liftIO (exitWith (ExitFailure 1)) @@ -1302,7 +1302,8 @@ runOneCommand eh gCmd = do st <- getGHCiState ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndFail $ - cmd_wrapper st $ doCommand c + handleGhciCommandError printErrorAndContinue $ + cmd_wrapper st $ doCommand c -- source error's are handled by runStmt -- is the handler necessary here? where @@ -1310,6 +1311,10 @@ runOneCommand eh gCmd = do printGhciException err return $ Just False -- Exit ghc -e, but not GHCi + printErrorAndContinue err = do + printGhciCommandException err + return $ Just False -- Exit ghc -e, but not GHCi + noSpace q = q >>= maybe (return Nothing) (\c -> case removeSpaces c of "" -> noSpace q @@ -2196,6 +2201,11 @@ loadModule fs = do (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs) either (liftIO . Exception.throwIO) return result +initialLoadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag +initialLoadModule fs = do + (_, result) <- runAndPrintStats (const Nothing) (initialLoadModule' fs) + either (liftIO . Exception.throwIO) return result + -- | @:load@ command loadModule_ :: GhciMonad m => [FilePath] -> m () loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnitId)) (repeat Nothing)) @@ -2203,6 +2213,44 @@ loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnit loadModuleDefer :: GhciMonad m => [FilePath] -> m () loadModuleDefer = wrapDeferTypeErrors . loadModule_ +initialLoadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag +initialLoadModule' files = do + let (filenames, uids, phases) = unzip3 files + exp_filenames <- mapM expandPath filenames + let files' = zip3 exp_filenames uids phases + targets <- mapM (\(file, uid, phase) -> GHC.guessTarget file uid phase) files' + + -- NOTE: we used to do the dependency anal first, so that if it + -- fails we didn't throw away the current set of modules. This would + -- require some re-working of the GHC interface, so we'll leave it + -- as a ToDo for now. + + hsc_env <- GHC.getSession + let !dflags = hsc_dflags hsc_env + + let load_module = do + -- unload first + _ <- GHC.abandonAll + clearCaches + + GHC.setTargets targets + if ghciDontLoad dflags + then + doLoadAndCollectInfo Load (LoadUpTo []) + else + doLoadAndCollectInfo Load LoadAllTargets + + if gopt Opt_GhciLeakCheck dflags + then do + -- Grab references to the currently loaded modules so that we can see if + -- they leak. + leak_indicators <- liftIO $ getLeakIndicators hsc_env + success <- load_module + liftIO $ checkLeakIndicators dflags leak_indicators + return success + else + load_module + loadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag loadModule' files = do let (filenames, uids, phases) = unzip3 files @@ -2286,13 +2334,18 @@ unAddModule files = do -- | @:reload@ command reloadModule :: GhciMonad m => String -> m () reloadModule m = do - session <- GHC.getSession - let home_unit = homeUnitId (hsc_home_unit session) - ok <- doLoadAndCollectInfo Reload (loadTargets home_unit) + let mods = words m + loadTarget <- findLoadTargets mods + ok <- doLoadAndCollectInfo Reload loadTarget when (failed ok) failIfExprEvalMode where - loadTargets hu | null m = LoadAllTargets - | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m)) + findLoadTargets modls + | null modls = + pure LoadAllTargets + | otherwise = do + mod_graph <- GHC.getModuleGraph + let mods = concatMap (fmap (fmap toUnitId . GHC.moduleNodeInfoModule) . GHC.mgLookupModuleName mod_graph) [GHC.mkModuleName modl | modl <- modls] + pure $ LoadUpTo mods reloadModuleDefer :: GhciMonad m => String -> m () reloadModuleDefer = wrapDeferTypeErrors . reloadModule @@ -4747,8 +4800,11 @@ showException se = Just other_ghc_ex -> putException (show other_ghc_ex) Nothing -> case fromException se of - Just UserInterrupt -> putException "Interrupted." - _ -> putException ("*** Exception: " ++ show se) + Just (GhciCommandError s) -> putException (show (GhciCommandError s)) + Nothing -> + case fromException se of + Just UserInterrupt -> putException "Interrupted." + _ -> putException ("*** Exception: " ++ show se) where putException = hPutStrLn stderr @@ -4798,15 +4854,22 @@ lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module lookupQualifiedModuleName qual modl = do GHC.lookupAllQualifiedModuleNames qual modl >>= \case - [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found.")) + [] -> throwGhciCommandError (GhciModuleError $ GhciModuleNameNotFound modl) [m] -> pure m - ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms)) + ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + +lookupHomeUnitModuleName :: GHC.GhcMonad m => ModuleName -> m HomeUnitModule +lookupHomeUnitModuleName modl = do + m <- GHC.lookupLoadedHomeModuleByModuleName modl >>= \case + Nothing -> throwGhciCommandError (GhciModuleError $ GhciNoLocalModuleName modl) + Just [m] -> pure m + Just ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + + if unitIsDefinite (moduleUnit m) + then pure (fmap toUnitId m) + else throwGhcException (CmdLineError ("module '" ++ str ++ "' is not from a definite unit")) where str = moduleNameString modl - errorMsg ms = intercalate "\n" - [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) - | m <- ms - ] showModule :: Module -> String showModule = moduleNameString . moduleName ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -5,7 +5,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} module GHCi.UI.Exception - ( GhciMessage(..) + ( GhciCommandError(..) + , throwGhciCommandError + , handleGhciCommandError + , GhciMessage(..) , GhciMessageOpts(..) , fromGhcOpts , toGhcHint @@ -29,19 +32,57 @@ import GHC.Tc.Errors.Ppr import GHC.Tc.Errors.Types import GHC.Types.Error.Codes +import GHC.Types.SrcLoc (interactiveSrcSpan) import GHC.TypeLits import GHC.Unit.State import GHC.Utils.Outputable +import GHC.Utils.Error import GHC.Generics import GHC.Types.Error import GHC.Types import qualified GHC +import Control.Exception +import Control.Monad.Catch as MC (MonadCatch, catch) +import Control.Monad.IO.Class import Data.List.NonEmpty (NonEmpty(..)) +-- | A 'GhciCommandError' are messages that caused the abortion of a GHCi command. +newtype GhciCommandError = GhciCommandError (Messages GhciMessage) + +instance Exception GhciCommandError + +instance Show GhciCommandError where + -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics + -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. + -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. + show (GhciCommandError msgs) = + renderWithContext defaultSDocContext + . vcat + . pprMsgEnvelopeBagWithLocDefault + . getMessages + $ msgs + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleGhciCommandError :: (MonadCatch m) => + (GhciCommandError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleGhciCommandError handler act = + MC.catch act (\(e :: GhciCommandError) -> handler e) + +throwGhciCommandError :: MonadIO m => GhciCommandMessage -> m a +throwGhciCommandError errorMessage = + liftIO + . throwIO + . GhciCommandError + . singleMessage + $ mkPlainErrorMsgEnvelope interactiveSrcSpan (GhciCommandMessage errorMessage) + -- | The Options passed to 'diagnosticMessage' -- in the 'Diagnostic' instance of 'GhciMessage'. data GhciMessageOpts = GhciMessageOpts @@ -257,6 +298,9 @@ data GhciModuleError | GhciNoResolvedModules | GhciNoModuleForName GHC.Name | GhciNoMatchingModuleExport + | GhciNoLocalModuleName !GHC.ModuleName + | GhciModuleNameNotFound !GHC.ModuleName + | GhciAmbiguousModuleName !GHC.ModuleName ![GHC.Module] deriving Generic instance Diagnostic GhciModuleError where @@ -278,6 +322,16 @@ instance Diagnostic GhciModuleError where -> "No module for" <+> ppr name GhciNoMatchingModuleExport -> "No matching export in any local modules." + GhciNoLocalModuleName modl + -> "Module" <+> quotes (ppr modl) <+> "cannot be found locally" + GhciModuleNameNotFound modl + -> "module" <+> quotes (ppr modl) <+> "could not be found." + GhciAmbiguousModuleName modl candidates + -> "Module name" <+> quotes (ppr modl) <+> "is ambiguous" $+$ + vcat + [ text "-" <+> ppr (GHC.moduleName m) <> colon <> ppr (GHC.moduleUnit m) + | m <- candidates + ] diagnosticReason = \case GhciModuleNotFound{} -> @@ -294,6 +348,12 @@ instance Diagnostic GhciModuleError where ErrorWithoutFlag GhciNoMatchingModuleExport{} -> ErrorWithoutFlag + GhciNoLocalModuleName{} -> + ErrorWithoutFlag + GhciModuleNameNotFound{} -> + ErrorWithoutFlag + GhciAmbiguousModuleName{} -> + ErrorWithoutFlag diagnosticHints = \case GhciModuleNotFound{} -> @@ -310,7 +370,12 @@ instance Diagnostic GhciModuleError where [] GhciNoMatchingModuleExport{} -> [] - + GhciNoLocalModuleName{} -> + [] + GhciModuleNameNotFound{} -> + [] + GhciAmbiguousModuleName{} -> + [] diagnosticCode = constructorCode @GHCi -- | A Diagnostic emitted by GHCi while executing a command @@ -487,6 +552,9 @@ type family GhciDiagnosticCode c = n | n -> c where GhciDiagnosticCode "GhciNoModuleForName" = 21847 GhciDiagnosticCode "GhciNoMatchingModuleExport" = 59723 GhciDiagnosticCode "GhciArgumentParseError" = 35671 + GhciDiagnosticCode "GhciNoLocalModuleName" = 81235 + GhciDiagnosticCode "GhciModuleNameNotFound" = 40475 + GhciDiagnosticCode "GhciAmbiguousModuleName" = 59019 type GhciConRecursInto :: Symbol -> Maybe Type type family GhciConRecursInto con where ===================================== ghc/GHCi/UI/Print.hs ===================================== @@ -5,6 +5,7 @@ module GHCi.UI.Print , printForUserPartWay , printError , printGhciException + , printGhciCommandException ) where import qualified GHC @@ -64,7 +65,7 @@ printForUserPartWay doc = do -- | pretty-print a 'GhciCommandMessage' printError :: GhcMonad m => GhciCommandMessage -> m () printError err = - let errEnvelope = mkPlainErrorMsgEnvelope (UnhelpfulSpan UnhelpfulInteractive) err + let errEnvelope = mkPlainErrorMsgEnvelope interactiveSrcSpan err in printError' (const NoDiagnosticOpts) (singleMessage errEnvelope) -- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting @@ -72,6 +73,9 @@ printError err = printGhciException :: GhcMonad m => SourceError -> m () printGhciException err = printError' initGhciPrintConfig (GhciGhcMessage <$> (srcErrorMessages err)) +printGhciCommandException :: GhcMonad m => GhciCommandError -> m () +printGhciCommandException (GhciCommandError errs) = printError' initGhciPrintConfig errs + printError' :: (GhcMonad m, Diagnostic a) => (DynFlags -> DiagnosticOpts a) -> Messages a -> m () printError' get_config err = do dflags <- getDynFlags ===================================== testsuite/tests/ghc-e/should_fail/T18441fail5.stderr ===================================== @@ -1,4 +1,4 @@ -<no location info>: error: [GHC-82272] - module ‘Abcde’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘Abcde’ cannot be found locally 1 ===================================== testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr ===================================== @@ -1,9 +1,15 @@ -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + ===================================== testsuite/tests/ghci/prog021/A.hs ===================================== @@ -0,0 +1,5 @@ +module A (f) where + +f x = [x] + +g x = Just x ===================================== testsuite/tests/ghci/prog021/B.hs ===================================== @@ -0,0 +1,5 @@ +module B where + +import A + +h = f ===================================== testsuite/tests/ghci/prog021/Makefile ===================================== @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk ===================================== testsuite/tests/ghci/prog021/prog021.T ===================================== @@ -0,0 +1,6 @@ +test('prog021', + [req_interp, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + extra_files(['A.hs', 'B.hs', 'prog021.script']) + ], + ghci_script, ['prog021.script']) ===================================== testsuite/tests/ghci/prog021/prog021.script ===================================== @@ -0,0 +1,15 @@ +-- Loads all targets +:load A B +:m + A B +f 5 +g 5 +h 5 +-- Load only one target +:reload A +:m A +putStrLn "B is not loaded, we can't add it to the context" +:m + B +f 5 +putStrLn "`g` and `h` are not in scope" +g 5 +h 5 ===================================== testsuite/tests/ghci/prog021/prog021.stderr ===================================== @@ -0,0 +1,10 @@ +<no location info>: error: [GHC-35235] + Could not find module ‘B’. + It is not a module in the current program, or in any known package. + +<interactive>:14:1: error: [GHC-88464] + Variable not in scope: g :: t0 -> t + +<interactive>:15:1: error: [GHC-88464] + Variable not in scope: h :: t0 -> t + ===================================== testsuite/tests/ghci/prog021/prog021.stdout ===================================== @@ -0,0 +1,6 @@ +[5] +Just 5 +[5] +B is not loaded, we can't add it to the context +[5] +`g` and `h` are not in scope ===================================== testsuite/tests/ghci/scripts/ghci021.stderr ===================================== @@ -1,3 +1,3 @@ -<no location info>: error: [GHC-82272] - module ‘ThisDoesNotExist’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘ThisDoesNotExist’ cannot be found locally View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cc30b51ef77e59dc1e7971518311b4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cc30b51ef77e59dc1e7971518311b4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] Solve implications right away [skip ci]
by Simon Peyton Jones (＠simonpj) 23 Jun '25

23 Jun '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 174ebaae by Simon Peyton Jones at 2025-06-23T17:34:51+01:00 Solve implications right away [skip ci] .. a very nice simplification if we can really do it - - - - - 6 changed files: - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Solver/Solve.hs-boot - compiler/GHC/Tc/Types/Constraint.hs Changes: ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -2130,7 +2130,8 @@ mk_superclasses_of fuel rec_clss ev tvs theta cls tys -- NB: If there is a loop, we cut off, so we have not -- added the superclasses, hence cc_pend_sc = fuel | otherwise - = CQuantCan (QCI { qci_tvs = tvs, qci_body = mkClassPred cls tys + = CQuantCan (QCI { qci_tvs = tvs, qci_theta = theta + , qci_body = mkClassPred cls tys , qci_ev = ev, qci_pend_sc = fuel }) ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -10,6 +10,8 @@ module GHC.Tc.Solver.Equality( import GHC.Prelude +import {-# SOURCE #-} GHC.Tc.Solver.Solve( trySolveImplication ) + import GHC.Tc.Solver.Irred( solveIrred ) import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) import GHC.Tc.Solver.Rewrite @@ -468,7 +470,7 @@ can_eq_nc_forall :: CtEvidence -> EqRel -- See Note [Solving forall equalities] can_eq_nc_forall ev eq_rel s1 s2 - | CtWanted (WantedCt { ctev_dest = orig_dest }) <- ev + | CtWanted (WantedCt { ctev_dest = orig_dest, ctev_loc = loc }) <- ev = do { let (bndrs1, phi1, bndrs2, phi2) = split_foralls s1 s2 flags1 = binderFlags bndrs1 flags2 = binderFlags bndrs2 @@ -481,9 +483,10 @@ can_eq_nc_forall ev eq_rel s1 s2 else do { traceTcS "Creating implication for polytype equality" (ppr ev) - ; let free_tvs = tyCoVarsOfTypes [s1,s2] - empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs - ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1) + ; let free_tvs = tyCoVarsOfTypes [s1,s2] + empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs + skol_info_anon = UnifyForAllSkol phi1 + ; skol_info <- mkSkolemInfo skol_info_anon ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ binderVars bndrs1 @@ -528,10 +531,21 @@ can_eq_nc_forall ev eq_rel s1 s2 unifyForAllBody ev (eqRelRole eq_rel) $ \uenv -> go uenv skol_tvs init_subst2 bndrs1 bndrs2 - ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds - - ; setWantedEq orig_dest all_co - ; stopWith ev "Deferred polytype equality" } } + ; ev_binds_var <- newNoTcEvBinds + ; solved <- trySolveImplication $ + (implicationPrototype (ctLocEnv loc)) + { ic_tclvl = lvl + , ic_binds = ev_binds_var + , ic_info = skol_info_anon + , ic_warn_inaccessible = False + , ic_skols = skol_tvs + , ic_given = [] + , ic_wanted = emptyWC { wc_simple = wanteds } } + + ; if solved + then do { setWantedEq orig_dest all_co + ; stopWith ev "Polytype equality: solved" } + else canEqSoftFailure IrredShapeReason ev s1 s2 } } | otherwise = do { traceTcS "Omitting decomposition of given polytype equality" $ @@ -834,18 +848,26 @@ canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2) = do { inerts <- getInertSet ; if can_decompose inerts then canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2) - else canEqSoftFailure ev eq_rel ty1 ty2 } + else assert (eq_rel == ReprEq) $ + canEqSoftFailure ReprEqReason ev ty1 ty2 } -- See Note [Skolem abstract data] in GHC.Core.Tycon | tyConSkolem tc1 || tyConSkolem tc2 = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) ; finishCanWithIrred AbstractTyConReason ev } - | otherwise -- Different TyCons - = if both_generative -- See (TC2) and (TC3) in - -- Note [Canonicalising TyCon/TyCon equalities] - then canEqHardFailure ev ty1 ty2 - else canEqSoftFailure ev eq_rel ty1 ty2 + -- Different TyCons + | NomEq <- eq_rel + = canEqHardFailure ev ty1 ty2 + + -- Different TyCons, eq_rel = ReprEq + -- See (TC2) and (TC3) in + -- Note [Canonicalising TyCon/TyCon equalities] + | both_generative + = canEqHardFailure ev ty1 ty2 + + | otherwise + = canEqSoftFailure ReprEqReason ev ty1 ty2 where -- See Note [Decomposing TyConApp equalities] -- and Note [Decomposing newtype equalities] @@ -1417,20 +1439,18 @@ canDecomposableFunTy ev eq_rel af f1@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2) -- | Call canEqSoftFailure when canonicalizing an equality fails, but if the -- equality is representational, there is some hope for the future. -canEqSoftFailure :: CtEvidence -> EqRel -> TcType -> TcType +canEqSoftFailure :: CtIrredReason -> CtEvidence -> TcType -> TcType -> TcS (StopOrContinue (Either IrredCt a)) -canEqSoftFailure ev NomEq ty1 ty2 - = canEqHardFailure ev ty1 ty2 -canEqSoftFailure ev ReprEq ty1 ty2 +canEqSoftFailure reason ev ty1 ty2 = do { (redn1, rewriters1) <- rewrite ev ty1 ; (redn2, rewriters2) <- rewrite ev ty2 -- We must rewrite the types before putting them in the -- inert set, so that we are sure to kick them out when -- new equalities become available - ; traceTcS "canEqSoftFailure with ReprEq" $ + ; traceTcS "canEqSoftFailure" $ vcat [ ppr ev, ppr redn1, ppr redn2 ] ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; finishCanWithIrred ReprEqReason new_ev } + ; finishCanWithIrred reason new_ev } -- | Call when canonicalizing an equality fails with utterly no hope. canEqHardFailure :: CtEvidence -> TcType -> TcType ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -758,12 +758,14 @@ getUnsolvedInerts , inert_funeqs = fun_eqs , inert_irreds = irreds , inert_dicts = idicts + , inert_insts = qcis } <- getInertCans ; let unsolved_tv_eqs = foldTyEqs (add_if_unsolved CEqCan) tv_eqs emptyCts unsolved_fun_eqs = foldFunEqs (add_if_unsolved CEqCan) fun_eqs emptyCts unsolved_irreds = foldr (add_if_unsolved CIrredCan) emptyCts irreds unsolved_dicts = foldDicts (add_if_unsolved CDictCan) idicts emptyCts + unsolved_qcis = foldr (add_if_unsolved CQuantCan) emptyCts qcis ; implics <- getWorkListImplics @@ -774,10 +776,11 @@ getUnsolvedInerts , text "irreds =" <+> ppr unsolved_irreds , text "implics =" <+> ppr implics ] - ; return ( implics, unsolved_tv_eqs `unionBags` + ; return ( implics, unsolved_tv_eqs `unionBags` unsolved_fun_eqs `unionBags` - unsolved_irreds `unionBags` - unsolved_dicts ) } + unsolved_irreds `unionBags` + unsolved_dicts `unionBags` + unsolved_qcis ) } where add_if_unsolved :: (a -> Ct) -> a -> Cts -> Cts add_if_unsolved mk_ct thing cts ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -7,6 +7,7 @@ module GHC.Tc.Solver.Solve ( solveWanteds, -- Solves WantedConstraints solveSimpleGivens, -- Solves [Ct] solveSimpleWanteds, -- Solves Cts + trySolveImplication, setImplicationStatus ) where @@ -1114,14 +1115,15 @@ solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel , eq_lhs = lhs, eq_rhs = rhs })) = solveEquality ev eq_rel (canEqLHSType lhs) rhs -solveCt (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) - = do { ev <- rewriteEvidence ev +solveCt (CQuantCan qci@(QCI { qci_ev = ev })) + = do { ev' <- rewriteEvidence ev -- It is (much) easier to rewrite and re-classify than to -- rewrite the pieces and build a Reduction that will rewrite -- the whole constraint - ; case classifyPredType (ctEvPred ev) of - ForAllPred tvs theta body_pred -> - Stage $ solveForAll ev tvs theta body_pred pend_sc + ; case classifyPredType (ctEvPred ev') of + ForAllPred tvs theta body_pred + -> solveForAll (qci { qci_ev = ev', qci_tvs = tvs + , qci_theta = theta, qci_body = body_pred }) _ -> pprPanic "SolveCt" (ppr ev) } solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc })) @@ -1155,7 +1157,7 @@ solveNC ev -- And then re-classify ; case classifyPredType (ctEvPred ev) of ClassPred cls tys -> solveDictNC ev cls tys - ForAllPred tvs th p -> Stage $ solveForAllNC ev tvs th p + ForAllPred tvs th p -> solveForAllNC ev tvs th p IrredPred {} -> solveIrred (IrredCt { ir_ev = ev, ir_reason = IrredShapeReason }) EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 -- EqPred only happens if (say) `c` is unified with `a ~# b`, @@ -1246,51 +1248,49 @@ type signature. -- -- Precondition: the constraint has already been rewritten by the inert set. solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType - -> TcS (StopOrContinue Void) + -> SolverStage Void solveForAllNC ev tvs theta body_pred - | Just (cls,tys) <- getClassPredTys_maybe body_pred - , classHasSCs cls - = do { dflags <- getDynFlags - -- Either expand superclasses (Givens) or provide fuel to do so (Wanteds) - ; if isGiven ev - then - -- See Note [Eagerly expand given superclasses] - -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] - do { sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys - ; emitWork (listToBag sc_cts) - ; solveForAll ev tvs theta body_pred doNotExpand } - else - -- See invariants (a) and (b) in QCI.qci_pend_sc - -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] - -- See Note [Quantified constraints] - do { solveForAll ev tvs theta body_pred (qcsFuel dflags) } - } + = do { fuel <- simpleStage mk_super_classes + ; solveForAll (QCI { qci_ev = ev, qci_tvs = tvs, qci_theta = theta + , qci_body = body_pred, qci_pend_sc = fuel }) } - | otherwise - = solveForAll ev tvs theta body_pred doNotExpand + where + mk_super_classes :: TcS ExpansionFuel + mk_super_classes + | Just (cls,tys) <- getClassPredTys_maybe body_pred + , classHasSCs cls + = do { dflags <- getDynFlags + -- Either expand superclasses (Givens) or provide fuel to do so (Wanteds) + ; if isGiven ev + then + -- See Note [Eagerly expand given superclasses] + -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + do { sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys + ; emitWork (listToBag sc_cts) + ; return doNotExpand } + else + -- See invariants (a) and (b) in QCI.qci_pend_sc + -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + -- See Note [Quantified constraints] + return (qcsFuel dflags) + } + + | otherwise + = return doNotExpand -- | Solve a canonical quantified constraint. -- -- Precondition: the constraint has already been rewritten by the inert set. -solveForAll :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> ExpansionFuel - -> TcS (StopOrContinue Void) -solveForAll ev tvs theta body_pred fuel +solveForAll :: QCInst -> SolverStage Void +solveForAll qci@(QCI { qci_ev = ev, qci_tvs = tvs, qci_theta = theta, qci_body = pred }) = case ev of CtGiven {} -> -- See Note [Solving a Given forall-constraint] - do { addInertForAll qci - ; stopWith ev "Given forall-constraint" } + do { simpleStage (addInertForAll qci) + ; stopWithStage ev "Given forall-constraint" } CtWanted wtd -> - do { mode <- getTcSMode - ; case mode of -- See Note [TcSSpecPrag] in GHC.Tc.Solver.Monad. - TcSSpecPrag -> solveWantedForAll_spec wtd - _ -> runSolverStage $ - do { tryInertQCs qci - ; solveWantedForAll_norm wtd tvs theta body_pred } } - where - qci = QCI { qci_ev = ev, qci_tvs = tvs - , qci_body = body_pred, qci_pend_sc = fuel } - + do { tryInertQCs qci + ; solveWantedForAll qci tvs theta pred wtd } tryInertQCs :: QCInst -> SolverStage () tryInertQCs qc @@ -1316,11 +1316,11 @@ try_inert_qcs (QCI { qci_ev = ev_w }) inerts = -- | Solve a (canonical) Wanted quantified constraint by emitting an implication. -- See Note [Solving a Wanted forall-constraint] -solveWantedForAll_norm :: WantedCtEvidence -> [TcTyVar] -> TcThetaType -> PredType - -> SolverStage Void -solveWantedForAll_norm wtd@(WantedCt { ctev_dest = dest, ctev_loc = ct_loc - , ctev_rewriters = rewriters }) - tvs theta body_pred +solveWantedForAll :: QCInst -> [TcTyVar] -> TcThetaType -> PredType + -> WantedCtEvidence -> SolverStage Void +solveWantedForAll qci tvs theta body_pred + wtd@(WantedCt { ctev_dest = dest, ctev_loc = ct_loc + , ctev_rewriters = rewriters }) = Stage $ TcS.setSrcSpan (getCtLocEnvLoc loc_env) $ -- This setSrcSpan is important: the emitImplicationTcS uses that @@ -1349,27 +1349,25 @@ solveWantedForAll_norm wtd@(WantedCt { ctev_dest = dest, ctev_loc = ct_loc , unitBag (mkNonCanonical $ CtWanted wanted_ev)) } ; traceTcS "solveForAll" (ppr given_ev_vars $$ ppr wanteds $$ ppr w_id) - ; ev_binds_var <- newTcEvBinds + ; ev_binds_var <- TcS.newTcEvBinds ; solved <- trySolveImplication $ - implicationPrototype loc_env + (implicationPrototype loc_env) { ic_tclvl = lvl , ic_binds = ev_binds_var , ic_info = skol_info_anon - , ic_warn_inacessible = False + , ic_warn_inaccessible = False , ic_skols = skol_tvs , ic_given = given_ev_vars , ic_wanted = emptyWC { wc_simple = wanteds } } ; if not solved - then updInertIrreds ( - else - do { ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds - - ; setWantedEvTerm dest EvCanonical $ - EvFun { et_tvs = skol_tvs, et_given = given_ev_vars - , et_binds = ev_binds, et_body = w_id } - ; stopWith (CtWanted wtd) "Wanted forall-constraint (implication)" } + then do { addInertForAll qci + ; stopWith (CtWanted wtd) "Wanted forall-constraint:unsolved" } + else do { setWantedEvTerm dest EvCanonical $ + EvFun { et_tvs = skol_tvs, et_given = given_ev_vars + , et_binds = TcEvBinds ev_binds_var, et_body = w_id } + ; stopWith (CtWanted wtd) "Wanted forall-constraint:solved" } } where - loc_env = ctLocEnv loc + loc_env = ctLocEnv ct_loc is_qc = IsQC (ctLocOrigin ct_loc) empty_subst = mkEmptySubst $ mkInScopeSet $ @@ -1381,6 +1379,14 @@ solveWantedForAll_norm wtd@(WantedCt { ctev_dest = dest, ctev_loc = ct_loc ClassPred cls tys -> pSizeClassPred cls tys _ -> pSizeType pred +trySolveImplication :: Implication -> TcS Bool +trySolveImplication imp + = tryTcS $ + do { imp' <- solveImplication imp + ; return (emptyWC { wc_impl = unitBag imp' }) } + -- ToDo: this emptyWC bit is somewhat clumsy + +{- solveWantedForAll_spec :: WantedCtEvidence -> TcS (StopOrContinue Void) -- Solve this implication constraint completely or not at all solveWantedForAll_spec wtd @@ -1399,7 +1405,7 @@ solveWantedForAll_spec wtd ; return $ Stop ev (text "Not fully solved:" <+> ppr wtd) } } where ev = CtWanted wtd - +-} {- Note [Solving a Wanted forall-constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Solver/Solve.hs-boot ===================================== @@ -1,6 +1,8 @@ module GHC.Tc.Solver.Solve where +import Prelude( Bool ) import GHC.Tc.Solver.Monad( TcS ) -import GHC.Tc.Types.Constraint( WantedConstraints, Cts ) +import GHC.Tc.Types.Constraint( WantedConstraints, Cts, Implication ) -solveSimpleWanteds :: Cts -> TcS WantedConstraints \ No newline at end of file +solveSimpleWanteds :: Cts -> TcS WantedConstraints +trySolveImplication :: Implication -> TcS Bool ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -351,9 +351,10 @@ instance Outputable IrredCt where -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve data QCInst -- | A quantified constraint, of type @forall tvs. context => ty@ - = QCI { qci_ev :: CtEvidence - , qci_tvs :: [TcTyVar] -- ^ @tvs@ - , qci_body :: TcPredType -- ^ the body of the @forall@, i.e. @ty@ + = QCI { qci_ev :: CtEvidence -- See Note [Ct/evidence invariant] + , qci_tvs :: [TcTyVar] -- ^ @tvs@ + , qci_theta :: TcThetaType + , qci_body :: TcPredType -- ^ the body of the @forall@, i.e. @ty@ , qci_pend_sc :: ExpansionFuel -- ^ Invariants: qci_pend_sc > 0 => -- @@ -990,8 +991,8 @@ pendingScDict_maybe _ = Nothing pendingScInst_maybe :: QCInst -> Maybe QCInst -- Same as isPendingScDict, but for QCInsts -pendingScInst_maybe qci@(QCI { qci_flav = flav, qci_pend_sc = f }) - | Given <- flav -- Do not expand Wanted QCIs +pendingScInst_maybe qci@(QCI { qci_ev = ev, qci_pend_sc = f }) + | isGiven ev -- Do not expand Wanted QCIs , pendingFuel f = Just (qci { qci_pend_sc = doNotExpand }) | otherwise = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/174ebaae7fff80dbf5f313e8702fb03… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/174ebaae7fff80dbf5f313e8702fb03… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/fix-reload-targets] Teach `:reload` about multiple home units
by Hannes Siebenhandl (＠fendor) 23 Jun '25

23 Jun '25

Hannes Siebenhandl pushed to branch wip/fendor/fix-reload-targets at Glasgow Haskell Compiler / GHC Commits: 83255056 by fendor at 2025-06-23T18:29:10+02:00 Teach `:reload` about multiple home units `:reload` needs to lookup the `ModuleName` and must not assume the given `ModuleName` is in the current `HomeUnit`. We add a new utility function which allows us to find a `HomeUnitModule` instead of a `Module`. Further, we introduce the `GhciCommandError` type which can be used to abort the execution of a GHCi command. This error is caught and printed in a human readable fashion. - - - - - 14 changed files: - compiler/GHC/Driver/Make.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - ghc/GHCi/UI/Print.hs - testsuite/tests/ghc-e/should_fail/T18441fail5.stderr - testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr - + testsuite/tests/ghci/prog021/A.hs - + testsuite/tests/ghci/prog021/B.hs - + testsuite/tests/ghci/prog021/Makefile - + testsuite/tests/ghci/prog021/prog021.T - + testsuite/tests/ghci/prog021/prog021.script - + testsuite/tests/ghci/prog021/prog021.stderr - + testsuite/tests/ghci/prog021/prog021.stdout - testsuite/tests/ghci/scripts/ghci021.stderr Changes: ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -135,6 +135,7 @@ import qualified GHC.Data.Maybe as M import GHC.Data.Graph.Directed.Reachability import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable +import qualified Data.List as List -- ----------------------------------------------------------------------------- -- Loading the program @@ -520,13 +521,13 @@ countMods (UnresolvedCycle ns) = length ns createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan] createBuildPlan mod_graph maybe_top_mod = let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles - cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod - + cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + cycle_mod_graph_with_boot_nodes = topSortModuleGraph False mod_graph maybe_top_mod -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles. build_plan :: [BuildPlan] build_plan -- Fast path, if there are no boot modules just do a normal toposort - | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod + | isEmptyModuleEnv boot_modules = collapseAcyclic cycle_mod_graph_with_boot_nodes | otherwise = toBuildPlan cycle_mod_graph [] toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan] @@ -599,13 +600,18 @@ createBuildPlan mod_graph maybe_top_mod = topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing + modGraphSize + | isEmptyModuleEnv boot_modules = lengthMGWithSCC cycle_mod_graph_with_boot_nodes + | otherwise = lengthMGWithSCC cycle_mod_graph in - - assertPpr (sum (map countMods build_plan) == lengthMG mod_graph) - (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMG mod_graph))]) + -- The assertion needs to operate on 'cycle_mod_graph' as we prune the module graph during 'topSortModuleGraph'. + assertPpr (sum (map countMods build_plan) == modGraphSize) + (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr modGraphSize)]) build_plan - + where + lengthMGWithSCC :: [SCC a] -> Int + lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0 -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally ===================================== ghc/GHCi/UI.hs ===================================== @@ -1302,7 +1302,8 @@ runOneCommand eh gCmd = do st <- getGHCiState ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndFail $ - cmd_wrapper st $ doCommand c + handleGhciCommandError printErrorAndContinue $ + cmd_wrapper st $ doCommand c -- source error's are handled by runStmt -- is the handler necessary here? where @@ -1310,6 +1311,10 @@ runOneCommand eh gCmd = do printGhciException err return $ Just False -- Exit ghc -e, but not GHCi + printErrorAndContinue err = do + printGhciCommandException err + return $ Just False -- Exit ghc -e, but not GHCi + noSpace q = q >>= maybe (return Nothing) (\c -> case removeSpaces c of "" -> noSpace q @@ -2286,13 +2291,16 @@ unAddModule files = do -- | @:reload@ command reloadModule :: GhciMonad m => String -> m () reloadModule m = do - session <- GHC.getSession - let home_unit = homeUnitId (hsc_home_unit session) - ok <- doLoadAndCollectInfo Reload (loadTargets home_unit) + loadTarget <- findLoadTarget + ok <- doLoadAndCollectInfo Reload loadTarget when (failed ok) failIfExprEvalMode where - loadTargets hu | null m = LoadAllTargets - | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m)) + findLoadTarget + | null m = + pure LoadAllTargets + | otherwise = do + mod' <- lookupHomeUnitModuleName (GHC.mkModuleName m) + pure $ LoadUpTo mod' reloadModuleDefer :: GhciMonad m => String -> m () reloadModuleDefer = wrapDeferTypeErrors . reloadModule @@ -4747,8 +4755,11 @@ showException se = Just other_ghc_ex -> putException (show other_ghc_ex) Nothing -> case fromException se of - Just UserInterrupt -> putException "Interrupted." - _ -> putException ("*** Exception: " ++ show se) + Just (GhciCommandError s) -> putException (show (GhciCommandError s)) + Nothing -> + case fromException se of + Just UserInterrupt -> putException "Interrupted." + _ -> putException ("*** Exception: " ++ show se) where putException = hPutStrLn stderr @@ -4798,15 +4809,22 @@ lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module lookupQualifiedModuleName qual modl = do GHC.lookupAllQualifiedModuleNames qual modl >>= \case - [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found.")) + [] -> throwGhciCommandError (GhciModuleError $ GhciModuleNameNotFound modl) [m] -> pure m - ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms)) + ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + +lookupHomeUnitModuleName :: GHC.GhcMonad m => ModuleName -> m HomeUnitModule +lookupHomeUnitModuleName modl = do + m <- GHC.lookupLoadedHomeModuleByModuleName modl >>= \case + Nothing -> throwGhciCommandError (GhciModuleError $ GhciNoLocalModuleName modl) + Just [m] -> pure m + Just ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + + if unitIsDefinite (moduleUnit m) + then pure (fmap toUnitId m) + else throwGhcException (CmdLineError ("module '" ++ str ++ "' is not from a definite unit")) where str = moduleNameString modl - errorMsg ms = intercalate "\n" - [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) - | m <- ms - ] showModule :: Module -> String showModule = moduleNameString . moduleName ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -5,7 +5,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} module GHCi.UI.Exception - ( GhciMessage(..) + ( GhciCommandError(..) + , throwGhciCommandError + , handleGhciCommandError + , GhciMessage(..) , GhciMessageOpts(..) , fromGhcOpts , toGhcHint @@ -29,19 +32,57 @@ import GHC.Tc.Errors.Ppr import GHC.Tc.Errors.Types import GHC.Types.Error.Codes +import GHC.Types.SrcLoc (interactiveSrcSpan) import GHC.TypeLits import GHC.Unit.State import GHC.Utils.Outputable +import GHC.Utils.Error import GHC.Generics import GHC.Types.Error import GHC.Types import qualified GHC +import Control.Exception +import Control.Monad.Catch as MC (MonadCatch, catch) +import Control.Monad.IO.Class import Data.List.NonEmpty (NonEmpty(..)) +-- | A 'GhciCommandError' are messages that caused the abortion of a GHCi command. +newtype GhciCommandError = GhciCommandError (Messages GhciMessage) + +instance Exception GhciCommandError + +instance Show GhciCommandError where + -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics + -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. + -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. + show (GhciCommandError msgs) = + renderWithContext defaultSDocContext + . vcat + . pprMsgEnvelopeBagWithLocDefault + . getMessages + $ msgs + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleGhciCommandError :: (MonadCatch m) => + (GhciCommandError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleGhciCommandError handler act = + MC.catch act (\(e :: GhciCommandError) -> handler e) + +throwGhciCommandError :: MonadIO m => GhciCommandMessage -> m a +throwGhciCommandError errorMessage = + liftIO + . throwIO + . GhciCommandError + . singleMessage + $ mkPlainErrorMsgEnvelope interactiveSrcSpan (GhciCommandMessage errorMessage) + -- | The Options passed to 'diagnosticMessage' -- in the 'Diagnostic' instance of 'GhciMessage'. data GhciMessageOpts = GhciMessageOpts @@ -257,6 +298,9 @@ data GhciModuleError | GhciNoResolvedModules | GhciNoModuleForName GHC.Name | GhciNoMatchingModuleExport + | GhciNoLocalModuleName !GHC.ModuleName + | GhciModuleNameNotFound !GHC.ModuleName + | GhciAmbiguousModuleName !GHC.ModuleName ![GHC.Module] deriving Generic instance Diagnostic GhciModuleError where @@ -278,6 +322,16 @@ instance Diagnostic GhciModuleError where -> "No module for" <+> ppr name GhciNoMatchingModuleExport -> "No matching export in any local modules." + GhciNoLocalModuleName modl + -> "Module" <+> quotes (ppr modl) <+> "cannot be found locally" + GhciModuleNameNotFound modl + -> "module" <+> quotes (ppr modl) <+> "could not be found." + GhciAmbiguousModuleName modl candidates + -> "Module name" <+> quotes (ppr modl) <+> "is ambiguous" $+$ + vcat + [ text "-" <+> ppr (GHC.moduleName m) <> colon <> ppr (GHC.moduleUnit m) + | m <- candidates + ] diagnosticReason = \case GhciModuleNotFound{} -> @@ -294,6 +348,12 @@ instance Diagnostic GhciModuleError where ErrorWithoutFlag GhciNoMatchingModuleExport{} -> ErrorWithoutFlag + GhciNoLocalModuleName{} -> + ErrorWithoutFlag + GhciModuleNameNotFound{} -> + ErrorWithoutFlag + GhciAmbiguousModuleName{} -> + ErrorWithoutFlag diagnosticHints = \case GhciModuleNotFound{} -> @@ -310,7 +370,12 @@ instance Diagnostic GhciModuleError where [] GhciNoMatchingModuleExport{} -> [] - + GhciNoLocalModuleName{} -> + [] + GhciModuleNameNotFound{} -> + [] + GhciAmbiguousModuleName{} -> + [] diagnosticCode = constructorCode @GHCi -- | A Diagnostic emitted by GHCi while executing a command @@ -487,6 +552,9 @@ type family GhciDiagnosticCode c = n | n -> c where GhciDiagnosticCode "GhciNoModuleForName" = 21847 GhciDiagnosticCode "GhciNoMatchingModuleExport" = 59723 GhciDiagnosticCode "GhciArgumentParseError" = 35671 + GhciDiagnosticCode "GhciNoLocalModuleName" = 81235 + GhciDiagnosticCode "GhciModuleNameNotFound" = 40475 + GhciDiagnosticCode "GhciAmbiguousModuleName" = 59019 type GhciConRecursInto :: Symbol -> Maybe Type type family GhciConRecursInto con where ===================================== ghc/GHCi/UI/Print.hs ===================================== @@ -5,6 +5,7 @@ module GHCi.UI.Print , printForUserPartWay , printError , printGhciException + , printGhciCommandException ) where import qualified GHC @@ -64,7 +65,7 @@ printForUserPartWay doc = do -- | pretty-print a 'GhciCommandMessage' printError :: GhcMonad m => GhciCommandMessage -> m () printError err = - let errEnvelope = mkPlainErrorMsgEnvelope (UnhelpfulSpan UnhelpfulInteractive) err + let errEnvelope = mkPlainErrorMsgEnvelope interactiveSrcSpan err in printError' (const NoDiagnosticOpts) (singleMessage errEnvelope) -- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting @@ -72,6 +73,9 @@ printError err = printGhciException :: GhcMonad m => SourceError -> m () printGhciException err = printError' initGhciPrintConfig (GhciGhcMessage <$> (srcErrorMessages err)) +printGhciCommandException :: GhcMonad m => GhciCommandError -> m () +printGhciCommandException (GhciCommandError errs) = printError' initGhciPrintConfig errs + printError' :: (GhcMonad m, Diagnostic a) => (DynFlags -> DiagnosticOpts a) -> Messages a -> m () printError' get_config err = do dflags <- getDynFlags ===================================== testsuite/tests/ghc-e/should_fail/T18441fail5.stderr ===================================== @@ -1,4 +1,4 @@ -<no location info>: error: [GHC-82272] - module ‘Abcde’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘Abcde’ cannot be found locally 1 ===================================== testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr ===================================== @@ -1,9 +1,15 @@ -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + ===================================== testsuite/tests/ghci/prog021/A.hs ===================================== @@ -0,0 +1,5 @@ +module A (f) where + +f x = [x] + +g x = Just x ===================================== testsuite/tests/ghci/prog021/B.hs ===================================== @@ -0,0 +1,5 @@ +module B where + +import A + +h = f ===================================== testsuite/tests/ghci/prog021/Makefile ===================================== @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk ===================================== testsuite/tests/ghci/prog021/prog021.T ===================================== @@ -0,0 +1,6 @@ +test('prog021', + [req_interp, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + extra_files(['A.hs', 'B.hs', 'prog021.script']) + ], + ghci_script, ['prog021.script']) ===================================== testsuite/tests/ghci/prog021/prog021.script ===================================== @@ -0,0 +1,15 @@ +-- Loads all targets +:load A B +:m + A B +f 5 +g 5 +h 5 +-- Load only one target +:reload A +:m A +putStrLn "B is not loaded, we can't add it to the context" +:m + B +f 5 +putStrLn "`g` and `h` are not in scope" +g 5 +h 5 ===================================== testsuite/tests/ghci/prog021/prog021.stderr ===================================== @@ -0,0 +1,10 @@ +<no location info>: error: [GHC-35235] + Could not find module ‘B’. + It is not a module in the current program, or in any known package. + +<interactive>:14:1: error: [GHC-88464] + Variable not in scope: g :: t0 -> t + +<interactive>:15:1: error: [GHC-88464] + Variable not in scope: h :: t0 -> t + ===================================== testsuite/tests/ghci/prog021/prog021.stdout ===================================== @@ -0,0 +1,6 @@ +[5] +Just 5 +[5] +B is not loaded, we can't add it to the context +[5] +`g` and `h` are not in scope ===================================== testsuite/tests/ghci/scripts/ghci021.stderr ===================================== @@ -1,3 +1,3 @@ -<no location info>: error: [GHC-82272] - module ‘ThisDoesNotExist’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘ThisDoesNotExist’ cannot be found locally View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8325505603bc54f7a93d24765cc5d21… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8325505603bc54f7a93d24765cc5d21… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ani/code-ctxt
by Apoorv Ingle (＠ani) 23 Jun '25

23 Jun '25

Apoorv Ingle pushed new branch wip/ani/code-ctxt at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ani/code-ctxt You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23675] configure: Check LlvmTarget exists for LlvmAsFlags
by Rodrigo Mesquita (＠alt-romes) 23 Jun '25

23 Jun '25

Rodrigo Mesquita pushed to branch wip/T23675 at Glasgow Haskell Compiler / GHC Commits: e41924c2 by Rodrigo Mesquita at 2025-06-23T16:01:21+01:00 configure: Check LlvmTarget exists for LlvmAsFlags If LlvmTarget was empty, LlvmAsFlags would be just "--target=". If it is empty now, simply keep LlvmAsFlags empty. ghc-toolchain already does this right. This fix makes the two configurations match up. - - - - - 1 changed file: - distrib/configure.ac.in Changes: ===================================== distrib/configure.ac.in ===================================== @@ -216,7 +216,7 @@ AC_SUBST([LlvmAsCmd]) dnl We know that `clang` supports `--target` and it is necessary to pass it dnl lest we see #25793. -if test -z "$LlvmAsFlags" ; then +if test -z "$LlvmAsFlags" && ! test -z "$LlvmTarget"; then LlvmAsFlags="--target=$LlvmTarget" fi AC_SUBST([LlvmAsFlags]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e41924c28c0866c8f0074a66f942b9e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e41924c28c0866c8f0074a66f942b9e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/no-load
by Hannes Siebenhandl (＠fendor) 23 Jun '25

23 Jun '25

Hannes Siebenhandl pushed new branch wip/fendor/no-load at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/no-load You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-5] 2 commits: debugger: Implement step-out feature
by Rodrigo Mesquita (＠alt-romes) 23 Jun '25

23 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-5 at Glasgow Haskell Compiler / GHC Commits: d168e1da by Rodrigo Mesquita at 2025-06-23T15:16:39+01:00 debugger: Implement step-out feature Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. On the other hand, it means the debugger follows the more realistic execution of the program. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key idea is simple: When step-out is enabled, traverse the runtime stack until a continuation BCO is found -- and enable the breakpoint heading that BCO explicitly using its tick-index. The details are specified in `Note [Debugger: Step-out]` in `rts/Interpreter.c`. Since PUSH_ALTS BCOs (representing case continuations) were never headed by a breakpoint (unlike the case alternatives they push), we introduced the BRK_ALTS instruction to allow the debugger to set a case continuation to stop at the breakpoint heading the alternative that is taken. This is further described in `Note [Debugger: BRK_ALTS]`. Fixes #26042 - - - - - 9d82d42f by Rodrigo Mesquita at 2025-06-23T15:16:39+01:00 debugger: Filter step-out stops by SrcSpan To implement step-out, the RTS looks for the first continuation frame on the stack and explicitly enables its entry breakpoint. However, some continuations will be contained in the function from which step-out was initiated (trivial example is a case expression). Similarly to steplocal, we will filter the breakpoints at which the RTS yields to the debugger based on the SrcSpan. When doing step-out, only stop if the breakpoint is /not/ contained in the function from which we initiated it. This is especially relevant in monadic statements such as IO which is compiled to a long chain of case expressions. See Note [Debugger: Filtering step-out stops] - - - - - 44 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/StgToByteCode.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Disassembler.c - rts/Interpreter.c - rts/Interpreter.h - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/rts/Bytecodes.h - rts/include/rts/Constants.h - rts/include/rts/storage/Closures.h - + testsuite/tests/ghci.debugger/scripts/T26042b.hs - + testsuite/tests/ghci.debugger/scripts/T26042b.script - + testsuite/tests/ghci.debugger/scripts/T26042b.stdout - + testsuite/tests/ghci.debugger/scripts/T26042c.hs - + testsuite/tests/ghci.debugger/scripts/T26042c.script - + testsuite/tests/ghci.debugger/scripts/T26042c.stdout - + testsuite/tests/ghci.debugger/scripts/T26042d.hs - + testsuite/tests/ghci.debugger/scripts/T26042d.script - + testsuite/tests/ghci.debugger/scripts/T26042d.stdout - + testsuite/tests/ghci.debugger/scripts/T26042e.hs - + testsuite/tests/ghci.debugger/scripts/T26042e.script - + testsuite/tests/ghci.debugger/scripts/T26042e.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f.hs - + testsuite/tests/ghci.debugger/scripts/T26042f.script - + testsuite/tests/ghci.debugger/scripts/T26042f1.stderr - + testsuite/tests/ghci.debugger/scripts/T26042f1.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f2.stdout - + testsuite/tests/ghci.debugger/scripts/T26042g.hs - + testsuite/tests/ghci.debugger/scripts/T26042g.script - + testsuite/tests/ghci.debugger/scripts/T26042g.stdout - testsuite/tests/ghci.debugger/scripts/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c784fa220dcd3f1eca57d8f2e199d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c784fa220dcd3f1eca57d8f2e199d… You're receiving this email because of your account on gitlab.haskell.org.

1 0