[Git][ghc/ghc][master] GHCi: support inlining breakpoints (#24712)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu May 2 19:42:37 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b85b1199 by Sylvain Henry at 2024-05-02T15:41:49-04:00
GHCi: support inlining breakpoints (#24712)
When a breakpoint is inlined, its context may change (e.g. tyvars in
scope). We must take this into account and not used the breakpoint tick
index as its sole identifier. Each instance of a breakpoint (even with
the same tick index) now gets a different "info" index.
We also need to distinguish modules:
- tick module: module with the break array (tick counters, status, etc.)
- info module: module having the CgBreakInfo (info at occurrence site)
- - - - -
20 changed files:
- compiler/GHC.hs
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Eval/Types.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- − compiler/GHC/Types/BreakInfo.hs
- + compiler/GHC/Types/Breakpoint.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Exception.cmm
- rts/Interpreter.c
- + testsuite/tests/ghci.debugger/scripts/T24712.hs
- + testsuite/tests/ghci.debugger/scripts/T24712.script
- + testsuite/tests/ghci.debugger/scripts/T24712.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
- testsuite/tests/ghci.debugger/scripts/break021.stdout
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -157,14 +157,14 @@ module GHC (
-- ** The debugger
SingleStep(..),
Resume(..),
- History(historyBreakInfo, historyEnclosingDecls),
+ History(historyBreakpointId, historyEnclosingDecls),
GHC.getHistorySpan, getHistoryModule,
abandon, abandonAll,
getResumeContext,
GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
- BreakInfo(..),
+ BreakpointId(..), InternalBreakpointId(..),
GHC.Runtime.Eval.back,
GHC.Runtime.Eval.forward,
GHC.Runtime.Eval.setupBreakpoint,
@@ -392,7 +392,7 @@ import GHC.Types.TyThing
import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.TypeEnv
-import GHC.Types.BreakInfo
+import GHC.Types.Breakpoint
import GHC.Types.PkgQual
import GHC.Types.Unique.FM
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -514,11 +514,16 @@ assembleI platform i = case i of
CCALL off m_addr i -> do np <- addr m_addr
emit bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit bci_PRIMCALL []
- BRK_FUN arr index mod cc -> do p1 <- ptr (BCOPtrBreakArray arr)
- m <- addr mod
+ BRK_FUN arr tick_mod tickx info_mod infox cc ->
+ do p1 <- ptr (BCOPtrBreakArray arr)
+ tick_addr <- addr tick_mod
+ info_addr <- addr info_mod
np <- addr cc
- emit bci_BRK_FUN [Op p1, SmallOp index,
- Op m, Op np]
+ emit bci_BRK_FUN [ Op p1
+ , Op tick_addr, Op info_addr
+ , SmallOp tickx, SmallOp infox
+ , Op np
+ ]
where
literal (LitLabel fs (Just sz) _)
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -206,7 +206,11 @@ data BCInstr
-- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode
-- Breakpoints
- | BRK_FUN (ForeignRef BreakArray) !Word16 (RemotePtr ModuleName)
+ | BRK_FUN (ForeignRef BreakArray)
+ (RemotePtr ModuleName) -- breakpoint tick module
+ !Word16 -- breakpoint tick index
+ (RemotePtr ModuleName) -- breakpoint info module
+ !Word16 -- breakpoint info index
(RemotePtr CostCentre)
-- -----------------------------------------------------------------------------
@@ -358,8 +362,11 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN _ index _ _) = text "BRK_FUN" <+> text "<breakarray>"
- <+> ppr index <+> text "<module>" <+> text "<cc>"
+ ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)
+ = text "BRK_FUN" <+> text "<breakarray>"
+ <+> text "<tick_module>" <+> ppr tickx
+ <+> text "<info_module>" <+> ppr infox
+ <+> text "<cc>"
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -107,7 +107,7 @@ import GHC.Types.Unique
import GHC.Types.Unique.Supply
import GHC.Types.Unique.DSet
import GHC.Types.TyThing
-import GHC.Types.BreakInfo
+import GHC.Types.Breakpoint
import GHC.Types.Unique.Map
import GHC.Unit
@@ -143,29 +143,27 @@ import Unsafe.Coerce ( unsafeCoerce )
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext = withSession (return . ic_resume . hsc_IC)
-mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
-mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
+mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> History
+mkHistory hsc_env hval ibi = History hval ibi (findEnclosingDecls hsc_env ibi)
getHistoryModule :: History -> Module
-getHistoryModule = breakInfo_module . historyBreakInfo
+getHistoryModule = ibi_tick_mod . historyBreakpointId
getHistorySpan :: HscEnv -> History -> SrcSpan
-getHistorySpan hsc_env History{..} =
- let BreakInfo{..} = historyBreakInfo in
- case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of
- Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
+getHistorySpan hsc_env hist =
+ let ibi = historyBreakpointId hist in
+ case lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env) of
+ Just hmi -> modBreaks_locs (getModBreaks hmi) ! ibi_tick_index ibi
_ -> panic "getHistorySpan"
{- | 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 -> BreakInfo -> [String]
-findEnclosingDecls hsc_env (BreakInfo modl ix) =
- let hmi = expectJust "findEnclosingDecls" $
- lookupHugByModule modl (hsc_HUG hsc_env)
- mb = getModBreaks hmi
- in modBreaks_decls mb ! ix
+findEnclosingDecls :: HscEnv -> InternalBreakpointId -> [String]
+findEnclosingDecls hsc_env ibi =
+ let hmi = expectJust "findEnclosingDecls" $ lookupHugByModule (ibi_tick_mod ibi) (hsc_HUG hsc_env)
+ in modBreaks_decls (getModBreaks hmi) ! ibi_tick_index ibi
-- | Update fixity environment in the current interactive context.
updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
@@ -324,27 +322,24 @@ handleRunStatus step expr bindings final_ids status history
| otherwise = not_tracing
where
tracing
- | EvalBreak apStack_ref maybe_break resume_ctxt _ccs <- status
- , Just (EvalBreakpoint ix mod_name) <- maybe_break
+ | EvalBreak apStack_ref (Just eval_break) resume_ctxt _ccs <- status
= do
hsc_env <- getSession
let interp = hscInterp hsc_env
let dflags = hsc_dflags hsc_env
- let hmi = expectJust "handleRunStatus" $
- lookupHpt (hsc_HPT hsc_env) (mkModuleName mod_name)
- modl = mi_module (hm_iface hmi)
+ let ibi = evalBreakpointToId (hsc_HPT hsc_env) eval_break
+ let hmi = expectJust "handleRunStatus" $ lookupHpt (hsc_HPT hsc_env) (moduleName (ibi_tick_mod ibi))
breaks = getModBreaks hmi
b <- liftIO $
- breakpointStatus interp (modBreaks_flags breaks) ix
+ breakpointStatus interp (modBreaks_flags breaks) (ibi_tick_index ibi)
if b
then not_tracing
-- This breakpoint is explicitly enabled; we want to stop
-- instead of just logging it.
else do
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
- let bi = BreakInfo modl ix
- !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
+ let !history' = mkHistory hsc_env apStack_fhv ibi `consBL` history
-- history is strict, otherwise our BoundedList is pointless.
fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
let eval_opts = initEvalOpts dflags True
@@ -362,23 +357,27 @@ handleRunStatus step expr bindings final_ids status history
let interp = hscInterp hsc_env
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
- let bp = evalBreakInfo (hsc_HPT hsc_env) <$> maybe_break
+ let ibi = evalBreakpointToId (hsc_HPT hsc_env) <$> maybe_break
(hsc_env1, names, span, decl) <- liftIO $
- bindLocalsAtBreakpoint hsc_env apStack_fhv bp
+ bindLocalsAtBreakpoint hsc_env apStack_fhv ibi
let
resume = Resume
- { resumeStmt = expr, resumeContext = resume_ctxt_fhv
- , resumeBindings = bindings, resumeFinalIds = final_ids
+ { resumeStmt = expr
+ , resumeContext = resume_ctxt_fhv
+ , resumeBindings = bindings
+ , resumeFinalIds = final_ids
, resumeApStack = apStack_fhv
- , resumeBreakInfo = bp
- , resumeSpan = span, resumeHistory = toListBL history
+ , resumeBreakpointId = ibi
+ , resumeSpan = span
+ , resumeHistory = toListBL history
, resumeDecl = decl
, resumeCCS = ccs
- , resumeHistoryIx = 0 }
+ , resumeHistoryIx = 0
+ }
hsc_env2 = pushResume hsc_env1 resume
setSession hsc_env2
- return (ExecBreak names bp)
+ return (ExecBreak names ibi)
-- Completed successfully
| EvalComplete allocs (EvalSuccess hvals) <- status
@@ -428,16 +427,21 @@ resumeExec canLogSpan step mbCnt
liftIO $ Loader.deleteFromLoadedEnv interp new_names
case r of
- Resume { resumeStmt = expr, resumeContext = fhv
- , resumeBindings = bindings, resumeFinalIds = final_ids
- , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
+ Resume { resumeStmt = expr
+ , resumeContext = fhv
+ , resumeBindings = bindings
+ , resumeFinalIds = final_ids
+ , resumeApStack = apStack
+ , resumeBreakpointId = mb_brkpt
, resumeSpan = span
, resumeHistory = hist } ->
withVirtualCWD $ do
- when (isJust mb_brkpt && isJust mbCnt) $ do
- setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt)
- -- When the user specified a break ignore count, set it
- -- in the interpreter
+ -- 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
+ _ -> return ()
+
let eval_opts = initEvalOpts dflags (isStep step)
status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
let prevHistoryLst = fromListBL 50 hist
@@ -449,16 +453,15 @@ resumeExec canLogSpan step mbCnt
fromListBL 50 hist
handleRunStatus step expr bindings final_ids status hist'
-setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m () -- #19157
-setupBreakpoint hsc_env brkInfo cnt = do
- let modl :: Module = breakInfo_module brkInfo
+setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157
+setupBreakpoint hsc_env bi cnt = do
+ let modl = bi_tick_mod bi
breaks hsc_env modl = getModBreaks $ expectJust "setupBreakpoint" $
lookupHpt (hsc_HPT hsc_env) (moduleName modl)
- ix = breakInfo_number brkInfo
modBreaks = breaks hsc_env modl
breakarray = modBreaks_flags modBreaks
interp = hscInterp hsc_env
- _ <- liftIO $ GHCi.storeBreakpoint interp breakarray ix cnt
+ _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt
pure ()
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
@@ -501,11 +504,11 @@ moveHist fn = do
if new_ix == 0
then case r of
Resume { resumeApStack = apStack,
- resumeBreakInfo = mb_brkpt } ->
+ resumeBreakpointId = mb_brkpt } ->
update_ic apStack mb_brkpt
else case history !! (new_ix - 1) of
History{..} ->
- update_ic historyApStack (Just historyBreakInfo)
+ update_ic historyApStack (Just historyBreakpointId)
-- -----------------------------------------------------------------------------
@@ -517,7 +520,7 @@ result_fs = fsLit "_result"
bindLocalsAtBreakpoint
:: HscEnv
-> ForeignHValue
- -> Maybe BreakInfo
+ -> Maybe InternalBreakpointId
-> IO (HscEnv, [Name], SrcSpan, String)
-- Nothing case: we stopped when an exception was raised, not at a
@@ -543,25 +546,28 @@ bindLocalsAtBreakpoint hsc_env apStack 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 (Just BreakInfo{..}) = do
+bindLocalsAtBreakpoint hsc_env apStack_fhv (Just ibi) = do
let
- hmi = expectJust "bindLocalsAtBreakpoint" $
- lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
interp = hscInterp hsc_env
- breaks = getModBreaks hmi
- info = expectJust "bindLocalsAtBreakpoint2" $
- IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
- occs = modBreaks_vars breaks ! breakInfo_number
- span = modBreaks_locs breaks ! breakInfo_number
- decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
+
+ info_mod = ibi_info_mod ibi
+ info_hmi = expectJust "bindLocalsAtBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName info_mod)
+ info_brks = getModBreaks info_hmi
+ info = expectJust "bindLocalsAtBreakpoint2" $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks)
+
+ tick_mod = ibi_tick_mod ibi
+ tick_hmi = expectJust "bindLocalsAtBreakpoint" $ lookupHpt (hsc_HPT hsc_env) (moduleName tick_mod)
+ tick_brks = getModBreaks tick_hmi
+ occs = modBreaks_vars tick_brks ! ibi_tick_index ibi
+ span = modBreaks_locs tick_brks ! ibi_tick_index ibi
+ decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi
-- Rehydrate to understand the breakpoint info relative to the current environment.
-- This design is critical to preventing leaks (#22530)
(mbVars, result_ty) <- initIfaceLoad hsc_env
- $ initIfaceLcl breakInfo_module (text "debugger") NotBoot
+ $ initIfaceLcl info_mod (text "debugger") NotBoot
$ hydrateCgBreakInfo info
-
let
-- Filter out any unboxed ids by changing them to Nothings;
=====================================
compiler/GHC/Runtime/Eval/Types.hs
=====================================
@@ -19,7 +19,7 @@ import GHCi.Message (EvalExpr, ResumeContext)
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.TyThing
-import GHC.Types.BreakInfo
+import GHC.Types.Breakpoint
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Utils.Exception
@@ -50,8 +50,8 @@ data ExecResult
, execAllocation :: Word64
}
| ExecBreak
- { breakNames :: [Name]
- , breakInfo :: Maybe BreakInfo
+ { breakNames :: [Name]
+ , breakPointId :: Maybe InternalBreakpointId
}
-- | Essentially a GlobalRdrEnv, but with additional cached values to allow
@@ -73,11 +73,10 @@ data Resume = Resume
, resumeFinalIds :: [Id] -- [Id] to bind on completion
, resumeApStack :: ForeignHValue -- The object from which we can get
-- value of the free variables.
- , resumeBreakInfo :: Maybe BreakInfo
- -- the breakpoint we stopped at
- -- (module, index)
+ , resumeBreakpointId :: Maybe InternalBreakpointId
+ -- ^ the breakpoint we stopped at
-- (Nothing <=> exception)
- , resumeSpan :: SrcSpan -- just a copy of the SrcSpan
+ , resumeSpan :: SrcSpan -- just a copy of the SrcSpan
-- from the ModBreaks,
-- otherwise it's a pain to
-- fetch the ModDetails &
@@ -90,9 +89,8 @@ data Resume = Resume
type ResumeBindings = ([TyThing], IcGlobalRdrEnv)
-data History
- = History {
- historyApStack :: ForeignHValue,
- historyBreakInfo :: BreakInfo,
- historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint
- }
+data History = History
+ { historyApStack :: ForeignHValue
+ , historyBreakpointId :: InternalBreakpointId -- ^ breakpoint identifier
+ , historyEnclosingDecls :: [String] -- ^ declarations enclosing the breakpoint
+ }
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
-- | Interacting with the iserv interpreter, whether it is running on an
@@ -28,7 +27,7 @@ module GHC.Runtime.Interpreter
, getClosure
, getModBreaks
, seqHValue
- , evalBreakInfo
+ , evalBreakpointToId
, interpreterDynamic
, interpreterProfiled
@@ -74,7 +73,7 @@ import GHCi.Message
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray (BreakArray)
-import GHC.Types.BreakInfo (BreakInfo(..))
+import GHC.Types.Breakpoint
import GHC.ByteCode.Types
import GHC.Linker.Types
@@ -395,14 +394,15 @@ seqHValue interp unit_env ref =
status <- interpCmd interp (Seq hval)
handleSeqHValueStatus interp unit_env status
-evalBreakInfo :: HomePackageTable -> EvalBreakpoint -> BreakInfo
-evalBreakInfo hpt (EvalBreakpoint ix mod_name) =
- BreakInfo modl ix
- where
- modl = mi_module $
- hm_iface $
- expectJust "evalBreakInfo" $
- lookupHpt hpt (mkModuleName mod_name)
+evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> InternalBreakpointId
+evalBreakpointToId hpt eval_break =
+ let load_mod x = mi_module $ hm_iface $ expectJust "evalBreakpointToId" $ lookupHpt hpt (mkModuleName x)
+ in InternalBreakpointId
+ { ibi_tick_mod = load_mod (eb_tick_mod eval_break)
+ , ibi_tick_index = eb_tick_index eval_break
+ , ibi_info_mod = load_mod (eb_info_mod eval_break)
+ , ibi_info_index = eb_info_index eval_break
+ }
-- | Process the result of a Seq or ResumeSeq message. #2950
handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
@@ -412,7 +412,7 @@ handleSeqHValueStatus interp unit_env eval_status =
-- A breakpoint was hit; inform the user and tell them
-- which breakpoint was hit.
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
- let bp = evalBreakInfo (ue_hpt unit_env) <$> maybe_break
+ let bp = evalBreakpointToId (ue_hpt unit_env) <$> maybe_break
sdocBpLoc = brackets . ppr . getSeqBpSpan
putStrLn ("*** Ignoring breakpoint " ++
(showSDocUnsafe $ sdocBpLoc bp))
@@ -422,14 +422,15 @@ handleSeqHValueStatus interp unit_env eval_status =
handleSeqHValueStatus interp unit_env status
(EvalComplete _ r) -> return r
where
- getSeqBpSpan :: Maybe BreakInfo -> SrcSpan
- -- Just case: Stopped at a breakpoint, extract SrcSpan information
- -- from the breakpoint.
- getSeqBpSpan (Just BreakInfo{..}) =
- (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number
- -- Nothing case - should not occur!
- -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq
- getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>")
+ getSeqBpSpan :: Maybe InternalBreakpointId -> SrcSpan
+ getSeqBpSpan = \case
+ Just bi -> (modBreaks_locs (breaks (ibi_tick_mod bi))) ! ibi_tick_index bi
+ -- Just case: Stopped at a breakpoint, extract SrcSpan information
+ -- from the breakpoint.
+ Nothing -> mkGeneralSrcSpan (fsLit "<unknown>")
+ -- Nothing case - should not occur!
+ -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq
+ --
breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $
lookupHpt (ue_hpt unit_env) (moduleName mod)
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -384,27 +384,40 @@ 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 mod) rhs) = do
+schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
code <- schemeE d 0 p rhs
hsc_env <- getHscEnv
current_mod <- getCurrentModule
- current_mod_breaks <- getCurrentModBreaks
- case break_info hsc_env mod current_mod current_mod_breaks of
+ mb_current_mod_breaks <- getCurrentModBreaks
+ case mb_current_mod_breaks of
+ -- if we're not generating ModBreaks for this module for some reason, we
+ -- can't store breakpoint occurrence information.
Nothing -> pure code
- Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = mod_ptr, modBreaks_ccs = cc_arr} -> do
- platform <- profilePlatform <$> getProfile
- let idOffSets = getVarOffSets platform d p fvs
- ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
- toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
- toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
- breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
- newBreakInfo tick_no breakInfo
- let cc | Just interp <- hsc_interp hsc_env
- , interpreterProfiled interp
- = cc_arr ! tick_no
- | otherwise = toRemotePtr nullPtr
- breakInstr = BRK_FUN breaks (fromIntegral tick_no) mod_ptr cc
- return $ breakInstr `consOL` code
+ Just current_mod_breaks -> case break_info hsc_env tick_mod current_mod mb_current_mod_breaks of
+ Nothing -> pure code
+ Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do
+ platform <- profilePlatform <$> getProfile
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
+
+ let info_mod_ptr = modBreaks_module current_mod_breaks
+ infox <- newBreakInfo breakInfo
+
+ let cc | Just interp <- hsc_interp hsc_env
+ , interpreterProfiled interp
+ = cc_arr ! tick_no
+ | otherwise = toRemotePtr nullPtr
+
+ let -- cast that checks that round-tripping through Word16 doesn't change the value
+ toW16 x = let r = fromIntegral x :: Word16
+ in if fromIntegral r == x
+ then r
+ else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
+ breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc
+ return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
-- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module
@@ -2189,7 +2202,12 @@ data BcM_State
, ffis :: [FFIInfo] -- ffi info blocks, to free later
-- Should be free()d when it is GCd
, modBreaks :: Maybe ModBreaks -- info about breakpoints
- , breakInfo :: IntMap CgBreakInfo
+
+ , 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
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)
@@ -2203,7 +2221,7 @@ 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)
+ = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty 0)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -2259,9 +2277,14 @@ getLabelsBc n
= BcM $ \st -> let ctr = nextlabel st
in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
-newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
-newBreakInfo ix info = BcM $ \st ->
- return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
+newBreakInfo :: CgBreakInfo -> BcM Int
+newBreakInfo info = BcM $ \st ->
+ let ix = breakInfoIdx st
+ st' = st
+ { breakInfo = IntMap.insert ix info (breakInfo st)
+ , breakInfoIdx = ix + 1
+ }
+ in return (st', ix)
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \st -> return (st, thisModule st)
=====================================
compiler/GHC/Types/BreakInfo.hs deleted
=====================================
@@ -1,12 +0,0 @@
--- | A module for the BreakInfo type. Used by both the GHC.Runtime.Eval and
--- GHC.Runtime.Interpreter hierarchy, so put here to have a less deep module
--- dependency tree
-module GHC.Types.BreakInfo (BreakInfo(..)) where
-
-import GHC.Prelude
-import GHC.Unit.Module
-
-data BreakInfo = BreakInfo
- { breakInfo_module :: Module
- , breakInfo_number :: Int
- }
=====================================
compiler/GHC/Types/Breakpoint.hs
=====================================
@@ -0,0 +1,53 @@
+-- | Breakpoint related types
+module GHC.Types.Breakpoint
+ ( BreakpointId (..)
+ , InternalBreakpointId (..)
+ , toBreakpointId
+ )
+where
+
+import GHC.Prelude
+import GHC.Unit.Module
+
+-- | Breakpoint identifier.
+--
+-- See Note [Breakpoint identifiers]
+data BreakpointId = BreakpointId
+ { bi_tick_mod :: !Module -- ^ Breakpoint tick module
+ , bi_tick_index :: !Int -- ^ Breakpoint tick index
+ }
+
+-- | Internal breakpoint identifier
+--
+-- See Note [Breakpoint identifiers]
+data InternalBreakpointId = InternalBreakpointId
+ { ibi_tick_mod :: !Module -- ^ Breakpoint tick module
+ , ibi_tick_index :: !Int -- ^ Breakpoint tick index
+ , ibi_info_mod :: !Module -- ^ Breakpoint info module
+ , ibi_info_index :: !Int -- ^ Breakpoint info index
+ }
+
+toBreakpointId :: InternalBreakpointId -> BreakpointId
+toBreakpointId ibi = BreakpointId
+ { bi_tick_mod = ibi_tick_mod ibi
+ , bi_tick_index = ibi_tick_index ibi
+ }
+
+
+-- Note [Breakpoint identifiers]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Before optimization a breakpoint is identified uniquely with a tick module
+-- and a tick index. See BreakpointId. A tick module contains an array, indexed
+-- with the tick indexes, which indicates breakpoint status.
+--
+-- When we generate ByteCode, we collect information for every breakpoint at
+-- their *occurrence sites* (see CgBreakInfo in GHC.ByteCode.Types) and these info
+-- are stored in the ModIface of the occurrence module. Because of inlining, we
+-- can't reuse the tick index to uniquely identify an occurrence; because of
+-- cross-module inlining, we can't assume that the occurrence module is the same
+-- as the tick module (#24712).
+--
+-- 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.
=====================================
compiler/ghc.cabal.in
=====================================
@@ -844,7 +844,7 @@ Library
GHC.Types.Annotations
GHC.Types.Avail
GHC.Types.Basic
- GHC.Types.BreakInfo
+ GHC.Types.Breakpoint
GHC.Types.CompleteMatch
GHC.Types.CostCentre
GHC.Types.CostCentre.State
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -72,6 +72,7 @@ import GHC.Core.TyCo.Ppr
import GHC.Types.SafeHaskell ( getSafeMode )
import GHC.Types.SourceError ( SourceError )
import GHC.Types.Name
+import GHC.Types.Breakpoint
import GHC.Types.Var ( varType )
import GHC.Iface.Syntax ( showToHeader )
import GHC.Builtin.Names
@@ -1408,15 +1409,13 @@ runAllocs m = do
_ -> Nothing
toBreakIdAndLocation :: GhciMonad m
- => Maybe GHC.BreakInfo -> m (Maybe (Int, BreakLocation))
+ => Maybe GHC.InternalBreakpointId -> m (Maybe (Int, BreakLocation))
toBreakIdAndLocation Nothing = return Nothing
toBreakIdAndLocation (Just inf) = do
- let md = GHC.breakInfo_module inf
- nm = GHC.breakInfo_number inf
st <- getGHCiState
return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
- breakModule loc == md,
- breakTick loc == nm ]
+ breakModule loc == ibi_tick_mod inf,
+ breakTick loc == ibi_tick_index inf ]
printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo res names = do
@@ -1544,15 +1543,11 @@ getCallStackAtCurrentBreakpoint = do
getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)
getCurrentBreakModule = do
resumes <- GHC.getResumeContext
- case resumes of
- [] -> return Nothing
- (r:_) -> do
- let ix = GHC.resumeHistoryIx r
- if ix == 0
- then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
- else do
- let hist = GHC.resumeHistory r !! (ix-1)
- return $ Just $ GHC.getHistoryModule hist
+ 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)
-----------------------------------------------------------------------------
--
@@ -3474,7 +3469,7 @@ pprStopped res =
<> text (GHC.resumeDecl res))
<> char ',' <+> ppr (GHC.resumeSpan res)
where
- mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res
+ mb_mod_name = moduleName <$> ibi_tick_mod <$> GHC.resumeBreakpointId res
showUnits :: GHC.GhcMonad m => m ()
showUnits = do
@@ -4035,8 +4030,11 @@ ignoreCmd argLine = withSandboxOnly ":ignore" $ do
case result of
Left sdoc -> printForUser sdoc
Right (loc, count) -> do
- let breakInfo = GHC.BreakInfo (breakModule loc) (breakTick loc)
- setupBreakpoint breakInfo count
+ let bi = GHC.BreakpointId
+ { bi_tick_mod = breakModule loc
+ , bi_tick_index = breakTick loc
+ }
+ setupBreakpoint bi count
ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Int))
ignoreSwitch [break, count] = do
@@ -4053,7 +4051,7 @@ getIgnoreCount str =
where
sdocIgnore = text "Ignore count" <+> quotes (text str)
-setupBreakpoint :: GhciMonad m => GHC.BreakInfo -> Int -> m()
+setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m()
setupBreakpoint loc count = do
hsc_env <- GHC.getSession
GHC.setupBreakpoint hsc_env loc count
@@ -4542,7 +4540,7 @@ setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m ()
setBreakFlag md ix enaDisa = do
let enaDisaToCount True = breakOn
enaDisaToCount False = breakOff
- setupBreakpoint (GHC.BreakInfo md ix) $ enaDisaToCount enaDisa
+ setupBreakpoint (GHC.BreakpointId md ix) $ enaDisaToCount enaDisa
-- ---------------------------------------------------------------------------
-- User code exception handling
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -398,10 +398,12 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
-data EvalBreakpoint =
- EvalBreakpoint
- Int -- ^ break index
- String -- ^ ModuleName
+data EvalBreakpoint = EvalBreakpoint
+ { eb_tick_mod :: String -- ^ Breakpoint tick module
+ , eb_tick_index :: Int -- ^ Breakpoint tick index
+ , eb_info_mod :: String -- ^ Breakpoint info module
+ , eb_info_index :: Int -- ^ Breakpoint info index
+ }
deriving (Generic, Show)
instance Binary EvalBreakpoint
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -329,7 +329,7 @@ withBreakAction opts breakMVar statusMVar act
-- as soon as it is hit, or in resetBreakAction below.
onBreak :: BreakpointCallback
- onBreak ix# mod_name# is_exception apStack = do
+ onBreak tick_mod# tickx# info_mod# infox# is_exception apStack = do
tid <- myThreadId
let resume = ResumeContext
{ resumeBreakMVar = breakMVar
@@ -342,8 +342,9 @@ withBreakAction opts breakMVar statusMVar act
if is_exception
then pure Nothing
else do
- mod_name <- peekCString (Ptr mod_name#)
- pure (Just (EvalBreakpoint (I# ix#) mod_name))
+ tick_mod <- peekCString (Ptr tick_mod#)
+ info_mod <- peekCString (Ptr info_mod#)
+ pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
takeMVar breakMVar
@@ -392,8 +393,10 @@ resetStepFlag :: IO ()
resetStepFlag = poke stepFlag 0
type BreakpointCallback
- = Int# -- the breakpoint index
- -> Addr# -- pointer to the module name
+ = Addr# -- pointer to the breakpoint tick module name
+ -> Int# -- breakpoint tick index
+ -> Addr# -- pointer to the breakpoint info module name
+ -> Int# -- breakpoint info index
-> Bool -- exception?
-> HValue -- the AP_STACK, or exception
-> IO ()
@@ -405,8 +408,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: BreakpointCallback
-noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction _ _ True _ = return () -- exception: just continue
+noBreakAction _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ _ _ True _ = return () -- exception: just continue
-- Malloc and copy the bytes. We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
=====================================
rts/Exception.cmm
=====================================
@@ -535,15 +535,19 @@ retry_pop_stack:
// be per-thread.
CInt[rts_stop_on_exception] = 0;
("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
- Sp = Sp - WDS(9);
- Sp(8) = exception;
- Sp(7) = stg_raise_ret_info;
- Sp(6) = exception;
- Sp(5) = ghczmprim_GHCziTypes_True_closure; // True <=> an exception
- Sp(4) = stg_ap_ppv_info;
- Sp(3) = 0;
- Sp(2) = stg_ap_n_info;
- Sp(1) = 0;
+ Sp = Sp - WDS(13);
+ Sp(12) = exception;
+ Sp(11) = stg_raise_ret_info;
+ Sp(10) = exception;
+ Sp(9) = ghczmprim_GHCziTypes_True_closure; // True <=> an exception
+ Sp(8) = stg_ap_ppv_info;
+ Sp(7) = 0;
+ Sp(6) = stg_ap_n_info;
+ Sp(5) = 0;
+ Sp(4) = stg_ap_n_info;
+ Sp(3) = 0;
+ Sp(2) = stg_ap_n_info;
+ Sp(1) = 0;
R1 = ioAction;
jump RET_LBL(stg_ap_n) [R1];
}
=====================================
rts/Interpreter.c
=====================================
@@ -1089,9 +1089,9 @@ run_BCO:
/* check for a breakpoint on the beginning of a let binding */
case bci_BRK_FUN:
{
- int arg1_brk_array, arg2_array_index, arg3_module_name;
+ int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_index, arg5_info_index;
#if defined(PROFILING)
- int arg4_cc;
+ int arg6_cc;
#endif
StgArrBytes *breakPoints;
int returning_from_break;
@@ -1106,10 +1106,12 @@ run_BCO:
int size_words;
arg1_brk_array = BCO_GET_LARGE_ARG;
- arg2_array_index = BCO_NEXT;
- arg3_module_name = BCO_GET_LARGE_ARG;
+ arg2_tick_mod = BCO_GET_LARGE_ARG;
+ arg3_info_mod = BCO_GET_LARGE_ARG;
+ arg4_tick_index = BCO_NEXT;
+ arg5_info_index = BCO_NEXT;
#if defined(PROFILING)
- arg4_cc = BCO_GET_LARGE_ARG;
+ arg6_cc = BCO_GET_LARGE_ARG;
#else
BCO_GET_LARGE_ARG;
#endif
@@ -1122,7 +1124,7 @@ run_BCO:
#if defined(PROFILING)
cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
- (CostCentre*)BCO_LIT(arg4_cc));
+ (CostCentre*)BCO_LIT(arg6_cc));
#endif
// if we are returning from a break then skip this section
@@ -1134,11 +1136,11 @@ run_BCO:
// stop the current thread if either the
// "rts_stop_next_breakpoint" flag is true OR if the
// ignore count for this particular breakpoint is zero
- StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg2_array_index];
+ StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_tick_index];
if (rts_stop_next_breakpoint == false && ignore_count > 0)
{
// decrement and write back ignore count
- ((StgInt*)breakPoints->payload)[arg2_array_index] = --ignore_count;
+ ((StgInt*)breakPoints->payload)[arg4_tick_index] = --ignore_count;
}
else if (rts_stop_next_breakpoint == true || ignore_count == 0)
{
@@ -1171,8 +1173,10 @@ run_BCO:
// Arrange the stack to call the breakpoint IO action, and
// continue execution of this BCO when the IO action returns.
//
- // ioAction :: Int# -- the breakpoint index
- // -> Addr# -- the breakpoint module
+ // ioAction :: Addr# -- the breakpoint tick module
+ // -> Int# -- the breakpoint tick index
+ // -> Addr# -- the breakpoint info module
+ // -> Int# -- the breakpoint info index
// -> Bool -- exception?
// -> HValue -- the AP_STACK, or exception
// -> IO ()
@@ -1180,15 +1184,19 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(11);
- SpW(10) = (W_)obj;
- SpW(9) = (W_)&stg_apply_interp_info;
- SpW(8) = (W_)new_aps;
- SpW(7) = (W_)False_closure; // True <=> an exception
- SpW(6) = (W_)&stg_ap_ppv_info;
- SpW(5) = (W_)BCO_LIT(arg3_module_name);
+ Sp_subW(15);
+ SpW(14) = (W_)obj;
+ SpW(13) = (W_)&stg_apply_interp_info;
+ SpW(12) = (W_)new_aps;
+ SpW(11) = (W_)False_closure; // True <=> an exception
+ SpW(10) = (W_)&stg_ap_ppv_info;
+ SpW(9) = (W_)arg5_info_index;
+ SpW(8) = (W_)&stg_ap_n_info;
+ SpW(7) = (W_)BCO_LIT(arg3_info_mod);
+ SpW(6) = (W_)&stg_ap_n_info;
+ SpW(5) = (W_)arg4_tick_index;
SpW(4) = (W_)&stg_ap_n_info;
- SpW(3) = (W_)arg2_array_index;
+ SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
SpW(2) = (W_)&stg_ap_n_info;
SpW(1) = (W_)ioAction;
SpW(0) = (W_)&stg_enter_info;
=====================================
testsuite/tests/ghci.debugger/scripts/T24712.hs
=====================================
@@ -0,0 +1,2 @@
+main = foo 123
+foo n = print n
=====================================
testsuite/tests/ghci.debugger/scripts/T24712.script
=====================================
@@ -0,0 +1,3 @@
+:l T24712.hs
+:b foo
+main
=====================================
testsuite/tests/ghci.debugger/scripts/T24712.stdout
=====================================
@@ -0,0 +1,4 @@
+Breakpoint 0 activated at T24712.hs:2:9-15
+Stopped in Main.foo, T24712.hs:2:9-15
+_result :: IO () = _
+n :: Integer = 123
=====================================
testsuite/tests/ghci.debugger/scripts/all.T
=====================================
@@ -141,3 +141,4 @@ test('break030',
)
test('T23057', [only_ghci, extra_hc_opts('-fno-break-points')], ghci_script, ['T23057.script'])
test('T24306', normal, ghci_script, ['T24306.script'])
+test('T24712', normal, ghci_script, ['T24712.script'])
=====================================
testsuite/tests/ghci.debugger/scripts/break021.stdout
=====================================
@@ -17,7 +17,7 @@ _result :: IO () = _
^^^^^^^
11 line2 0
Stopped in Main.line1, break020.hs:3:11-19
-_result :: m () = _
+_result :: IO () = _
2
3 line1 _ = return ()
^^^^^^^^^
@@ -29,7 +29,7 @@ _result :: IO () = _
^^^^^^^
12 in_another_decl 0
Stopped in Main.line2, break020.hs:4:11-19
-_result :: m () = _
+_result :: IO () = _
3 line1 _ = return ()
4 line2 _ = return ()
^^^^^^^^^
@@ -41,7 +41,7 @@ _result :: IO () = _
^^^^^^^^^^^^^^^^^
13 in_another_module 0
Stopped in Main.in_another_decl, break020.hs:(6,21)-(7,30)
-_result :: m () = _
+_result :: IO () = _
5
vv
6 in_another_decl _ = do line1 0
@@ -49,25 +49,25 @@ _result :: m () = _
^^
8
Stopped in Main.in_another_decl, break020.hs:6:24-30
-_result :: m () = _
+_result :: IO () = _
5
6 in_another_decl _ = do line1 0
^^^^^^^
7 line2 0
Stopped in Main.line1, break020.hs:3:11-19
-_result :: m () = _
+_result :: IO () = _
2
3 line1 _ = return ()
^^^^^^^^^
4 line2 _ = return ()
Stopped in Main.in_another_decl, break020.hs:7:24-30
-_result :: m () = _
+_result :: IO () = _
6 in_another_decl _ = do line1 0
7 line2 0
^^^^^^^
8
Stopped in Main.line2, break020.hs:4:11-19
-_result :: m () = _
+_result :: IO () = _
3 line1 _ = return ()
4 line2 _ = return ()
^^^^^^^^^
@@ -85,7 +85,7 @@ _result :: IO () = _
^^^^^^^
15 return ()
Stopped in Main.line2, break020.hs:4:11-19
-_result :: m () = _
+_result :: IO () = _
3 line1 _ = return ()
4 line2 _ = return ()
^^^^^^^^^
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b85b11994e0130ff2401dd4bbdf52330e0bcf776
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b85b11994e0130ff2401dd4bbdf52330e0bcf776
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240502/6cf578a5/attachment-0001.html>
More information about the ghc-commits
mailing list