Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC Commits: 5989a722 by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 refactor: "Inspecting the session" moved from GHC Moved utilities for inspecting the session from the GHC module to GHC.Driver.Session.Inspect Purely a clean up - - - - - ff7d68ab by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Pass the HUG to readModBreaks, not HscEnv A minor cleanup. The associated history and setupBreakpoint functions are changed accordingly. - - - - - cc8a6cd8 by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Move readModBreaks to GHC.Runtime.Interpreter With some small docs changes - - - - - 56218cbf by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Move interpreterProfiled to Interp.Types Moves interpreterProfiled and interpreterDynamic to GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter. - - - - - e60ece5d by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Don't import GHC in Debugger.Breakpoints Remove the top-level import GHC from GHC.Runtime.Debugger.Breakpoints This makes the module dependencies more granular and cleans up the qualified imports from the code. - - - - - de60ae45 by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 28 changed files: - compiler/GHC.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - + compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC.hs ===================================== @@ -346,6 +346,7 @@ import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.CmdLine import GHC.Driver.Session +import GHC.Driver.Session.Inspect import GHC.Driver.Backend import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) @@ -378,7 +379,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails) +import GHC.Rename.Names (renamePkgQual, renameRawPkgQual) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -425,14 +426,12 @@ import GHC.Types.Target import GHC.Types.Basic import GHC.Types.TyThing import GHC.Types.Name.Env -import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.Breakpoint import GHC.Types.PkgQual import GHC.Unit import GHC.Unit.Env as UnitEnv -import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModGuts @@ -1570,169 +1569,6 @@ compileCore simplify fn = do cm_safe = safe_mode } --- %************************************************************************ --- %* * --- Inspecting the session --- %* * --- %************************************************************************ - --- | Get the module dependency graph. -getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary -getModuleGraph = liftM hsc_mod_graph getSession - -{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-} --- | Return @True@ \<==> module is loaded. -isLoaded :: GhcMonad m => ModuleName -> m Bool -isLoaded m = withSession $ \hsc_env -> liftIO $ do - hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m - return $! not (null hmis) - --- | Check whether a 'ModuleName' is found in the 'HomePackageTable' --- for the given 'UnitId'. -isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool -isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do - hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m - return $! isJust hmi - --- | Check whether 'Module' is part of the 'HomeUnitGraph'. --- --- Similar to 'isLoadedModule', but for 'Module's. -isLoadedHomeModule :: GhcMonad m => Module -> m Bool -isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do - hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env) - return $! isJust hmi - --- | Return the bindings for the current interactive session. -getBindings :: GhcMonad m => m [TyThing] -getBindings = withSession $ \hsc_env -> - return $ icInScopeTTs $ hsc_IC hsc_env - --- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) -getInsts = withSession $ \hsc_env -> - let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env) - in return (instEnvElts inst_env, fam_env) - -getNamePprCtx :: GhcMonad m => m NamePprCtx -getNamePprCtx = withSession $ \hsc_env -> do - return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) - --- | Container for information about a 'Module'. -data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: [AvailInfo], - minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface, - minf_safe :: SafeHaskellMode, - minf_modBreaks :: Maybe ModBreaks - } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. - - --- | Request information about a loaded 'Module' -getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X -getModuleInfo mdl = withSession $ \hsc_env -> do - if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env) - then liftIO $ getHomeModuleInfo hsc_env mdl - else liftIO $ getPackageModuleInfo hsc_env mdl - -getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl - = do eps <- hscEPS hsc_env - iface <- hscGetModuleInterface hsc_env mdl - let - avails = mi_exports iface - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = avails, - minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface, - minf_modBreaks = Nothing - })) - -availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv -availsToGlobalRdrEnv hsc_env mod avails - = forceGlobalRdrEnv rdr_env - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. - where - rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails) - -- We're building a GlobalRdrEnv as if the user imported - -- all the specified modules into the global interactive module - imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} - decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, - is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual, - is_dloc = srcLocSpan interactiveSrcLoc, - is_level = NormalLevel } - -getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getHomeModuleInfo hsc_env mdl = - HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case - Nothing -> return Nothing - Just hmi -> do - let details = hm_details hmi - iface = hm_iface hmi - return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo. - minf_instances = instEnvElts $ md_insts details, - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface - ,minf_modBreaks = getModBreaks hmi - })) - --- | The list of top-level entities defined in a module -modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings minf = typeEnvElts (minf_type_env minf) - -modInfoExports :: ModuleInfo -> [Name] -modInfoExports minf = concatMap availNames $! minf_exports minf - -modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf - --- | Returns the instances defined by the specified module. --- Warning: currently unimplemented for package modules. -modInfoInstances :: ModuleInfo -> [ClsInst] -modInfoInstances = minf_instances - -modInfoIsExportedName :: ModuleInfo -> Name -> Bool -modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) - -mkNamePprCtxForModule :: - GhcMonad m => - Module -> - ModuleInfo -> - m NamePprCtx -mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) - ptc = initPromotionTickContext (hsc_dflags hsc_env) - return name_ppr_ctx - -modInfoLookupName :: GhcMonad m => - ModuleInfo -> Name - -> m (Maybe TyThing) -- XXX: returns a Maybe X -modInfoLookupName minf name = withSession $ \hsc_env -> do - case lookupTypeEnv (minf_type_env minf) name of - Just tyThing -> return (Just tyThing) - Nothing -> liftIO (lookupType hsc_env name) - -modInfoIface :: ModuleInfo -> Maybe ModIface -modInfoIface = minf_iface - --- | Retrieve module safe haskell mode -modInfoSafe :: ModuleInfo -> SafeHaskellMode -modInfoSafe = minf_safe - -modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks -modInfoModBreaks = minf_modBreaks - isDictonaryId :: Id -> Bool isDictonaryId id = isDictTy (idType id) @@ -2063,7 +1899,7 @@ getGHCiMonad :: GhcMonad m => m Name getGHCiMonad = fmap (ic_monad . hsc_IC) getSession getHistorySpan :: GhcMonad m => History -> m SrcSpan -getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan hsc_env h +getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan (hsc_HUG hsc_env) h obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term obtainTermFromVal bound force ty a = withSession $ \hsc_env -> ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -287,7 +287,7 @@ exprs_fvs :: [CoreExpr] -> FV exprs_fvs exprs = mapUnionFV expr_fvs exprs tickish_fvs :: CoreTickish -> FV -tickish_fvs (Breakpoint _ _ ids _) = FV.mkFVs ids +tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV {- ********************************************************************** @@ -759,8 +759,8 @@ freeVars = go , AnnTick tickish expr2 ) where expr2 = go expr - tickishFVs (Breakpoint _ _ ids _) = mkDVarSet ids - tickishFVs _ = emptyDVarSet + tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -897,8 +897,8 @@ lintCoreExpr (Cast expr co) lintCoreExpr (Tick tickish expr) = do { case tickish of - Breakpoint _ _ ids _ -> forM_ ids $ \id -> lintIdOcc id 0 - _ -> return () + Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0 + _ -> return () ; markAllJoinsBadIf block_joins $ lintCoreExpr expr } where block_joins = not (tickish `tickishScopesLike` SoftScope) ===================================== compiler/GHC/Core/Map/Expr.hs ===================================== @@ -198,11 +198,10 @@ eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where - go (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod) + go (Breakpoint lext lid lids) (Breakpoint rext rid rids) = lid == rid && D env1 lids == D env2 rids && lext == rext - && lmod == rmod go l r = l == r -- Compares for equality, modulo alpha ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2501,7 +2501,7 @@ occAnal env (Tick tickish body) -- For a non-soft tick scope, we can inline lambdas only, so we -- abandon tail calls, and do markAllInsideLam too: usage_lam - | Breakpoint _ _ ids _ <- tickish + | Breakpoint _ _ ids <- tickish = -- Never substitute for any of the Ids in a Breakpoint addManyOccs usage_lam (mkVarSet ids) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1461,8 +1461,8 @@ simplTick env tickish expr cont simplTickish env tickish - | Breakpoint ext n ids modl <- tickish - = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids) modl + | Breakpoint ext bid ids <- tickish + = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids) | otherwise = tickish -- Push type application and coercion inside a tick ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Prelude import GHC.Core import GHC.Core.Stats (exprStats) +import GHC.Types.Breakpoint import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Literal( pprLiteral ) import GHC.Types.Name( pprInfixName, pprPrefixName ) @@ -694,10 +695,10 @@ instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where ppr modl, comma, ppr ix, text ">"] - ppr (Breakpoint _ext ix vars modl) = + ppr (Breakpoint _ext bid vars) = hcat [text "break<", - ppr modl, comma, - ppr ix, + ppr (bi_tick_mod bid), comma, + ppr (bi_tick_index bid), text ">", parens (hcat (punctuate comma (map ppr vars)))] ppr (ProfNote { profNoteCC = cc, ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -602,8 +602,8 @@ substDVarSet subst@(Subst _ _ tv_env cv_env) fvs ------------------ -- | Drop free vars from the breakpoint if they have a non-variable substitution. substTickish :: Subst -> CoreTickish -> CoreTickish -substTickish subst (Breakpoint ext n ids modl) - = Breakpoint ext n (mapMaybe do_one ids) modl +substTickish subst (Breakpoint ext bid ids) + = Breakpoint ext bid (mapMaybe do_one ids) where do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst ===================================== compiler/GHC/Core/Tidy.hs ===================================== @@ -235,8 +235,8 @@ tidyAlt env (Alt con vs rhs) ------------ Tickish -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish -tidyTickish env (Breakpoint ext ix ids modl) - = Breakpoint ext ix (map (tidyVarOcc env) ids) modl +tidyTickish env (Breakpoint ext bid ids) + = Breakpoint ext bid (map (tidyVarOcc env) ids) tidyTickish _ other_tickish = other_tickish ------------ Rules -------------- ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -2492,11 +2492,10 @@ cheapEqExpr' ignoreTick e1 e2 -- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool -eqTickish env (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod) +eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids && - lext == rext && - lmod == rmod + lext == rext eqTickish _ l r = l == r -- | Finds differences between core bindings, see @diffExpr@. ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -586,8 +586,8 @@ toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push toIfaceTickish (HpcTick modl ix) = IfaceHpcTick modl ix toIfaceTickish (SourceNote src (LexicalFastString names)) = IfaceSource src names -toIfaceTickish (Breakpoint _ ix fv m) = - IfaceBreakpoint ix (toIfaceVar <$> fv) m +toIfaceTickish (Breakpoint _ ix fv) = + IfaceBreakpoint ix (toIfaceVar <$> fv) --------------------- toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -643,10 +643,10 @@ coreToStgArgs (arg : args) = do -- Non-type argument coreToStgTick :: Type -- type of the ticked expression -> CoreTickish -> StgTickish -coreToStgTick _ty (HpcTick m i) = HpcTick m i -coreToStgTick _ty (SourceNote span nm) = SourceNote span nm -coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope -coreToStgTick !ty (Breakpoint _ bid fvs modl) = Breakpoint ty bid fvs modl +coreToStgTick _ty (HpcTick m i) = HpcTick m i +coreToStgTick _ty (SourceNote span nm) = SourceNote span nm +coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope +coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs -- --------------------------------------------------------------------------- -- The magic for lets: ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -842,9 +842,9 @@ cpeRhsE env (Tick tickish expr) = do { body <- cpeBodyNF env expr ; return (emptyFloats, mkTick tickish' body) } where - tickish' | Breakpoint ext n fvs modl <- tickish + tickish' | Breakpoint ext bid fvs <- tickish -- See also 'substTickish' - = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) modl + = Breakpoint ext bid (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) | otherwise = tickish ===================================== compiler/GHC/Driver/Session/Inspect.hs ===================================== @@ -0,0 +1,201 @@ +{-# LANGUAGE LambdaCase #-} + +-- | GHC API utilities for inspecting the GHC session +module GHC.Driver.Session.Inspect where + +import GHC.Prelude +import GHC.Data.Maybe +import Control.Monad + +import GHC.ByteCode.Types +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +import GHC.Driver.Env +import GHC.Driver.Main +import GHC.Driver.Monad +import GHC.Driver.Session +import GHC.Rename.Names +import GHC.Runtime.Context +import GHC.Runtime.Interpreter +import GHC.Types.Avail +import GHC.Types.Name +import GHC.Types.Name.Ppr +import GHC.Types.Name.Reader +import GHC.Types.Name.Set +import GHC.Types.PkgQual +import GHC.Types.SafeHaskell +import GHC.Types.SrcLoc +import GHC.Types.TyThing +import GHC.Types.TypeEnv +import GHC.Unit.External +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Utils.Misc +import GHC.Utils.Outputable +import qualified GHC.Unit.Home.Graph as HUG + +-- %************************************************************************ +-- %* * +-- Inspecting the session +-- %* * +-- %************************************************************************ + +-- | Get the module dependency graph. +getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary +getModuleGraph = liftM hsc_mod_graph getSession + +{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-} +-- | Return @True@ \<==> module is loaded. +isLoaded :: GhcMonad m => ModuleName -> m Bool +isLoaded m = withSession $ \hsc_env -> liftIO $ do + hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m + return $! not (null hmis) + +-- | Check whether a 'ModuleName' is found in the 'HomePackageTable' +-- for the given 'UnitId'. +isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool +isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do + hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m + return $! isJust hmi + +-- | Check whether 'Module' is part of the 'HomeUnitGraph'. +-- +-- Similar to 'isLoadedModule', but for 'Module's. +isLoadedHomeModule :: GhcMonad m => Module -> m Bool +isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do + hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env) + return $! isJust hmi + +-- | Return the bindings for the current interactive session. +getBindings :: GhcMonad m => m [TyThing] +getBindings = withSession $ \hsc_env -> + return $ icInScopeTTs $ hsc_IC hsc_env + +-- | Return the instances for the current interactive session. +getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) +getInsts = withSession $ \hsc_env -> + let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env) + in return (instEnvElts inst_env, fam_env) + +getNamePprCtx :: GhcMonad m => m NamePprCtx +getNamePprCtx = withSession $ \hsc_env -> do + return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_type_env :: TypeEnv, + minf_exports :: [AvailInfo], + minf_instances :: [ClsInst], + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode, + minf_modBreaks :: Maybe ModBreaks + } + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X +getModuleInfo mdl = withSession $ \hsc_env -> do + if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env) + then liftIO $ getHomeModuleInfo hsc_env mdl + else liftIO $ getPackageModuleInfo hsc_env mdl + +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getPackageModuleInfo hsc_env mdl + = do eps <- hscEPS hsc_env + iface <- hscGetModuleInterface hsc_env mdl + let + avails = mi_exports iface + pte = eps_PTE eps + tys = [ ty | name <- concatMap availNames avails, + Just ty <- [lookupTypeEnv pte name] ] + + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = avails, + minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = Nothing + })) + +availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv +availsToGlobalRdrEnv hsc_env mod avails + = forceGlobalRdrEnv rdr_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + where + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails) + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} + decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, + is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual, + is_dloc = srcLocSpan interactiveSrcLoc, + is_level = NormalLevel } + +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getHomeModuleInfo hsc_env mdl = + HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case + Nothing -> return Nothing + Just hmi -> do + let details = hm_details hmi + iface = hm_iface hmi + return (Just (ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo. + minf_instances = instEnvElts $ md_insts details, + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = getModBreaks hmi + })) + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (minf_type_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = concatMap availNames $! minf_exports minf + +modInfoExportsWithSelectors :: ModuleInfo -> [Name] +modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf + +-- | Returns the instances defined by the specified module. +-- Warning: currently unimplemented for package modules. +modInfoInstances :: ModuleInfo -> [ClsInst] +modInfoInstances = minf_instances + +modInfoIsExportedName :: ModuleInfo -> Name -> Bool +modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) + +mkNamePprCtxForModule :: + GhcMonad m => + Module -> + ModuleInfo -> + m NamePprCtx +mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) + ptc = initPromotionTickContext (hsc_dflags hsc_env) + return name_ppr_ctx + +modInfoLookupName :: GhcMonad m => + ModuleInfo -> Name + -> m (Maybe TyThing) -- XXX: returns a Maybe X +modInfoLookupName minf name = withSession $ \hsc_env -> do + case lookupTypeEnv (minf_type_env minf) name of + Just tyThing -> return (Just tyThing) + Nothing -> liftIO (lookupType hsc_env name) + +modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface = minf_iface + +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + +modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks +modInfoModBreaks = minf_modBreaks + ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Types.Breakpoint import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Id @@ -1235,7 +1236,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do Breakpoints -> do i <- addMixEntry me - pure (Breakpoint noExtField i ids (this_mod env)) + pure (Breakpoint noExtField (BreakpointId (this_mod env) i) ids) SourceNotes | RealSrcSpan pos' _ <- pos -> return $ SourceNote pos' $ LexicalFastString cc_name ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -56,6 +56,7 @@ import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue) import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey, constraintKindTyConKey ) +import GHC.Types.Breakpoint import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type import GHC.Iface.Recomp.Binary @@ -699,7 +700,7 @@ data IfaceTickish = IfaceHpcTick Module Int -- from HpcTick x | IfaceSCC CostCentre Bool Bool -- from ProfNote | IfaceSource RealSrcSpan FastString -- from SourceNote - | IfaceBreakpoint Int [IfaceExpr] Module -- from Breakpoint + | IfaceBreakpoint BreakpointId [IfaceExpr] -- from Breakpoint data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr -- Note: IfLclName, not IfaceBndr (and same with the case binder) @@ -1848,7 +1849,7 @@ pprIfaceTickish (IfaceSCC cc tick scope) = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) pprIfaceTickish (IfaceSource src _names) = braces (pprUserRealSpan True src) -pprIfaceTickish (IfaceBreakpoint m ix fvs) +pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs) = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs) ------------------ @@ -2198,7 +2199,7 @@ freeNamesIfaceTyConParent (IfDataInstance ax tc tys) = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys freeNamesIfTickish :: IfaceTickish -> NameSet -freeNamesIfTickish (IfaceBreakpoint _ fvs _) = +freeNamesIfTickish (IfaceBreakpoint _ fvs) = fnList freeNamesIfExpr fvs freeNamesIfTickish _ = emptyNameSet @@ -2919,7 +2920,7 @@ instance Binary IfaceTickish where put_ bh (srcSpanEndLine src) put_ bh (srcSpanEndCol src) put_ bh name - put_ bh (IfaceBreakpoint m ix fvs) = do + put_ bh (IfaceBreakpoint (BreakpointId m ix) fvs) = do putByte bh 3 put_ bh m put_ bh ix @@ -2947,7 +2948,7 @@ instance Binary IfaceTickish where 3 -> do m <- get bh ix <- get bh fvs <- get bh - return (IfaceBreakpoint m ix fvs) + return (IfaceBreakpoint (BreakpointId m ix) fvs) _ -> panic ("get IfaceTickish " ++ show h) instance Binary IfaceConAlt where @@ -3206,7 +3207,7 @@ instance NFData IfaceTickish where IfaceHpcTick m i -> rnf m `seq` rnf i IfaceSCC cc b1 b2 -> rnf cc `seq` rnf b1 `seq` rnf b2 IfaceSource src str -> rnf src `seq` rnf str - IfaceBreakpoint m i fvs -> rnf m `seq` rnf i `seq` rnf fvs + IfaceBreakpoint i fvs -> rnf i `seq` rnf fvs instance NFData IfaceConAlt where rnf = \case ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -955,7 +955,7 @@ dffvExpr :: CoreExpr -> DFFV () dffvExpr (Var v) = insert v dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ _ ids _) e) = mapM_ insert ids >> dffvExpr e +dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e dffvExpr (Tick _other e) = dffvExpr e dffvExpr (Cast e _) = dffvExpr e dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1732,9 +1732,9 @@ tcIfaceTickish :: IfaceTickish -> IfL CoreTickish tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) tcIfaceTickish (IfaceSource src name) = return (SourceNote src (LexicalFastString name)) -tcIfaceTickish (IfaceBreakpoint ix fvs modl) = do +tcIfaceTickish (IfaceBreakpoint bid fvs) = do fvs' <- mapM tcIfaceExpr fvs - return (Breakpoint NoExtField ix [f | Var f <- fvs'] modl) + return (Breakpoint NoExtField bid [f | Var f <- fvs']) ------------------------- tcIfaceLit :: Literal -> IfL Literal ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -1,9 +1,12 @@ + -- | GHC API debugger module for finding and setting breakpoints. -- -- This module is user facing and is at least used by `GHCi` and `ghc-debugger` -- to find and set breakpoints. module GHC.Runtime.Debugger.Breakpoints where +import GHC.Prelude + import Control.Monad.Catch import Control.Monad import Data.Array @@ -13,10 +16,18 @@ import Data.Maybe import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as S -import GHC -import GHC.Prelude +import GHC.ByteCode.Types (BreakIndex, ModBreaks(..)) +import GHC.Driver.Env +import GHC.Driver.Monad +import GHC.Driver.Session.Inspect +import GHC.Runtime.Eval import GHC.Runtime.Eval.Utils +import GHC.Types.Name import GHC.Types.SrcLoc +import GHC.Types.Breakpoint +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary import GHC.Utils.Outputable import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict @@ -44,10 +55,10 @@ findBreakByLine line arr ticks = arr ! line starts_here = [ (ix,pan) | (ix, pan) <- ticks, - GHC.srcSpanStartLine pan == line ] + srcSpanStartLine pan == line ] (comp, incomp) = partition ends_here starts_here - where ends_here (_,pan) = GHC.srcSpanEndLine pan == line + where ends_here (_,pan) = srcSpanEndLine pan == line -- | Find a breakpoint in the 'TickArray' of a module, given a line number and a column coordinate. findBreakByCoord :: (Int, Int) -> TickArray -> Maybe (BreakIndex, RealSrcSpan) @@ -63,8 +74,8 @@ findBreakByCoord (line, col) arr contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col) ] after_here = [ tick | tick@(_,pan) <- ticks, - GHC.srcSpanStartLine pan == line, - GHC.srcSpanStartCol pan >= col ] + srcSpanStartLine pan == line, + srcSpanStartCol pan >= col ] leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd @@ -112,7 +123,7 @@ resolveFunctionBreakpoint inp = do Nothing -> do -- No errors found, go and return the module info let mod = fromMaybe (panic "resolveFunctionBreakpoint") mb_mod - mb_mod_info <- GHC.getModuleInfo mod + mb_mod_info <- getModuleInfo mod case mb_mod_info of Nothing -> pure . Left $ text "Could not find ModuleInfo of " <> ppr mod @@ -120,16 +131,16 @@ resolveFunctionBreakpoint inp = do where -- Try to lookup the module for an identifier that is in scope. -- `parseName` throws an exception, if the identifier is not in scope - lookupModuleInscope :: GHC.GhcMonad m => String -> m (Maybe Module) + lookupModuleInscope :: GhcMonad m => String -> m (Maybe Module) lookupModuleInscope mod_top_lvl = do - names <- GHC.parseName mod_top_lvl - pure $ Just $ NE.head $ GHC.nameModule <$> names + names <- parseName mod_top_lvl + pure $ Just $ NE.head $ nameModule <$> names -- Lookup the Module of a module name in the module graph - lookupModuleInGraph :: GHC.GhcMonad m => String -> m (Maybe Module) + lookupModuleInGraph :: GhcMonad m => String -> m (Maybe Module) lookupModuleInGraph mod_str = do - graph <- GHC.getModuleGraph - let hmods = ms_mod <$> GHC.mgModSummaries graph + graph <- getModuleGraph + let hmods = ms_mod <$> mgModSummaries graph pure $ find ((== mod_str) . moduleNameString . moduleName) hmods -- Check validity of an identifier to set a breakpoint: @@ -137,21 +148,21 @@ resolveFunctionBreakpoint inp = do -- 2. the identifier must be in an interpreted module -- 3. the ModBreaks array for module `mod` must have an entry -- for the function - validateBP :: GHC.GhcMonad m => String -> String -> Maybe Module + validateBP :: GhcMonad m => String -> String -> Maybe Module -> m (Maybe SDoc) validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text (combineModIdent mod_str (takeWhile (/= '.') fun_str))) <+> text "not in scope" validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing" validateBP _ fun_str (Just modl) = do - isInterpr <- GHC.moduleIsInterpreted modl + isInterpr <- moduleIsInterpreted modl mb_err_msg <- case isInterpr of False -> pure $ Just $ text "Module" <+> quotes (ppr modl) <+> text "is not interpreted" True -> do mb_modbreaks <- getModBreak modl let found = case mb_modbreaks of Nothing -> False - Just mb -> fun_str `elem` (intercalate "." <$> elems (GHC.modBreaks_decls mb)) + Just mb -> fun_str `elem` (intercalate "." <$> elems (modBreaks_decls mb)) if found then pure Nothing else pure $ Just $ text "No breakpoint found for" <+> quotes (text fun_str) @@ -163,13 +174,13 @@ resolveFunctionBreakpoint inp = do -- for -- (a) this binder only (it maybe a top-level or a nested declaration) -- (b) that do not have an enclosing breakpoint -findBreakForBind :: String {-^ Name of bind to break at -} -> GHC.ModBreaks -> [(BreakIndex, RealSrcSpan)] +findBreakForBind :: String {-^ Name of bind to break at -} -> ModBreaks -> [(BreakIndex, RealSrcSpan)] findBreakForBind str_name modbreaks = filter (not . enclosed) ticks where ticks = [ (index, span) - | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks), + | (index, decls) <- assocs (modBreaks_decls modbreaks), str_name == intercalate "." decls, - RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ] + RealSrcSpan span _ <- [modBreaks_locs modbreaks ! index] ] enclosed (_,sp0) = any subspan ticks where subspan (_,sp) = sp /= sp0 && realSrcSpanStart sp <= realSrcSpanStart sp0 && @@ -180,53 +191,53 @@ findBreakForBind str_name modbreaks = filter (not . enclosed) ticks -------------------------------------------------------------------------------- -- | Maps line numbers to the breakpoint ticks existing at that line for a module. -type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)] +type TickArray = Array Int [(BreakIndex,RealSrcSpan)] -- | Construct the 'TickArray' for the given module. makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray) makeModuleLineMap m = do - mi <- GHC.getModuleInfo m - return $ mkTickArray . assocs . GHC.modBreaks_locs <$> (GHC.modInfoModBreaks =<< mi) + mi <- getModuleInfo m + return $ mkTickArray . assocs . modBreaks_locs <$> (modInfoModBreaks =<< mi) where mkTickArray :: [(BreakIndex, SrcSpan)] -> TickArray mkTickArray ticks = accumArray (flip (:)) [] (1, max_line) [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ] where - max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ] - srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ] + max_line = foldr max 0 [ srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ] + srcSpanLines pan = [ srcSpanStartLine pan .. srcSpanEndLine pan ] -- | Get the 'ModBreaks' of the given 'Module' when available -getModBreak :: GHC.GhcMonad m - => Module -> m (Maybe ModBreaks) +getModBreak :: GhcMonad m => Module -> m (Maybe ModBreaks) getModBreak m = do - mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m - pure $ GHC.modInfoModBreaks mod_info + mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m + pure $ modInfoModBreaks mod_info -------------------------------------------------------------------------------- -- Getting current breakpoint information -------------------------------------------------------------------------------- -getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan) +getCurrentBreakSpan :: GhcMonad m => m (Maybe SrcSpan) getCurrentBreakSpan = do - resumes <- GHC.getResumeContext + hug <- hsc_HUG <$> getSession + resumes <- getResumeContext case resumes of [] -> return Nothing (r:_) -> do - let ix = GHC.resumeHistoryIx r + let ix = resumeHistoryIx r if ix == 0 - then return (Just (GHC.resumeSpan r)) + then return (Just (resumeSpan r)) else do - let hist = GHC.resumeHistory r !! (ix-1) - pan <- GHC.getHistorySpan hist + let hist = resumeHistory r !! (ix-1) + pan <- liftIO $ getHistorySpan hug hist return (Just pan) -getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module) +getCurrentBreakModule :: GhcMonad m => m (Maybe Module) getCurrentBreakModule = do - resumes <- GHC.getResumeContext + resumes <- getResumeContext return $ case resumes of [] -> Nothing - (r:_) -> case GHC.resumeHistoryIx r of - 0 -> ibi_tick_mod <$> GHC.resumeBreakpointId r - ix -> Just $ GHC.getHistoryModule $ GHC.resumeHistory r !! (ix-1) + (r:_) -> case resumeHistoryIx r of + 0 -> ibi_tick_mod <$> resumeBreakpointId r + ix -> Just $ getHistoryModule $ resumeHistory r !! (ix-1) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -144,25 +144,25 @@ import qualified GHC.Unit.Home.Graph as HUG getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) -mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> IO History -mkHistory hsc_env hval ibi = History hval ibi <$> findEnclosingDecls hsc_env ibi +mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History +mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi getHistoryModule :: History -> Module getHistoryModule = ibi_tick_mod . historyBreakpointId -getHistorySpan :: HscEnv -> History -> IO SrcSpan -getHistorySpan hsc_env hist = do +getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan +getHistorySpan hug hist = do let ibi = historyBreakpointId hist - brks <- readModBreaks hsc_env (ibi_tick_mod ibi) + brks <- readModBreaks hug (ibi_tick_mod ibi) return $ modBreaks_locs brks ! ibi_tick_index ibi {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. -findEnclosingDecls :: HscEnv -> InternalBreakpointId -> IO [String] -findEnclosingDecls hsc_env ibi = do - brks <- readModBreaks hsc_env (ibi_tick_mod ibi) +findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String] +findEnclosingDecls hug ibi = do + brks <- readModBreaks hug (ibi_tick_mod ibi) return $ modBreaks_decls brks ! ibi_tick_index ibi -- | Update fixity environment in the current interactive context. @@ -349,7 +349,8 @@ handleRunStatus step expr bindings final_ids status history0 = do -- - or one of the stepping options in @EvalOpts@ caused us to stop at one EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do let ibi = evalBreakpointToId eval_break - tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi) + let hug = hsc_HUG hsc_env + tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi) let span = modBreaks_locs tick_brks ! ibi_tick_index ibi decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi @@ -390,7 +391,7 @@ handleRunStatus step expr bindings final_ids status history0 = do let eval_opts = initEvalOpts dflags (enableGhcStepMode step) status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv history <- if not tracing then pure history0 else do - history1 <- liftIO $ mkHistory hsc_env apStack_fhv ibi + history1 <- liftIO $ mkHistory hug apStack_fhv ibi let !history' = history1 `consBL` history0 -- history is strict, otherwise our BoundedList is pointless. return history' @@ -443,27 +444,27 @@ resumeExec step mbCnt -- When the user specified a break ignore count, set it -- in the interpreter case (mb_brkpt, mbCnt) of - (Just brkpt, Just cnt) -> setupBreakpoint hsc_env (toBreakpointId brkpt) cnt + (Just brkpt, Just cnt) -> setupBreakpoint interp (toBreakpointId brkpt) cnt _ -> return () let eval_opts = initEvalOpts dflags (enableGhcStepMode step) status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist + hug = hsc_HUG hsc_env hist' = case mb_brkpt of Nothing -> pure prevHistoryLst Just bi | breakHere False step span -> do - hist1 <- liftIO (mkHistory hsc_env apStack bi) + hist1 <- liftIO (mkHistory hug apStack bi) return $ hist1 `consBL` fromListBL 50 hist | otherwise -> pure prevHistoryLst handleRunStatus step expr bindings final_ids status =<< hist' -setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157 -setupBreakpoint hsc_env bi cnt = do - let modl = bi_tick_mod bi - modBreaks <- liftIO $ readModBreaks hsc_env modl +setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m () -- #19157 +setupBreakpoint interp bi cnt = do + hug <- hsc_HUG <$> getSession + modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi) let breakarray = modBreaks_flags modBreaks - interp = hscInterp hsc_env _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt pure () @@ -494,7 +495,7 @@ moveHist fn = do span <- case mb_info of Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>") Just ibi -> liftIO $ do - brks <- readModBreaks hsc_env (ibi_tick_mod ibi) + brks <- readModBreaks (hsc_HUG hsc_env) (ibi_tick_mod ibi) return $ modBreaks_locs brks ! ibi_tick_index ibi (hsc_env1, names) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info @@ -525,11 +526,6 @@ moveHist fn = do result_fs :: FastString result_fs = fsLit "_result" --- | Read the 'ModBreaks' of the given home 'Module' from the 'HomeUnitGraph'. -readModBreaks :: HscEnv -> Module -> IO ModBreaks -readModBreaks hsc_env mod = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule mod (hsc_HUG hsc_env) - - bindLocalsAtBreakpoint :: HscEnv -> ForeignHValue @@ -560,8 +556,9 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do - info_brks <- readModBreaks hsc_env (ibi_info_mod ibi) - tick_brks <- readModBreaks hsc_env (ibi_tick_mod ibi) + let hug = hsc_HUG hsc_env + info_brks <- readModBreaks hug (ibi_info_mod ibi) + tick_brks <- readModBreaks hug (ibi_tick_mod ibi) let info = expectJust $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks) interp = hscInterp hsc_env occs = modBreaks_vars tick_brks ! ibi_tick_index ibi ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -27,10 +27,9 @@ module GHC.Runtime.Interpreter , getClosure , whereFrom , getModBreaks + , readModBreaks , seqHValue , evalBreakpointToId - , interpreterDynamic - , interpreterProfiled -- * The object-code linker , initObjLinker @@ -98,7 +97,6 @@ import GHC.Unit.Env #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run -import GHC.Platform.Ways #endif import Control.Concurrent @@ -117,6 +115,7 @@ import qualified GHC.InfoProv as InfoProv import GHC.Builtin.Names import GHC.Types.Name +import qualified GHC.Unit.Home.Graph as HUG -- Standard libraries import GHC.Exts @@ -732,13 +731,12 @@ wormholeRef interp _r = case interpInstance interp of ExternalInterp {} -> throwIO (InstallationError "this operation requires -fno-external-interpreter") --- ----------------------------------------------------------------------------- --- Misc utils - -fromEvalResult :: EvalResult a -> IO a -fromEvalResult (EvalException e) = throwIO (fromSerializableException e) -fromEvalResult (EvalSuccess a) = return a +-------------------------------------------------------------------------------- +-- * Finding breakpoint information +-------------------------------------------------------------------------------- +-- | Get the breakpoint information from the ByteCode object associated to this +-- 'HomeModInfo'. getModBreaks :: HomeModInfo -> Maybe ModBreaks getModBreaks hmi | Just linkable <- homeModInfoByteCode hmi, @@ -748,24 +746,15 @@ getModBreaks hmi | otherwise = Nothing -- probably object code --- | Interpreter uses Profiling way -interpreterProfiled :: Interp -> Bool -interpreterProfiled interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> hostIsProfiled -#endif - ExternalInterp ext -> case ext of - ExtIServ i -> iservConfProfiled (interpConfig i) - ExtJS {} -> False -- we don't support profiling yet in the JS backend - ExtWasm i -> wasmInterpProfiled $ interpConfig i - --- | Interpreter uses Dynamic way -interpreterDynamic :: Interp -> Bool -interpreterDynamic interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> hostIsDynamic -#endif - ExternalInterp ext -> case ext of - ExtIServ i -> iservConfDynamic (interpConfig i) - ExtJS {} -> False -- dynamic doesn't make sense for JS - ExtWasm {} -> True -- wasm dyld can only load dynamic code +-- | Read the 'InternalModBreaks' and 'ModBreaks' of the given home 'Module' +-- from the 'HomeUnitGraph'. +readModBreaks :: HomeUnitGraph -> Module -> IO ModBreaks +readModBreaks hug modl = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule modl hug + +-- ----------------------------------------------------------------------------- +-- Misc utils + +fromEvalResult :: EvalResult a -> IO a +fromEvalResult (EvalException e) = throwIO (fromSerializableException e) +fromEvalResult (EvalSuccess a) = return a + ===================================== compiler/GHC/Runtime/Interpreter/Types.hs ===================================== @@ -24,7 +24,8 @@ module GHC.Runtime.Interpreter.Types , interpSymbolSuffix , eliminateInterpSymbol , interpretedInterpSymbol - + , interpreterProfiled + , interpreterDynamic -- * IServ , IServ @@ -48,6 +49,9 @@ import GHCi.RemoteTypes import GHCi.Message ( Pipe ) import GHC.Platform +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHC.Platform.Ways +#endif import GHC.Utils.TmpFs import GHC.Utils.Logger import GHC.Unit.Env @@ -136,6 +140,28 @@ data ExtInterpInstance c = ExtInterpInstance -- ^ Instance specific extra fields } +-- | Interpreter uses Profiling way +interpreterProfiled :: Interp -> Bool +interpreterProfiled interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsProfiled +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfProfiled (interpConfig i) + ExtJS {} -> False -- we don't support profiling yet in the JS backend + ExtWasm i -> wasmInterpProfiled $ interpConfig i + +-- | Interpreter uses Dynamic way +interpreterDynamic :: Interp -> Bool +interpreterDynamic interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsDynamic +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfDynamic (interpConfig i) + ExtJS {} -> False -- dynamic doesn't make sense for JS + ExtWasm {} -> True -- wasm dyld can only load dynamic code + ------------------------ -- JS Stuff ------------------------ ===================================== compiler/GHC/Stg/BcPrep.hs ===================================== @@ -49,7 +49,7 @@ bcPrepRHS con@StgRhsCon{} = pure con bcPrepExpr :: StgExpr -> BcPrepM StgExpr -- explicitly match all constructors so we get a warning if we miss any -bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _ _) rhs) +bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs) | isLiftedTypeKind (typeKind tick_ty) = do id <- newId tick_ty rhs' <- bcPrepExpr rhs ===================================== compiler/GHC/Stg/FVs.hs ===================================== @@ -257,8 +257,8 @@ exprFVs env = go , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs = (StgTick tick e', imp_fvs, top_fvs, lcl_fvs') where - tickish (Breakpoint _ _ ids _) = mkDVarSet ids - tickish _ = emptyDVarSet + tickish (Breakpoint _ _ ids) = mkDVarSet ids + tickish _ = emptyDVarSet go_bind dc bind body = (dc bind' body', imp_fvs, top_fvs, lcl_fvs) where ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Platform.Profile import GHC.Runtime.Interpreter import GHCi.FFI import GHC.Types.Basic +import GHC.Types.Breakpoint import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Id @@ -388,7 +389,7 @@ schemeR_wrk fvs nm original_body (args, body) -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do +schemeER_wrk d p (StgTick (Breakpoint tick_ty (BreakpointId tick_mod tick_no) fvs) rhs) = do code <- schemeE d 0 p rhs hsc_env <- getHscEnv current_mod <- getCurrentModule @@ -640,10 +641,9 @@ schemeE d s p (StgLet _ext binds body) = do thunk_codes <- sequence compile_binds return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) -schemeE _d _s _p (StgTick (Breakpoint _ bp_id _ _) _rhs) - = panic ("schemeE: Breakpoint without let binding: " ++ - show bp_id ++ - " forgot to run bcPrep?") +schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) + = pprPanic "schemeE: Breakpoint without let binding: " $ + ppr bp_id <> text " forgot to run bcPrep?" -- ignore other kinds of tick schemeE d s p (StgTick _ rhs) = schemeE d s p rhs ===================================== compiler/GHC/Types/Breakpoint.hs ===================================== @@ -8,6 +8,9 @@ where import GHC.Prelude import GHC.Unit.Module +import GHC.Utils.Outputable +import Control.DeepSeq +import Data.Data (Data) -- | Breakpoint identifier. -- @@ -16,7 +19,7 @@ data BreakpointId = BreakpointId { bi_tick_mod :: !Module -- ^ Breakpoint tick module , bi_tick_index :: !Int -- ^ Breakpoint tick index } - deriving (Eq, Ord) + deriving (Eq, Ord, Data) -- | Internal breakpoint identifier -- @@ -53,3 +56,11 @@ toBreakpointId ibi = BreakpointId -- So every breakpoint occurrence gets assigned a module-unique *info index* and -- we store it alongside the occurrence module (*info module*) in the -- InternalBreakpointId datatype. + +instance Outputable BreakpointId where + ppr BreakpointId{bi_tick_mod, bi_tick_index} = + text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index + +instance NFData BreakpointId where + rnf BreakpointId{bi_tick_mod, bi_tick_index} = + rnf bi_tick_mod `seq` rnf bi_tick_index ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Core.Type import GHC.Unit.Module +import GHC.Types.Breakpoint import GHC.Types.CostCentre import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) import GHC.Types.Var @@ -128,7 +129,7 @@ data GenTickish pass = -- and (b) substituting (don't substitute for them) | Breakpoint { breakpointExt :: XBreakpoint pass - , breakpointId :: !Int + , breakpointId :: !BreakpointId , breakpointFVs :: [XTickishId pass] -- ^ the order of this list is important: -- it matches the order of the lists in the @@ -136,7 +137,6 @@ data GenTickish pass = -- -- Careful about substitution! See -- Note [substTickish] in "GHC.Core.Subst". - , breakpointModule :: Module } -- | A source note. ===================================== compiler/ghc.cabal.in ===================================== @@ -548,6 +548,7 @@ Library GHC.Driver.Plugins.External GHC.Driver.Ppr GHC.Driver.Session + GHC.Driver.Session.Inspect GHC.Driver.Session.Units GHC.Hs GHC.Hs.Basic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/674a1380fa8dcc4715be6a028880cbf... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/674a1380fa8dcc4715be6a028880cbf... You're receiving this email because of your account on gitlab.haskell.org.