Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC Commits: e610933e by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Pass the HUG to readModBreaks, not HscEnv A minor cleanup. The associated history and setupBreakpoint functions are changed accordingly. - - - - - ba684e79 by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Move readModBreaks to GHC.Runtime.Interpreter With some small docs changes - - - - - 2764f1f6 by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Move interpreterProfiled to Interp.Types Moves interpreterProfiled and interpreterDynamic to GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter. - - - - - 8c302392 by Rodrigo Mesquita at 2025-06-30T20:10:58+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. - - - - - affa8dbc by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 819bb93f by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 stg2bc: Derive BcM via ReaderT StateT A small refactor that simplifies GHC.StgToByteCode by deriving-via the Monad instances for BcM. This is done along the lines of previous similar refactors like 72b54c0760bbf85be1f73c1a364d4701e5720465. - - - - - 27 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/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 - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -1899,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/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 ===================================== @@ -4,13 +4,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} -- -- (c) The University of Glasgow 2002-2006 -- -- | GHC.StgToByteCode: Generate bytecode from STG -module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where +module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen ) where import GHC.Prelude @@ -33,6 +34,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 @@ -95,6 +97,10 @@ import GHC.Stg.Syntax import qualified Data.IntSet as IntSet import GHC.CoreToIface +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT(..)) + -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -119,7 +125,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries flattenBind (StgNonRec b e) = [(b,e)] flattenBind (StgRec bs) = bs - (BcM_State{..}, proto_bcos) <- + (proto_bcos, BcM_State{..}) <- runBc hsc_env this_mod mb_modBreaks $ do let flattened_binds = concatMap flattenBind (reverse lifted_binds) FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds @@ -311,7 +317,7 @@ schemeTopBind (id, rhs) -- because mkConAppCode treats nullary constructor applications -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. - -- ioToBc (putStrLn $ "top level BCO") + -- liftIO (putStrLn $ "top level BCO") pure (mkProtoBCO platform add_bco_name (getName id) (toOL [PACK data_con 0, RETURN P]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) @@ -388,7 +394,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 @@ -448,7 +454,7 @@ break_info hsc_env mod current_mod current_mod_breaks | mod == current_mod = pure current_mod_breaks | otherwise - = ioToBc (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case + = liftIO (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case Just hp -> pure $ getModBreaks hp Nothing -> pure Nothing @@ -640,10 +646,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 @@ -2627,63 +2632,38 @@ typeArgReps platform = map (toArgRep platform) . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad +-- | Read only environment for generating ByteCode +data BcM_Env + = BcM_Env + { bcm_hsc_env :: HscEnv + , bcm_module :: Module -- current module (for breakpoints) + } + data BcM_State = BcM_State - { bcm_hsc_env :: HscEnv - , thisModule :: Module -- current module (for breakpoints) - , nextlabel :: Word32 -- for generating local labels - , modBreaks :: Maybe ModBreaks -- info about breakpoints - - , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. - -- Indexed with breakpoint *info* index. - -- See Note [Breakpoint identifiers] - -- in GHC.Types.Breakpoint - , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + { nextlabel :: !Word32 -- ^ For generating local labels + , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + , modBreaks :: Maybe ModBreaks -- info about breakpoints + + , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. + -- Indexed with breakpoint *info* index. + -- See Note [Breakpoint identifiers] + -- in GHC.Types.Breakpoint } -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) - -ioToBc :: IO a -> BcM a -ioToBc io = BcM $ \st -> do - x <- io - return (st, x) - -runBc :: HscEnv -> Module -> Maybe ModBreaks - -> BcM r - -> IO (BcM_State, r) -runBc hsc_env this_mod modBreaks (BcM m) - = m (BcM_State hsc_env this_mod 0 modBreaks IntMap.empty 0) +newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State)) + deriving (Functor, Applicative, Monad, MonadIO) + via (ReaderT BcM_Env (StateT BcM_State IO)) -thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc (BcM expr) cont = BcM $ \st0 -> do - (st1, q) <- expr st0 - let BcM k = cont q - (st2, r) <- k st1 - return (st2, r) - -thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do - (st1, _) <- expr st0 - (st2, r) <- cont st1 - return (st2, r) - -returnBc :: a -> BcM a -returnBc result = BcM $ \st -> (return (st, result)) - -instance Applicative BcM where - pure = returnBc - (<*>) = ap - (*>) = thenBc_ - -instance Monad BcM where - (>>=) = thenBc - (>>) = (*>) +runBc :: HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (r, BcM_State) +runBc hsc_env this_mod mbs (BcM m) + = m (BcM_Env hsc_env this_mod) (BcM_State 0 0 mbs IntMap.empty) instance HasDynFlags BcM where - getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) + getDynFlags = hsc_dflags <$> getHscEnv getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) +getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st) getProfile :: BcM Profile getProfile = targetProfile <$> getDynFlags @@ -2696,31 +2676,31 @@ shouldAddBcoName = do else return Nothing getLabelBc :: BcM LocalLabel -getLabelBc - = BcM $ \st -> do let nl = nextlabel st - when (nl == maxBound) $ - panic "getLabelBc: Ran out of labels" - return (st{nextlabel = nl + 1}, LocalLabel nl) +getLabelBc = BcM $ \_ st -> + do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (LocalLabel nl, st{nextlabel = nl + 1}) getLabelsBc :: Word32 -> BcM [LocalLabel] -getLabelsBc n - = BcM $ \st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1]) +getLabelsBc n = BcM $ \_ st -> + let ctr = nextlabel st + in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) newBreakInfo :: CgBreakInfo -> BcM Int -newBreakInfo info = BcM $ \st -> +newBreakInfo info = BcM $ \_ st -> let ix = breakInfoIdx st st' = st - { breakInfo = IntMap.insert ix info (breakInfo st) - , breakInfoIdx = ix + 1 - } - in return (st', ix) + { breakInfo = IntMap.insert ix info (breakInfo st) + , breakInfoIdx = ix + 1 + } + in return (ix, st') getCurrentModule :: BcM Module -getCurrentModule = BcM $ \st -> return (st, thisModule st) +getCurrentModule = BcM $ \env st -> return (bcm_module env, st) getCurrentModBreaks :: BcM (Maybe ModBreaks) -getCurrentModBreaks = BcM $ \st -> return (st, modBreaks st) +getCurrentModBreaks = BcM $ \_env st -> return (modBreaks st, st) tickFS :: FastString tickFS = fsLit "ticked" ===================================== 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. ===================================== ghc/GHCi/UI.hs ===================================== @@ -4371,7 +4371,7 @@ getIgnoreCount str = setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m() setupBreakpoint loc count = do hsc_env <- GHC.getSession - GHC.setupBreakpoint hsc_env loc count + GHC.setupBreakpoint (hscInterp hsc_env) loc count backCmd :: GhciMonad m => String -> m () backCmd arg View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/461986b7338451fe82ba7dd20b3f12b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/461986b7338451fe82ba7dd20b3f12b... You're receiving this email because of your account on gitlab.haskell.org.