May 2025 - ghc-commits

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

23 May '25

Rodrigo Mesquita pushed to branch wip/romes/step-out at Glasgow Haskell Compiler / GHC Commits: 8f61f302 by Rodrigo Mesquita at 2025-05-23T17:25:39+01:00 debugger: Implement step-out feature TODO UPDATE DESCRIPTION Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. On the other hand, it means the debugger follows the more realistic execution of the program. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key implementation bit is simple: When step-out is set and the interpreter hits a RETURN instruction, enable "stop at the immediate next breakpoint" (aka single-step). See also `Note [Debugger Step-out]` in `rts/Interpreter.c` Note [Debugger Step-out] ~~~~~~~~~~~~~~~~~~~~~~~~ When the global debugger step-out flag is set (`rts_stop_after_return`), the interpreter must yield execution right after the first RETURN. When stepping-out, we simply enable `rts_stop_next_breakpoint` when we hit a return instruction (in `do_return_pointer` and `do_return_nonpointer`). The step-out flag is cleared and must be re-enabled explicitly to step-out again. A limitation of this approach is that stepping-out of a function that was tail-called will skip its caller since no stack frame is pushed for a tail call (i.e. a tail call returns directly to its caller's first non-tail caller). Fixes #26042 - - - - - 32 changed files: - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - + rts/Debugger.cmm - rts/Interpreter.c - rts/Interpreter.h - rts/Printer.c - rts/RtsSymbols.c - rts/include/rts/Constants.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h - rts/rts.cabal - + testsuite/tests/ghci.debugger/scripts/T26042a.hs - + testsuite/tests/ghci.debugger/scripts/T26042a.script - + testsuite/tests/ghci.debugger/scripts/T26042a.stdout - + testsuite/tests/ghci.debugger/scripts/T26042b.hs - + testsuite/tests/ghci.debugger/scripts/T26042b.script - + testsuite/tests/ghci.debugger/scripts/T26042b.stdout - + testsuite/tests/ghci.debugger/scripts/T26042c.hs - + testsuite/tests/ghci.debugger/scripts/T26042c.script - + testsuite/tests/ghci.debugger/scripts/T26042c.stdout - testsuite/tests/ghci.debugger/scripts/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f61f3023ca9cfd797d69478a7be9bd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f61f3023ca9cfd797d69478a7be9bd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out] 3 commits: debugger/rts: Allow toggling step-in per thread
by Rodrigo Mesquita (＠alt-romes) 23 May '25

23 May '25

Rodrigo Mesquita pushed to branch wip/romes/step-out at Glasgow Haskell Compiler / GHC Commits: ac7b34fd by Rodrigo Mesquita at 2025-05-23T15:54:43+01:00 debugger/rts: Allow toggling step-in per thread The RTS global flag `rts_stop_next_breakpoint` globally sets the interpreter to stop at the immediate next breakpoint. With this commit, single step mode can additionally be set per thread in the TSO flag (TSO_STOP_NEXT_BREAKPOINT). Being able to toggle "stop at next breakpoint" per thread is an important requirement for implementing "stepping out" of a function in a multi-threaded context. And, more generally, having a per-thread flag for single-stepping paves the way for multi-threaded debugging. That said, when we want to enable "single step" mode for the whole interpreted program we still want to stop at the immediate next breakpoint, whichever thread it belongs to. That's why we also keep the global `rts_stop_next_breakpoint` flag, with `rts_enableStopNextBreakpointAll` and `rts_disableStopNextBreakpointAll` helpers. Preparation for #26042 - - - - - 186b2582 by Rodrigo Mesquita at 2025-05-23T15:55:01+01:00 rts: Case continuation BCOs This commit introduces the `stg_CASE_CONT_BCO` info table, which is identical to `stg_BCO` and shares the same closure type (== BCO). It changes the bytecode generator to always use `stg_CASE_CONT_BCO_info` when constructing case continuation BCOs, and remain using `stg_BCO` otherwise. This allows us to distinguish at runtime case continuation BCOs from other BCOs. In particular, this is relevant because, unlike other BCOs, the code of a case continuation BCO may refer to variables in its parent's stack frame (ie non-local variables), and therefore its frame position on the stack cannot be changed in isolation. The full motivation and details are in Note [Case continuation BCOs]. Towards #26042 - - - - - 6a2a446b by Rodrigo Mesquita at 2025-05-23T17:24:00+01:00 debugger: Implement step-out feature TODO UPDATE DESCRIPTION Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. On the other hand, it means the debugger follows the more realistic execution of the program. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key implementation bit is simple: When step-out is set and the interpreter hits a RETURN instruction, enable "stop at the immediate next breakpoint" (aka single-step). See also `Note [Debugger Step-out]` in `rts/Interpreter.c` Note [Debugger Step-out] ~~~~~~~~~~~~~~~~~~~~~~~~ When the global debugger step-out flag is set (`rts_stop_after_return`), the interpreter must yield execution right after the first RETURN. When stepping-out, we simply enable `rts_stop_next_breakpoint` when we hit a return instruction (in `do_return_pointer` and `do_return_nonpointer`). The step-out flag is cleared and must be re-enabled explicitly to step-out again. A limitation of this approach is that stepping-out of a function that was tail-called will skip its caller since no stack frame is pushed for a tail call (i.e. a tail call returns directly to its caller's first non-tail caller). Fixes #26042 - - - - - 44 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/StgToByteCode.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghci/GHCi/CreateBCO.hs - + libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/ResolvedBCO.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - + rts/Debugger.cmm - rts/Interpreter.c - rts/Interpreter.h - rts/PrimOps.cmm - rts/Printer.c - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/rts/Constants.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h - rts/rts.cabal - + testsuite/tests/ghci.debugger/scripts/T26042a.hs - + testsuite/tests/ghci.debugger/scripts/T26042a.script - + testsuite/tests/ghci.debugger/scripts/T26042a.stdout - + testsuite/tests/ghci.debugger/scripts/T26042b.hs - + testsuite/tests/ghci.debugger/scripts/T26042b.script - + testsuite/tests/ghci.debugger/scripts/T26042b.stdout - + testsuite/tests/ghci.debugger/scripts/T26042c.hs - + testsuite/tests/ghci.debugger/scripts/T26042c.script - + testsuite/tests/ghci.debugger/scripts/T26042c.stdout - testsuite/tests/ghci.debugger/scripts/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1cb330020a43ac0b7098744f56a6d4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1cb330020a43ac0b7098744f56a6d4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25992] yet more
by Simon Peyton Jones (＠simonpj) 23 May '25

23 May '25

Simon Peyton Jones pushed to branch wip/T25992 at Glasgow Haskell Compiler / GHC Commits: 4cb8b60a by Simon Peyton Jones at 2025-05-23T17:11:37+01:00 yet more - - - - - 6 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -399,13 +399,6 @@ warnRedundantConstraints ctxt env info redundant_evs | null redundant_evs = return () - -- Do not report redundant constraints for quantified constraints - -- See (RC4) in Note [Tracking redundant constraints] - -- Fortunately it is easy to spot implications constraints that arise - -- from quantified constraints, from their SkolInfo - | InstSkol (IsQC {}) _ <- info - = return () - | SigSkol user_ctxt _ _ <- info -- When dealing with a user-written type signature, -- we want to add "In the type signature for f". ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -275,7 +275,7 @@ solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS Implicati solveImplicationUsingUnsatGiven unsat_given@(given_ev,_) impl@(Implic { ic_wanted = wtd, ic_tclvl = tclvl, ic_binds = ev_binds_var - , ic_need_pruned = inner }) + , ic_need_implic = inner }) | isCoEvBindsVar ev_binds_var -- We can't use Unsatisfiable evidence in kinds. -- See Note [Coercion evidence only] in GHC.Tc.Types.Evidence. @@ -284,7 +284,7 @@ solveImplicationUsingUnsatGiven = do { wcs <- nestImplicTcS ev_binds_var tclvl $ go_wc wtd ; setImplicationStatus $ impl { ic_wanted = wcs - , ic_need_pruned = inner `extendEvNeedSet` given_ev } } + , ic_need_implic = inner `extendEvNeedSet` given_ev } } -- Record that the Given is needed; I'm not certain why where go_wc :: WantedConstraints -> TcS WantedConstraints ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -2089,18 +2089,8 @@ solveOneFromTheOther. (a) If both are GivenSCOrigin, choose the one that is unblocked if possible according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. - (b) Prefer constraints that are not superclass selections. Example: - - f :: (Eq a, Ord a) => a -> Bool - f x = x == x - - Eager superclass expansion gives us two [G] Eq a constraints. We - want to keep the one from the user-written Eq a, not the superclass - selection. This means we report the Ord a as redundant with - -Wredundant-constraints, not the Eq a. - - Getting this wrong was #20602. See also - Note [Tracking redundant constraints] in GHC.Tc.Solver. + (b) Prefer constraints that are not superclass selections. See + (TRC3) in Note [Tracking redundant constraints] in GHC.Tc.Solver. (c) If both are GivenSCOrigin, chooose the one with the shallower superclass-selection depth, in the hope of identifying more correct ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -354,84 +354,42 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ---------------------- setImplicationStatus :: Implication -> TcS Implication -- Finalise the implication returned from solveImplication, --- setting the ic_status field +-- * Set the ic_status field +-- * Prune unnecessary evidence bindings +-- * Prune unnecessary child implications -- Precondition: the ic_status field is not already IC_Solved --- Return Nothing if we can discard the implication altogether setImplicationStatus implic@(Implic { ic_status = old_status , ic_info = info , ic_wanted = wc }) - | assertPpr (not (isSolvedStatus old_status)) (ppr info) $ + = assertPpr (not (isSolvedStatus old_status)) (ppr info) $ -- Precondition: we only set the status if it is not already solved - not (isSolvedWC wc) - = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic) + do { traceTcS "setImplicationStatus {" (ppr implic) - ; let new_status | insolubleWC wc = IC_Insoluble - | otherwise = IC_Unsolved - new_implic = pruneImplications (implic { ic_status = new_status }) - - ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic) - - ; return new_implic } - - | otherwise - = do { traceTcS "setImplicationStatus(solved) {" (ppr implic) + ; let solved = isSolvedWC wc + ; new_implic <- neededEvVars implic + ; bad_telescope <- if solved then checkBadTelescope implic + else return False - ; (dead_givens, implic) <- neededEvVars implic - - ; bad_telescope <- checkBadTelescope implic + ; let new_status | insolubleWC wc = IC_Insoluble + | not solved = IC_Unsolved + | bad_telescope = IC_BadTelescope + | otherwise = IC_Solved { ics_dead = dead_givens } + dead_givens = findRedundantGivens new_implic - ; let final_status - | bad_telescope = IC_BadTelescope - | otherwise = IC_Solved { ics_dead = dead_givens } - final_implic = pruneImplications (implic { ic_status = final_status }) + final_implic = new_implic { ic_status = new_status } - ; traceTcS "setImplicationStatus(solved) }" (ppr final_implic) + ; traceTcS "setImplicationStatus }" (ppr final_implic) ; return final_implic } -pruneImplications :: Implication -> Implication --- We have now taken account of the `needs_outer` variables of these --- implications, so we can drop any that are no longer necessary -pruneImplications implic@(Implic { ic_wanted = wc - , ic_need_pruned = old_needs }) - = implic { ic_need_pruned = new_needs - , ic_wanted = wc { wc_impl = new_implics } } - -- Do not prune holes; these should be reported - where - (new_needs, new_implics) = foldr do_one (old_needs, emptyBag) (wc_impl wc) - - do_one :: Implication -> (EvNeedSet, Bag Implication) -> (EvNeedSet, Bag Implication) - do_one implic (ens, implics) - | keep_me implic = (ens, implic `consBag` implics) - | otherwise = (add_needs ens implic, implics) - - keep_me :: Implication -> Bool - keep_me (Implic { ic_status = status, ic_wanted = wanted }) - | IC_Solved { ics_dead = dead_givens } <- status -- Fully solved - , null dead_givens -- No redundant givens to report - , isEmptyBag (wc_impl wanted) -- No children that might have things to report - = False - | otherwise - = True -- Otherwise, keep it - - add_needs :: EvNeedSet -> Implication -> EvNeedSet - -- For a default-method implication, add all its needed vars to ens_dms - -- For anything else, just propagate - add_needs (ENS { ens_dms = dms, ens_fvs = fvs }) - (Implic { ic_need_outer = ENS { ens_dms = dms1, ens_fvs = fvs1 } - , ic_info = info }) - | is_dm_skol info = ENS { ens_dms = dms `unionVarSet` dms1 `unionVarSet` fvs1 - , ens_fvs = fvs } - | otherwise = ENS { ens_dms = dms `unionVarSet` dms1 - , ens_fvs = fvs `unionVarSet` fvs1 } - -findUnnecessaryGivens :: SkolemInfoAnon -> VarSet -> [EvVar] -> [EvVar] -findUnnecessaryGivens info need_inner givens +findRedundantGivens :: Implication -> [EvVar] +findRedundantGivens (Implic { ic_info = info, ic_need = need, ic_given = givens }) | not (warnRedundantGivens info) -- Don't report redundant constraints at all - = [] + = [] -- See (TRC4) of Note [Tracking redundant constraints] | not (null unused_givens) -- Some givens are literally unused = unused_givens + -- Only try this if unused_givens is empty: see (TRC2a) | otherwise -- All givens are used, but some might = redundant_givens -- still be redundant e.g. (Eq a, Ord a) @@ -441,11 +399,13 @@ findUnnecessaryGivens info need_inner givens unused_givens = filterOut is_used givens + needed_givens_ignoring_default_methods = ens_fvs need is_used given = is_type_error given - || given `elemVarSet` need_inner + || given `elemVarSet` needed_givens_ignoring_default_methods || (in_instance_decl && is_improving (idType given)) - minimal_givens = mkMinimalBySCs evVarPred givens + minimal_givens = mkMinimalBySCs evVarPred givens -- See (TRC2) + is_minimal = (`elemVarSet` mkVarSet minimal_givens) redundant_givens | in_instance_decl = [] @@ -457,6 +417,26 @@ findUnnecessaryGivens info need_inner givens is_improving pred -- (transSuperClasses p) does not include p = any isImprovementPred (pred : transSuperClasses pred) +warnRedundantGivens :: SkolemInfoAnon -> Bool +warnRedundantGivens (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt _ rrc -> reportRedundantConstraints rrc + ExprSigCtxt rrc -> reportRedundantConstraints rrc + _ -> False + +warnRedundantGivens (InstSkol from _) + -- Do not report redundant constraints for quantified constraints + -- See (TRC4) in Note [Tracking redundant constraints] + -- Fortunately it is easy to spot implications constraints that arise + -- from quantified constraints, from their SkolInfo + = case from of + IsQC {} -> False + IsClsInst {} -> True + + -- To think about: do we want to report redundant givens for + -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. +warnRedundantGivens _ = False + {- Note [Redundant constraints in instance decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Instance declarations are special in two ways: @@ -508,21 +488,11 @@ checkBadTelescope (Implic { ic_info = info | otherwise = go (later_skols `extendVarSet` one_skol) earlier_skols -warnRedundantGivens :: SkolemInfoAnon -> Bool -warnRedundantGivens (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt _ rrc -> reportRedundantConstraints rrc - ExprSigCtxt rrc -> reportRedundantConstraints rrc - _ -> False - - -- To think about: do we want to report redundant givens for - -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. -warnRedundantGivens (InstSkol {}) = True -warnRedundantGivens _ = False - -neededEvVars :: Implication -> TcS ([EvVar], Implication) +neededEvVars :: Implication -> TcS Implication -- Find all the evidence variables that are "needed", --- and delete dead evidence bindings +-- /and/ delete dead evidence bindings +-- /and/ delete unnecessary child implications +-- -- See Note [Tracking redundant constraints] -- See Note [Delete dead Given evidence bindings] -- @@ -539,78 +509,89 @@ neededEvVars :: Implication -> TcS ([EvVar], Implication) -- -- - Prune out all Given bindings that are not needed -- --- - From the 'needed' set, delete ev_bndrs, the binders of the --- evidence bindings, to give the final needed variables --- -neededEvVars implic@(Implic { ic_given = givens - , ic_info = info - , ic_binds = ev_binds_var - , ic_wanted = WC { wc_impl = implics } - , ic_need_pruned = need_pruned }) +-- - Prune out all child implications that are no longer useful + +neededEvVars implic@(Implic { ic_info = info + , ic_binds = ev_binds_var + , ic_wanted = old_wanted + , ic_need_implic = old_need_implic -- See (TRC1) + }) + | WC { wc_impl = old_implics } <- old_wanted = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - ; let -- Get the variables needed by the implications - ENS { ens_dms = implic_dm_seeds, ens_fvs = implic_other_seeds } - = foldr add_implic_seeds need_pruned implics + ; let -- Augment `need_implic` (see (TRC1)) with the variables needed by the implications + new_need_implic@(ENS { ens_dms = dm_seeds, ens_fvs = other_seeds }) + = foldr add_implic old_need_implic old_implics -- Get the variables needed by the solved bindings + -- (It's OK to use a non-deterministic fold here + -- because add_wanted is commutative.) seeds_w = nonDetStrictFoldEvBindMap add_wanted tcvs ev_binds - -- `seeds_w` are the vars mentioned by all the solved Wanted bindings - -- (It's OK to use a non-deterministic fold here - -- because add_wanted is commutative.) - need_ignoring_dms = findNeededGivenEvVars ev_binds (implic_other_seeds `unionVarSet` seeds_w) - need_from_dms = findNeededGivenEvVars ev_binds implic_dm_seeds + need_ignoring_dms = findNeededGivenEvVars ev_binds (other_seeds `unionVarSet` seeds_w) + need_from_dms = findNeededGivenEvVars ev_binds dm_seeds need_full = need_ignoring_dms `unionVarSet` need_from_dms - live_ev_binds = filterEvBindMap (needed_ev_bind need_full) ev_binds + -- `new_need`: the Givens from outer scopes that are used in this implication + need | is_dm_skol info = ENS { ens_dms = trim ev_binds need_full + , ens_fvs = emptyVarSet } + | otherwise = ENS { ens_dms = trim ev_binds need_from_dms + , ens_fvs = trim ev_binds need_ignoring_dms } + + -- `new_implics`: we have now taken account of the `ic_need` variables + -- of `old_implics`, so we can drop any that are no longer necessary + pruned_implics = filterBag keep_me old_implics + pruned_wanted = old_wanted { wc_impl = pruned_implics } + -- Do not prune holes; these should be reported + + -- Delete dead Given evidence bindings + -- See Note [Delete dead Given evidence bindings] + ; let live_ev_binds = filterEvBindMap (needed_ev_bind need_full) ev_binds ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds - -- See Note [Delete dead Given evidence bindings] - - ; let -- `dead_givens` are the Givens from this implication that are unused - dead_givens = findUnnecessaryGivens info need_ignoring_dms givens - -- `need_outer` are the Givens from outer scopes that are used in this implication - need_outer - | is_dm_skol info = ENS { ens_dms = trim live_ev_binds need_full - , ens_fvs = emptyVarSet } - | otherwise = ENS { ens_dms = trim live_ev_binds need_from_dms - , ens_fvs = trim live_ev_binds need_ignoring_dms } ; traceTcS "neededEvVars" $ - vcat [ text "old need_pruned:" <+> ppr need_pruned + vcat [ text "old_need_implic:" <+> ppr old_need_implic + , text "new_need_implic:" <+> ppr new_need_implic , text "tcvs:" <+> ppr tcvs , text "need_ignoring_dms:" <+> ppr need_ignoring_dms , text "need_from_dms:" <+> ppr need_from_dms - , text "need_outer:" <+> ppr need_outer - , text "dead_givens:" <+> ppr dead_givens + , text "need:" <+> ppr need , text "ev_binds:" <+> ppr ev_binds , text "live_ev_binds:" <+> ppr live_ev_binds ] - - ; return ( dead_givens - , implic { ic_need_outer = need_outer }) } + ; return (implic { ic_need = need + , ic_need_implic = new_need_implic + , ic_wanted = pruned_wanted }) } where - trim :: EvBindMap -> VarSet -> VarSet - -- Delete variables bound by Givens or bindings - trim live_ev_binds needs = (needs `varSetMinusEvBindMap` live_ev_binds) - `delVarSetList` givens + trim :: EvBindMap -> VarSet -> VarSet + -- Delete variables bound by Givens or bindings + trim ev_binds needs = needs `varSetMinusEvBindMap` ev_binds - add_implic_seeds :: Implication -> EvNeedSet -> EvNeedSet - add_implic_seeds (Implic { ic_need_outer = needs }) acc - = needs `unionEvNeedSet` acc + add_implic :: Implication -> EvNeedSet -> EvNeedSet + add_implic (Implic { ic_given = givens, ic_need = need }) acc + = (need `delGivensFromEvNeedSet` givens) `unionEvNeedSet` acc - needed_ev_bind needed (EvBind { eb_lhs = ev_var, eb_info = info }) - | EvBindGiven{} <- info = ev_var `elemVarSet` needed - | otherwise = True -- Keep all wanted bindings + needed_ev_bind needed (EvBind { eb_lhs = ev_var, eb_info = info }) + | EvBindGiven{} <- info = ev_var `elemVarSet` needed + | otherwise = True -- Keep all wanted bindings - add_wanted :: EvBind -> VarSet -> VarSet - add_wanted (EvBind { eb_info = info, eb_rhs = rhs }) needs - | EvBindGiven{} <- info = needs -- Add the rhs vars of the Wanted bindings only - | otherwise = evVarsOfTerm rhs `unionVarSet` needs + add_wanted :: EvBind -> VarSet -> VarSet + add_wanted (EvBind { eb_info = info, eb_rhs = rhs }) needs + | EvBindGiven{} <- info = needs -- Add the rhs vars of the Wanted bindings only + | otherwise = evVarsOfTerm rhs `unionVarSet` needs -is_dm_skol :: SkolemInfoAnon -> Bool -is_dm_skol (MethSkol _ is_dm) = is_dm -is_dm_skol _ = False + keep_me :: Implication -> Bool + keep_me (Implic { ic_status = status, ic_wanted = wanted }) + | IC_Solved { ics_dead = dead_givens } <- status -- Fully solved + , null dead_givens -- No redundant givens to report + , isEmptyBag (wc_impl wanted) -- No children that might have things to report + = False + | otherwise + = True -- Otherwise, keep it + + is_dm_skol :: SkolemInfoAnon -> Bool + is_dm_skol (MethSkol _ is_dm) = is_dm + is_dm_skol _ = False findNeededGivenEvVars :: EvBindMap -> VarSet -> VarSet -- Find all the Given evidence needed by seeds, @@ -752,133 +733,82 @@ in GHC.Tc.Gen.HsType. Note [Tracking redundant constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Opt_WarnRedundantConstraints, GHC can report which -constraints of a type signature (or instance declaration) are -redundant, and can be omitted. Here is an overview of how it -works. - -This is all tested in typecheck/should_compile/T20602 (among -others). - ------ What is a redundant constraint? - -* The things that can be redundant are precisely the Given - constraints of an implication. +With Opt_WarnRedundantConstraints, GHC can report which constraints of a type +signature (or instance declaration) are redundant, and can be omitted. Here is +an overview of how it works. -* A constraint can be redundant in two different ways: - a) It is not needed by the Wanted constraints covered by the - implication E.g. - f :: Eq a => a -> Bool - f x = True -- Equality not used - b) It is implied by other givens. E.g. - f :: (Eq a, Ord a) => blah -- Eq a unnecessary - g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary - -* To find (a) we need to know which evidence bindings are 'wanted'; - hence the eb_is_given field on an EvBind. - -* To find (b), we use mkMinimalBySCs on the Givens to see if any - are unnecessary. +This is all tested in typecheck/should_compile/T20602 (among others). ----- How tracking works -(RC1) When two Givens are the same, we drop the evidence for the one - that requires more superclass selectors. This is done - according to 2(c) of Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. - -(RC2) The ic_need fields of an Implic records in-scope (given) evidence - variables bound by the context, that were needed to solve this - implication (so far). See the declaration of Implication. +* We maintain the `ic_need` field in an implication: + ic_need: the set of Given evidence variables that are needed somewhere + in this implication; and are bound either by this implication + or by an enclosing one. -(RC3) setImplicationStatus: +* `setImplicationStatus` does all the work: When the constraint solver finishes solving all the wanteds in an implication, it sets its status to IC_Solved - - The ics_dead field, of IC_Solved, records the subset of this - implication's ic_given that are redundant (not needed). - - - We compute which evidence variables are needed by an implication - in setImplicationStatus. A variable is needed if - a) it is free in the RHS of a Wanted EvBind, - b) it is free in the RHS of an EvBind whose LHS is needed, or - c) it is in the ics_need of a nested implication. - - - After computing which variables are needed, we then look at the - remaining variables for internal redundancies. This is case (b) - from above. This is also done in setImplicationStatus. - Note that we only look for case (b) if case (a) shows up empty, - as exemplified below. - - - We need to be careful not to discard an implication - prematurely, even one that is fully solved, because we might - thereby forget which variables it needs, and hence wrongly - report a constraint as redundant. But we can discard it once - its free vars have been incorporated into its parent; or if it - simply has no free vars. This careful discarding is also - handled in setImplicationStatus. - -(RC4) We do not want to report redundant constraints for implications - that come from quantified constraints. Example #23323: - data T a - instance Show (T a) where ... -- No context! - foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int - bar = foo @T @Eq - - The call to `foo` gives us - [W] d : (forall a. Eq a => Show (T a)) - To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint: - forall a. Eq a => [W] ds : Show (T a) - and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a` - constraint. But we don't want to report it as redundant! - -(RC5) Consider this (#25992), where `op2` has a default method - class C a where { op1, op2 :: a -> a - ; op2 = op1 . op1 } - instance C a => C [a] where - op1 x = x - - Plainly the (C a) constraint is unused; but the expanded decl will - look like - $dmop2 :: C a => a -> a - $dmop2 = op1 . op2 - - instance C a = C [a] b + - `neededEvVars`: computes which evidence variables are needed by an + implication in `setImplicationStatus`. A variable is needed if -*** INCOMPLETE TODO *** + a) It is in the ic_need field of this implication, computed in + a previous call to `setImplicationStatus`; see (TRC1) + b) It is in the ics_need of a nested implication; see `add_implic` + in `neededEvVars` -* Examples: - - f, g, h :: (Eq a, Ord a) => a -> Bool - f x = x == x - g x = x > x - h x = x == x && x > x + c) It is free in the RHS of any /Wanted/ EvBind; each such binding + solves a Wanted, so we want them all. See `add_wanted` in + `neededEvVars` - All three will discover that they have two [G] Eq a constraints: - one as given and one extracted from the Ord a constraint. They will - both discard the latter, as noted above and in - Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. + d) It is free in the RHS of a /Given/ EvBind whose LHS is needed: + see `findNeededGivenEvVars` called from `neededEvVars`. - The body of f uses the [G] Eq a, but not the [G] Ord a. It will - report a redundant Ord a using the logic for case (a). - - The body of g uses the [G] Ord a, but not the [G] Eq a. It will - report a redundant Eq a using the logic for case (a). - - The body of h uses both [G] Ord a and [G] Eq a. Case (a) will - thus come up with nothing redundant. But then, the case (b) - check will discover that Eq a is redundant and report this. - - If we did case (b) even when case (a) reports something, then - we would report both constraints as redundant for f, which is - terrible. - ------ Reporting redundant constraints + - Next, if the final status is IC_Solved, `setImplicationStatus` uses + `findRedunantGivens` to decide which of this implicaion's Givens are redundant. * GHC.Tc.Errors does the actual warning, in warnRedundantConstraints. -* We don't report redundant givens for *every* implication; only - for those which reply True to GHC.Tc.Solver.warnRedundantGivens: + +Wrinkles: + +(TRC1) `pruneImplications` drops any sub-implications of an Implication + that are irrelevant for error reporting: + - no unsolved wanteds + - no sub-implications + - no redundant givens to report + But in doing so we must not lose track of the variables that those implications + needed! So we do not recompute `ic_need` from scratch each time; rather, we + simply grow it -- see the use of `old_need` in `neededEvVars`. + + Starting from `old_needs` also means that the transitive closure algorithm in + `findNeededGivenEvVars` will terminate faster + +(TRC2) A Given can be redundant because it is implied by other Givens + f :: (Eq a, Ord a) => blah -- Eq a unnecessary + g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary + We nail this by using `mkMinimalBySCs` in `findRedundantGivens`. + (TRC2a) But NOTE that we only attempt this mkMinimalBySCs stuff if all Givens + used by evidence bindings. Example: + f :: (Eq a, Ord a) => a -> Bool + f x = x == x + We report (Ord a) as unused because it is. But we must not also report (Eq a) + as unused because it is a superclass of Ord! + +(TRC3) When two Givens are the same, prefer one that does not involve superclass + selection, or more generally has shallower superclass-selection depth: + see 2(b,c) in Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. + e.g f :: (Eq a, Ord a) => a -> Bool + f x = x == x + Eager superclass expansion gives us two [G] Eq a constraints. We want to keep + the one from the user-written Eq a, not the superclass selection. This means + we report the Ord a as redundant with -Wredundant-constraints, not the Eq a. + Getting this wrong was #20602. + +(TRC4) We don't compute redundant givens for *every* implication; only + for those which reply True to `warnRedundantGivens`: - For example, in a class declaration, the default method *can* use the class constraint, but it certainly doesn't *have* to, @@ -897,9 +827,68 @@ others). - GHC.Tc.Gen.Bind.tcSpecPrag - GHC.Tc.Gen.Bind.tcTySig - This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors - so that we can discard implication constraints that we don't need. - So ics_dead consists only of the *reportable* redundant givens. + - We do not want to report redundant constraints for implications + that come from quantified constraints. Example #23323: + data T a + instance Show (T a) where ... -- No context! + foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int + bar = foo @T @Eq + + The call to `foo` gives us + [W] d : (forall a. Eq a => Show (T a)) + To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint: + forall a. Eq a => [W] ds : Show (T a) + and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a` + constraint. But we don't want to report it as redundant! + +(TRC5) Consider this (#25992), where `op2` has a default method + class C a where { op1, op2 :: a -> a + ; op2 = op1 . op1 } + instance C a => C [a] where + op1 x = x + + Plainly the (C a) constraint is unused; but the expanded decl will look like + $dmop2 :: C a => a -> a + $dmop2 = op1 . op2 + + $fCList :: forall a. C a => C [a] + $fCList @a (d::C a) = MkC (\(x:a).x) ($dmop2 @a d) + + Notice that `d` gets passed to `$dmop`: it is "needed". But it's only + /really/ needed if some /other/ method (in this case `op1`) uses it. + + So, rather than one set of "needed Givens" we use `EvNeedSet` to track a /pair/ + of sets: + ens_dms: needed /only/ by default-method calls + ens_fvs: needed by something other than a default-method call + It's a bit of a palaver, but not really difficult. + All the works is in `neededEvVars`. + + + +----- Reporting redundant constraints + + +----- Examples + + f, g, h :: (Eq a, Ord a) => a -> Bool + f x = x == x + g x = x > x + h x = x == x && x > x + + All of f,g,h will discover that they have two [G] Eq a constraints: one as + given and one extracted from the Ord a constraint. They will both discard + the latter; see (TRC3). + + The body of f uses the [G] Eq a, but not the [G] Ord a. It will report a + redundant Ord a. + + The body of g uses the [G] Ord a, but not the [G] Eq a. It will report a + redundant Eq a. + + The body of h uses both [G] Ord a and [G] Eq a; each is used in a solved + Wanted evidence binding. But (TRC2) kicks in and discovers the Eq a + is redundant. ----- Shortcomings ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -67,7 +67,7 @@ module GHC.Tc.Types.Constraint ( ImplicStatus(..), isInsolubleStatus, isSolvedStatus, UserGiven, getUserGivensFromImplics, HasGivenEqs(..), checkImplicationInvariants, - EvNeedSet(..), emptyEvNeedSet, unionEvNeedSet, extendEvNeedSet, + EvNeedSet(..), emptyEvNeedSet, unionEvNeedSet, extendEvNeedSet, delGivensFromEvNeedSet, -- CtLocEnv CtLocEnv(..), setCtLocEnvLoc, setCtLocEnvLvl, getCtLocEnvLoc, getCtLocEnvLvl, ctLocEnvInGeneratedCode, @@ -1459,14 +1459,17 @@ data Implication -- The ic_need fields keep track of which Given evidence -- is used by this implication or its children - -- NB: including stuff used by nested implications that have since - -- been discarded - -- See Note [Needed evidence variables] - -- and (RC2) in Note [Tracking redundant constraints]a - ic_need_outer :: EvNeedSet, -- Includes only the free Given evidence - -- i.e. after deleting (a) ic_givens (b) binders of ic_binds - ic_need_pruned :: EvNeedSet, -- Union of the ic_need_outer EvNeedSets of implications that - -- have been pruned from wc_impl.ic_wanted + -- See Note [Tracking redundant constraints] + -- NB: including stuff used by fully-solved nested implications that have + -- since been discarded + ic_need :: EvNeedSet, -- Includes needed Given evidence + -- /after/ deleting the binders of ic_binds, but + -- /before/ deleting ic_givens + + ic_need_implic :: EvNeedSet, -- Union of of the ic_need of all implications in ic_wanted + -- /including/ any fully-solved implications that have been + -- discarded. This discarding is why we need to keep this + -- field in the first place. ic_status :: ImplicStatus } @@ -1486,6 +1489,11 @@ unionEvNeedSet (ENS { ens_dms = dm1, ens_fvs = fv1 }) extendEvNeedSet :: EvNeedSet -> Var -> EvNeedSet extendEvNeedSet ens@(ENS { ens_fvs = fvs }) v = ens { ens_fvs = fvs `extendVarSet` v } +delGivensFromEvNeedSet :: EvNeedSet -> [Var] -> EvNeedSet +delGivensFromEvNeedSet (ENS { ens_dms = dms, ens_fvs = fvs }) givens + = ENS { ens_dms = dms `delVarSetList` givens + , ens_fvs = fvs `delVarSetList` givens } + implicationPrototype :: CtLocEnv -> Implication implicationPrototype ct_loc_env = Implic { -- These fields must be initialised @@ -1494,15 +1502,17 @@ implicationPrototype ct_loc_env , ic_info = panic "newImplic:info" , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" - , ic_env = ct_loc_env + -- Given by caller + , ic_env = ct_loc_env + -- The rest have sensible default values - , ic_skols = [] - , ic_given = [] - , ic_wanted = emptyWC - , ic_given_eqs = MaybeGivenEqs - , ic_status = IC_Unsolved - , ic_need_pruned = emptyEvNeedSet - , ic_need_outer = emptyEvNeedSet } + , ic_skols = [] + , ic_given = [] + , ic_wanted = emptyWC + , ic_given_eqs = MaybeGivenEqs + , ic_status = IC_Unsolved + , ic_need = emptyEvNeedSet + , ic_need_implic = emptyEvNeedSet } data ImplicStatus = IC_Solved -- All wanteds in the tree are solved, all the way down @@ -1578,7 +1588,7 @@ instance Outputable Implication where , ic_given = given, ic_given_eqs = given_eqs , ic_wanted = wanted, ic_status = status , ic_binds = binds - , ic_need_pruned = need_pruned, ic_need_outer = need_out + , ic_need = need, ic_need_implic = need_implic , ic_info = info }) = hang (text "Implic" <+> lbrace) 2 (sep [ text "TcLevel =" <+> ppr tclvl @@ -1588,8 +1598,8 @@ instance Outputable Implication where , hang (text "Given =") 2 (pprEvVars given) , hang (text "Wanted =") 2 (ppr wanted) , text "Binds =" <+> ppr binds - , whenPprDebug (text "Needed pruned =" <+> ppr need_pruned) - , whenPprDebug (text "Needed outer =" <+> ppr need_out) + , text "need =" <+> ppr need + , text "need_implic =" <+> ppr need_implic , pprSkolInfo info ] <+> rbrace) instance Outputable EvNeedSet where @@ -1684,18 +1694,6 @@ all at once, creating one implication constraint for the lot: implication. TL;DR: an explicit forall should generate an implication quantified only over those explicitly quantified variables. -Note [Needed evidence variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Th ic_need_evs field holds the free vars of ic_binds, and all the -ic_binds in nested implications. - - * Main purpose: if one of the ic_givens is not mentioned in here, it - is redundant. - - * solveImplication may drop an implication altogether if it has no - remaining 'wanteds'. But we still track the free vars of its - evidence binds, even though it has now disappeared. - Note [Shadowing in a constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We assume NO SHADOWING in a constraint. Specifically ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -50,27 +50,30 @@ module GHC.Tc.Types.Evidence ( import GHC.Prelude -import GHC.Types.Unique.DFM -import GHC.Types.Unique.FM -import GHC.Types.Var -import GHC.Types.Id( idScaledType ) +import GHC.Tc.Utils.TcType + +import GHC.Core import GHC.Core.Coercion.Axiom import GHC.Core.Coercion import GHC.Core.Ppr () -- Instance OutputableBndr TyVar -import GHC.Tc.Utils.TcType +import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.DataCon ( DataCon, dataConWrapId ) -import GHC.Builtin.Names +import GHC.Core.Class (Class, classSCSelId ) +import GHC.Core.FVs ( exprSomeFreeVars ) +import GHC.Core.InstEnv ( CanonicalEvidence(..) ) + +import GHC.Types.Unique.DFM +import GHC.Types.Unique.FM +import GHC.Types.Var +import GHC.Types.Name( isInternalName ) +import GHC.Types.Id( idScaledType ) import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Core.Predicate import GHC.Types.Basic -import GHC.Core -import GHC.Core.Class (Class, classSCSelId ) -import GHC.Core.FVs ( exprSomeFreeVars ) -import GHC.Core.InstEnv ( CanonicalEvidence(..) ) +import GHC.Builtin.Names import GHC.Utils.Misc import GHC.Utils.Panic @@ -865,8 +868,13 @@ evTermCoercion tm = case evTermCoercion_maybe tm of * * ********************************************************************* -} +relevantEvVar :: Var -> Bool +-- Just returns /local/ free evidence variables; i.e ones with Internal Names +-- Top-level ones (DFuns, dictionary selectors and the like) don't count +relevantEvVar v = isInternalName (varName v) + evVarsOfTerm :: EvTerm -> VarSet -evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e +evVarsOfTerm (EvExpr e) = exprSomeFreeVars relevantEvVar e evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4cb8b60a22f1a3b7227f5f5153e00f3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4cb8b60a22f1a3b7227f5f5153e00f3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/top-level-bcos-tag] 2 commits: debugger/rts: Allow toggling step-in per thread
by Rodrigo Mesquita (＠alt-romes) 23 May '25

23 May '25

Rodrigo Mesquita pushed to branch wip/romes/top-level-bcos-tag at Glasgow Haskell Compiler / GHC Commits: ac7b34fd by Rodrigo Mesquita at 2025-05-23T15:54:43+01:00 debugger/rts: Allow toggling step-in per thread The RTS global flag `rts_stop_next_breakpoint` globally sets the interpreter to stop at the immediate next breakpoint. With this commit, single step mode can additionally be set per thread in the TSO flag (TSO_STOP_NEXT_BREAKPOINT). Being able to toggle "stop at next breakpoint" per thread is an important requirement for implementing "stepping out" of a function in a multi-threaded context. And, more generally, having a per-thread flag for single-stepping paves the way for multi-threaded debugging. That said, when we want to enable "single step" mode for the whole interpreted program we still want to stop at the immediate next breakpoint, whichever thread it belongs to. That's why we also keep the global `rts_stop_next_breakpoint` flag, with `rts_enableStopNextBreakpointAll` and `rts_disableStopNextBreakpointAll` helpers. Preparation for #26042 - - - - - 186b2582 by Rodrigo Mesquita at 2025-05-23T15:55:01+01:00 rts: Case continuation BCOs This commit introduces the `stg_CASE_CONT_BCO` info table, which is identical to `stg_BCO` and shares the same closure type (== BCO). It changes the bytecode generator to always use `stg_CASE_CONT_BCO_info` when constructing case continuation BCOs, and remain using `stg_BCO` otherwise. This allows us to distinguish at runtime case continuation BCOs from other BCOs. In particular, this is relevant because, unlike other BCOs, the code of a case continuation BCO may refer to variables in its parent's stack frame (ie non-local variables), and therefore its frame position on the stack cannot be changed in isolation. The full motivation and details are in Note [Case continuation BCOs]. Towards #26042 - - - - - 25 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/StgToByteCode.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghci/GHCi/CreateBCO.hs - + libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/ResolvedBCO.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Interpreter.c - rts/Interpreter.h - rts/PrimOps.cmm - rts/Printer.c - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/rts/Constants.h - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3872,12 +3872,13 @@ primop MkApUpd0_Op "mkApUpd0#" GenPrimOp with out_of_line = True -primop NewBCOOp "newBCO#" GenPrimOp - ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) - { @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The +primop NewBCOOp "newBCO2#" GenPrimOp + Int8# -> ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) + { @'newBCO2#' is_case_cont instrs lits ptrs arity bitmap@ creates a new bytecode object. The resulting object encodes a function of the given arity with the instructions encoded in @instrs@, and a static reference table usage bitmap given by - @bitmap@. } + @bitmap@. The @is_case_cont@ boolean indicates whether the BCO is a case + continuation (see Note [Case continuation BCOs]) } with effect = ReadWriteEffect out_of_line = True ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -85,7 +85,7 @@ bcoFreeNames :: UnlinkedBCO -> UniqDSet Name bcoFreeNames bco = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] where - bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs _) = unionManyUniqDSets ( mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] : mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] : @@ -236,7 +236,8 @@ assembleBCO platform , protoBCOInstrs = instrs , protoBCOBitmap = bitmap , protoBCOBitmapSize = bsize - , protoBCOArity = arity }) = do + , protoBCOArity = arity + , protoBCOIsCaseCont = isCC }) = do -- pass 1: collect up the offsets of the local labels. let initial_offset = 0 @@ -266,7 +267,7 @@ assembleBCO platform let !insns_arr = mkBCOByteArray $ final_isn_array !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap - ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array) + ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array) isCC -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -53,7 +53,8 @@ data ProtoBCO a -- what the BCO came from, for debugging only protoBCOExpr :: Either [CgStgAlt] CgStgRhs, -- malloc'd pointers - protoBCOFFIs :: [FFIInfo] + protoBCOFFIs :: [FFIInfo], + protoBCOIsCaseCont :: !Bool -- See Note [Case continuation BCOs] } -- | A local block label (e.g. identifying a case alternative). ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -59,7 +59,7 @@ linkBCO -> UnlinkedBCO -> IO ResolvedBCO linkBCO interp pkgs_loaded le bco_ix - (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do + (UnlinkedBCO _ arity insns bitmap lits0 ptrs0 isCC) = do -- fromIntegral Word -> Word64 should be a no op if Word is Word64 -- otherwise it will result in a cast to longlong on 32bit systems. (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0) @@ -69,7 +69,7 @@ linkBCO interp pkgs_loaded le bco_ix insns bitmap (mkBCOByteArray lits') - (addListToSS emptySS ptrs)) + (addListToSS emptySS ptrs) isCC) lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word lookupLiteral interp pkgs_loaded le ptr = case ptr of ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -167,14 +167,108 @@ newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable) newtype AddrPtr = AddrPtr (RemotePtr ()) deriving (NFData) +{- +-------------------------------------------------------------------------------- +-- * Byte Code Objects (BCOs) +-------------------------------------------------------------------------------- + +Note [Case continuation BCOs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A stack with a BCO stack frame at the top looks like: + + (an StgBCO) + | ... | +---> +---------[1]--+ + +------------------+ | | info_tbl_ptr | ------+ + | OTHER FRAME | | +--------------+ | + +------------------+ | | StgArrBytes* | <--- the byte code + | ... | | +--------------+ | + +------------------+ | | ... | | + | fvs1 | | | + +------------------+ | | + | ... | | (StgInfoTable) | + +------------------+ | +----------+ <---+ + | args1 | | | ... | + +------------------+ | +----------+ + | some StgBCO* | -----+ | type=BCO | + +------------------+ +----------+ + Sp | stg_apply_interp | -----+ | ... | + +------------------+ | + | + | (StgInfoTable) + +----> +--------------+ + | ... | + +--------------+ + | type=RET_BCO | + +--------------+ + | ... | + + +The byte code for a BCO heap object makes use of arguments and free variables +which can typically be found within the BCO stack frame. In the code, these +variables are referenced via a statically known stack offset (tracked using +`BCEnv` in `StgToByteCode`). + +However, in /case continuation/ BCOs, the code may additionally refer to free +variables that are outside of that BCO's stack frame -- some free variables of a +case continuation BCO may only be found in the stack frame of a parent BCO. + +Yet, references to these out-of-frame variables are also done in terms of stack +offsets. Thus, they rely on the position of /another frame/ to be fixed. (See +Note [PUSH_L underflow] for more information about references to previous +frames and nested BCOs) + +This makes case continuation BCOs special: unlike normal BCOs, case cont BCO +frames cannot be moved on the stack independently from their parent BCOs. + +In order to be able to distinguish them at runtime, the code generator will use +distinct info table pointers for their closures, even though they will have the +same structure on the heap (StgBCO). Specifically: + + - Normal BCOs are always headed by the `stg_BCO_info` pointer. + - Case continuation BCOs are always headed by the `stg_CASE_CONT_BCO_info` pointer. + +A primary reason why we need to distinguish these two cases is to know where we +can insert a debugger step-out frame (`stg_stop_after_ret_frame`). In +particular, because case cont BCOs may refer to the parent frame, we must not +insert step-out frames between a case cont BCO and its parent. + +As an example, consider the following, where `y` is free in the case alternatives: + + f x y = case x of + True -> y - 1 + False -> y + 1 :: Int + +While interpreting f, the args x and y will be on the stack as part of f's frame. +In its body, a case continuation BCO is pushed (PUSH_ALTS) and then `x` is +entered to be evaluated. Upon entering `x`, the stack would look something like: + + <f arg 2> + <f arg 1> + ... + <Case continuation BCO Frame> + +We cannot insert a step out frame in between: + + + <f arg 2> + <f arg 1> + ... + <inserted step-out frame> <--- BAD! Breaks stack offsets in the case cont. + <Case continuation BCO Frame> + +Instead, we must traverse until the parent BCO and insert the step-out frame before it instead. +-} + data UnlinkedBCO = UnlinkedBCO { unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns - unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap + unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns + unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs + unlinkedBCOPtrs :: !(FlatBag BCOPtr), -- ptrs + unlinkedBCOIsCaseCont :: !Bool -- See Note [Case continuation BCOs] } instance NFData UnlinkedBCO where @@ -227,10 +321,11 @@ seqCgBreakInfo CgBreakInfo{..} = rnf cgb_resty instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs pi) = sep [text "BCO", ppr nm, text "with", ppr (sizeFlatBag lits), text "lits", - ppr (sizeFlatBag ptrs), text "ptrs" ] + ppr (sizeFlatBag ptrs), text "ptrs", + ppr pi, text "is_pos_indep"] instance Outputable CgBreakInfo where ppr info = text "CgBreakInfo" <+> ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -253,7 +253,11 @@ mkProtoBCO -> Int -- ^ arity -> WordOff -- ^ bitmap size -> [StgWord] -- ^ bitmap - -> Bool -- ^ True <=> is a return point, rather than a function + -> Bool -- ^ True <=> it's a case continuation, rather than a function + -- Used for + -- (A) Stack check collision and + -- (B) Mark the BCO wrt whether it contains non-local stack + -- references. See Note [Case continuation BCOs]. -> [FFIInfo] -> ProtoBCO Name mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis @@ -264,7 +268,8 @@ mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bit protoBCOBitmapSize = fromIntegral bitmap_size, protoBCOArity = arity, protoBCOExpr = origin, - protoBCOFFIs = ffis + protoBCOFFIs = ffis, + protoBCOIsCaseCont = is_ret } where #if MIN_VERSION_rts(1,0,3) @@ -353,6 +358,9 @@ schemeTopBind (id, rhs) -- Park the resulting BCO in the monad. Also requires the -- name of the variable to which this value was bound, -- so as to give the resulting BCO a name. +-- +-- The resulting ProtoBCO expects the free variables and the function arguments +-- to be in the stack directly before it. schemeR :: [Id] -- Free vars of the RHS, ordered as they -- will appear in the thunk. Empty for -- top-level things, which have no free vars. @@ -391,6 +399,8 @@ schemeR_wrk fvs nm original_body (args, body) -- them unlike constructor fields. szsb_args = map (wordsToBytes platform . idSizeW platform) all_args sum_szsb_args = sum szsb_args + -- Make a stack offset for each argument or free var -- they should + -- appear contiguous in the stack, in order. p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) -- make the arg bitmap @@ -1401,7 +1411,7 @@ Note [unboxed tuple bytecodes and tuple_BCO] tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name tupleBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} + 0{-no arity-} bitmap_size bitmap False{-not alts-} where {- The tuple BCO is never referred to by name, so we can get away @@ -1422,7 +1432,7 @@ tupleBCO platform args_info args = primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name primCallBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} + 0{-no arity-} bitmap_size bitmap False{-not alts-} where {- The primcall BCO is never referred to by name, so we can get away ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -26,12 +26,12 @@ module GHC.Exts -- ** Legacy interface for arrays of arrays module GHC.Internal.ArrayArray, -- * Primitive operations - {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} + {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 10.14", "These symbols should be imported from ghc-internal instead if needed."] #-} Prim.BCO, {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} Prim.mkApUpd0#, {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} - Prim.newBCO#, + IExts.newBCO#, module GHC.Prim, module GHC.Prim.Ext, -- ** Running 'RealWorld' state thread @@ -119,7 +119,7 @@ module GHC.Exts maxTupleSize ) where -import GHC.Internal.Exts +import GHC.Internal.Exts hiding ( newBCO# ) import GHC.Internal.ArrayArray import GHC.Prim hiding ( coerce @@ -132,7 +132,7 @@ import GHC.Prim hiding , isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned# -- deprecated - , BCO, mkApUpd0#, newBCO# + , BCO, mkApUpd0# -- Don't re-export vector FMA instructions , fmaddFloatX4# @@ -256,8 +256,10 @@ import GHC.Prim hiding , minWord8X32# , minWord8X64# ) +import qualified GHC.Internal.Exts as IExts + ( newBCO# ) import qualified GHC.Prim as Prim - ( BCO, mkApUpd0#, newBCO# ) + ( BCO, mkApUpd0# ) import GHC.Prim.Ext ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -624,6 +624,7 @@ data TsoFlags | TsoMarked | TsoSqueezed | TsoAllocLimit + | TsoStopNextBreakpoint | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug deriving (Eq, Show, Generic, Ord) ===================================== libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc ===================================== @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +#if __GLASGOW_HASKELL__ >= 913 + | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w) +#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] ===================================== libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc ===================================== @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +#if __GLASGOW_HASKELL__ >= 913 + | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w) +#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] ===================================== libraries/ghc-heap/tests/parse_tso_flags.hs ===================================== @@ -13,5 +13,6 @@ main = do assertEqual (parseTsoFlags 64) [TsoMarked] assertEqual (parseTsoFlags 128) [TsoSqueezed] assertEqual (parseTsoFlags 256) [TsoAllocLimit] + assertEqual (parseTsoFlags 512) [TsoStopNextBreakpoint] assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx] ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -163,6 +163,9 @@ module GHC.Internal.Exts -- * The maximum tuple size maxTupleSize, + + -- * Interpreter + newBCO# ) where import GHC.Internal.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge#, whereFrom# ) @@ -469,3 +472,18 @@ resizeSmallMutableArray# arr0 szNew a s0 = -- accessible\" by word. considerAccessible :: Bool considerAccessible = True + +-------------------------------------------------------------------------------- +-- Interpreter + +{-| +@'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The +resulting object encodes a function of the given arity with the instructions +encoded in @instrs@, and a static reference table usage bitmap given by +@bitmap@. + +Note: Case continuation BCOs, with non-local stack references, must be +constructed using @'newBCO2#' 1@ instead. See Note [Case continuation BCOs]. +-} +newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) +newBCO# b1 b2 a1 i1 b3 s = newBCO2# (intToInt8# 0#) b1 b2 a1 i1 b3 s ===================================== libraries/ghci/GHCi/CreateBCO.hs ===================================== @@ -87,11 +87,11 @@ linkBCO' arr ResolvedBCO{..} = do literals_barr = barr (getBCOByteArray resolvedBCOLits) PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs + let is_case_cont | resolvedBCOIsCaseCont = intToInt8# 1# + | otherwise = intToInt8# 0# IO $ \s -> case unsafeFreezeArray# marr s of { (# s, arr #) -> - case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io -> - io s - }} + newBCO2# is_case_cont insns_barr literals_barr arr arity# bitmap_barr s } -- we recursively link any sub-BCOs while making the ptrs array ===================================== libraries/ghci/GHCi/Debugger.hs ===================================== @@ -0,0 +1,67 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module GHCi.Debugger + ( + -- * Single step mode + rts_enableStopNextBreakpoint + , rts_enableStopNextBreakpointAll + , rts_disableStopNextBreakpoint + , rts_disableStopNextBreakpointAll + + -- * Stop on exception + , exceptionFlag + + -- * Breakpoint Callback + , BreakpointCallback + , breakPointIOAction + ) where + +import Prelude -- See note [Why do we import Prelude here?] + +import GHC.Base (ThreadId#, Addr#, Int#) +import Foreign.C (CInt) +import Foreign (StablePtr, Ptr) +import GHCi.RemoteTypes (HValue) + +-------------------------------------------------------------------------------- +-- Single step mode + +-- | Enables the single step mode for a specific thread, thus stopping only on +-- breakpoints in that thread. +foreign import ccall unsafe "rts_enableStopNextBreakpoint" + rts_enableStopNextBreakpoint :: ThreadId# -> IO () + +-- | Disables per-thread single-step mode. Note: if global single-step is +-- enabled we stop at all breakpoints regardless of the per-thread flag. +foreign import ccall unsafe "rts_disableStopNextBreakpoint" + rts_disableStopNextBreakpoint :: ThreadId# -> IO () + +-- | Enables the single step mode for all threads, thus stopping at any +-- existing breakpoint. +foreign import ccall unsafe "rts_enableStopNextBreakpointAll" + rts_enableStopNextBreakpointAll :: IO () + +-- | Disables the single step mode for all threads +foreign import ccall unsafe "rts_disableStopNextBreakpointAll" + rts_disableStopNextBreakpointAll :: IO () + +-------------------------------------------------------------------------------- + +foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt + +-------------------------------------------------------------------------------- + +type BreakpointCallback + = Addr# -- pointer to the breakpoint tick module name + -> Addr# -- pointer to the breakpoint tick module unit id + -> Int# -- breakpoint tick index + -> Addr# -- pointer to the breakpoint info module name + -> Addr# -- pointer to the breakpoint info module unit id + -> Int# -- breakpoint info index + -> Bool -- exception? + -> HValue -- the AP_STACK, or exception + -> IO () + +foreign import ccall "&rts_breakpoint_io_action" + breakPointIOAction :: Ptr (StablePtr BreakpointCallback) + ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -45,7 +45,8 @@ data ResolvedBCO resolvedBCOBitmap :: BCOByteArray Word, -- ^ bitmap resolvedBCOLits :: BCOByteArray Word, -- ^ non-ptrs - subword sized entries still take up a full (host) word - resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ^ ptrs + resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr), -- ^ ptrs + resolvedBCOIsCaseCont :: !Bool -- ^ See Note [Case continuation BCOs] } deriving (Generic, Show) @@ -86,7 +87,8 @@ instance Binary ResolvedBCO where put resolvedBCOBitmap put resolvedBCOLits put resolvedBCOPtrs - get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get + put resolvedBCOIsCaseCont + get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get <*> get -- See Note [BCOByteArray serialization] instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP, - UnboxedTuples, LambdaCase #-} + UnboxedTuples, LambdaCase, UnliftedFFITypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -20,6 +20,7 @@ import GHCi.InfoTable #endif import qualified GHC.InfoProv as InfoProv +import GHCi.Debugger import GHCi.FFI import GHCi.Message import GHCi.ObjLink @@ -332,7 +333,7 @@ withBreakAction opts breakMVar statusMVar act stablePtr <- newStablePtr onBreak poke breakPointIOAction stablePtr when (breakOnException opts) $ poke exceptionFlag 1 - when (singleStep opts) $ setStepFlag + when (singleStep opts) rts_enableStopNextBreakpointAll return stablePtr -- Breaking on exceptions is not enabled by default, since it -- might be a bit surprising. The exception flag is turned off @@ -363,7 +364,7 @@ withBreakAction opts breakMVar statusMVar act resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr poke exceptionFlag 0 - resetStepFlag + rts_disableStopNextBreakpointAll freeStablePtr stablePtr resumeStmt @@ -396,28 +397,6 @@ abandonStmt hvref = do _ <- takeMVar resumeStatusMVar return () -foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt -foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt - -setStepFlag :: IO () -setStepFlag = poke stepFlag 1 -resetStepFlag :: IO () -resetStepFlag = poke stepFlag 0 - -type BreakpointCallback - = Addr# -- pointer to the breakpoint tick module name - -> Addr# -- pointer to the breakpoint tick module unit id - -> Int# -- breakpoint tick index - -> Addr# -- pointer to the breakpoint info module name - -> Addr# -- pointer to the breakpoint info module unit id - -> Int# -- breakpoint info index - -> Bool -- exception? - -> HValue -- the AP_STACK, or exception - -> IO () - -foreign import ccall "&rts_breakpoint_io_action" - breakPointIOAction :: Ptr (StablePtr BreakpointCallback) - noBreakStablePtr :: StablePtr BreakpointCallback noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction ===================================== libraries/ghci/ghci.cabal.in ===================================== @@ -60,6 +60,7 @@ library CPP-Options: -DHAVE_INTERNAL_INTERPRETER exposed-modules: GHCi.Run + GHCi.Debugger GHCi.CreateBCO GHCi.ObjLink GHCi.Signals ===================================== rts/Interpreter.c ===================================== @@ -203,14 +203,14 @@ PUSH_L instruction. |---------| | BCO_1 | -<-┐ -|---------| +|---------| | ......... | |---------| | PUSH_L <n> | BCO_N | ->-┘ |---------| Here BCO_N is syntactically nested within the code for BCO_1 and will result -in code that references the prior stack frame of BCO_1 for some of it's local +in code that references the prior stack frame of BCO_1 for some of its local variables. If a stack overflow happens between the creation of the stack frame for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving BCO_1 in place, invalidating a simple offset based reference to the outer stack @@ -243,9 +243,44 @@ allocate_NONUPD (Capability *cap, int n_words) return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } -int rts_stop_next_breakpoint = 0; int rts_stop_on_exception = 0; +/* --------------------------------------------------------------------------- + * Enabling and disabling global single step mode + * ------------------------------------------------------------------------ */ + +/* A global toggle for single-step mode. + * Unlike `TSO_STOP_NEXT_BREAKPOINT`, which sets single-step mode per-thread, + * `rts_stop_next_breakpoint` globally enables single-step mode. If enabled, we + * will stop at the immediate next breakpoint regardless of what thread it is in. */ +int rts_stop_next_breakpoint = 0; + +void rts_enableStopNextBreakpointAll(void) +{ + rts_stop_next_breakpoint = 1; +} + +void rts_disableStopNextBreakpointAll(void) +{ + rts_stop_next_breakpoint = 0; +} + +/* --------------------------------------------------------------------------- + * Enabling and disabling per-thread single step mode + * ------------------------------------------------------------------------ */ + +void rts_enableStopNextBreakpoint(StgPtr tso) +{ + ((StgTSO *)tso)->flags |= TSO_STOP_NEXT_BREAKPOINT; +} + +void rts_disableStopNextBreakpoint(StgPtr tso) +{ + ((StgTSO *)tso)->flags &= ~TSO_STOP_NEXT_BREAKPOINT; +} + +/* -------------------------------------------------------------------------- */ + #if defined(INTERP_STATS) #define N_CODES 128 @@ -508,14 +543,35 @@ interpretBCO (Capability* cap) // // We have a BCO application to perform. Stack looks like: // - // | .... | - // +---------------+ - // | arg1 | - // +---------------+ - // | BCO | - // +---------------+ - // Sp | RET_BCO | - // +---------------+ + // + // (an StgBCO) + // +---> +---------[1]--+ + // | | stg_BCO_info | ------+ + // | +--------------+ | + // | | StgArrBytes* | <--- the byte code + // | ... | | +--------------+ | + // +------------------+ | | ... | | + // | fvs1 | | | + // +------------------+ | | + // | ... | | (StgInfoTable) | + // +------------------+ | +----------+ <---+ + // | args1 | | | ... | + // +------------------+ | +----------+ + // | some StgBCO* | -----+ | type=BCO | + // +------------------+ +----------+ + // Sp | stg_apply_interp | -----+ | ... | + // +------------------+ | + // | + // | (StgInfoTable) + // +----> +--------------+ + // | ... | + // +--------------+ + // | type=RET_BCO | + // +--------------+ + // | ... | + // + // [1] An StgBCO's info table pointer may also be stg_CASE_CONT_BCO_info. + // See Note [Case continuation BCOs]. // else if (SpW(0) == (W_)&stg_apply_interp_info) { obj = UNTAG_CLOSURE((StgClosure *)ReadSpW(1)); @@ -1250,7 +1306,7 @@ run_BCO: int arg8_cc; #endif StgArrBytes *breakPoints; - int returning_from_break; + int returning_from_break, stop_next_breakpoint; // the io action to run at a breakpoint StgClosure *ioAction; @@ -1280,6 +1336,13 @@ run_BCO: returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; + // check whether this thread is set to stop at the immediate next + // breakpoint -- either by the global `rts_stop_next_breakpoint` + // flag, or by the local `TSO_STOP_NEXT_BREAKPOINT` + stop_next_breakpoint = + rts_stop_next_breakpoint || + cap->r.rCurrentTSO->flags & TSO_STOP_NEXT_BREAKPOINT; + #if defined(PROFILING) cap->r.rCCCS = pushCostCentre(cap->r.rCCCS, (CostCentre*)BCO_LIT(arg8_cc)); @@ -1291,20 +1354,20 @@ run_BCO: { breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array); - // 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 + // stop the current thread if either `stop_next_breakpoint` is + // true OR if the ignore count for this particular breakpoint is zero StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index]; - if (rts_stop_next_breakpoint == false && ignore_count > 0) + if (stop_next_breakpoint == false && ignore_count > 0) { // decrement and write back ignore count ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count; } - else if (rts_stop_next_breakpoint == true || ignore_count == 0) + else if (stop_next_breakpoint == true || ignore_count == 0) { // make sure we don't automatically stop at the // next breakpoint - rts_stop_next_breakpoint = false; + rts_stop_next_breakpoint = 0; + cap->r.rCurrentTSO->flags &= ~TSO_STOP_NEXT_BREAKPOINT; // allocate memory for a new AP_STACK, enough to // store the top stack frame plus an @@ -1477,7 +1540,7 @@ run_BCO: // Here we make sure references we push are tagged. // See Note [CBV Functions and the interpreter] in Info.hs - //Safe some memory reads if we already have a tag. + //Save some memory reads if we already have a tag. if(GET_CLOSURE_TAG(tagged_obj) == 0) { StgClosure *obj = UNTAG_CLOSURE(tagged_obj); switch ( get_itbl(obj)->type ) { ===================================== rts/Interpreter.h ===================================== @@ -11,3 +11,8 @@ RTS_PRIVATE Capability *interpretBCO (Capability* cap); void interp_startup ( void ); void interp_shutdown ( void ); + +void rts_enableStopNextBreakpointAll ( void ); +void rts_disableStopNextBreakpointAll ( void ); +void rts_enableStopNextBreakpoint ( StgPtr ); +void rts_disableStopNextBreakpoint ( StgPtr ); ===================================== rts/PrimOps.cmm ===================================== @@ -55,6 +55,7 @@ import CLOSURE stg_AP_STACK_info; import CLOSURE stg_AP_info; import CLOSURE stg_ARR_WORDS_info; import CLOSURE stg_BCO_info; +import CLOSURE stg_CASE_CONT_BCO_info; import CLOSURE stg_C_FINALIZER_LIST_info; import CLOSURE stg_DEAD_WEAK_info; import CLOSURE stg_END_STM_WATCH_QUEUE_closure; @@ -2434,7 +2435,8 @@ stg_deRefStablePtrzh ( P_ sp ) Bytecode object primitives ------------------------------------------------------------------------- */ -stg_newBCOzh ( P_ instrs, +stg_newBCO2zh ( CBool is_case_cont, + P_ instrs, P_ literals, P_ ptrs, W_ arity, @@ -2449,7 +2451,16 @@ stg_newBCOzh ( P_ instrs, bco = Hp - bytes + WDS(1); // No memory barrier necessary as this is a new allocation. - SET_HDR(bco, stg_BCO_info, CCS_MAIN); + if (is_case_cont > 0) { + /* Uses stg_CASE_CONT_BCO_info to construct the BCO frame (rather than stg_BCO_info). + * Case continuations may contain non-local references to parent frames. The distinct info table + * tag allows the RTS to identify such non-local frames. + * See Note [Case continuation BCOs] + */ + SET_HDR(bco, stg_CASE_CONT_BCO_info, CCS_MAIN); + } else { + SET_HDR(bco, stg_BCO_info, CCS_MAIN); + } StgBCO_instrs(bco) = instrs; StgBCO_literals(bco) = literals; ===================================== rts/Printer.c ===================================== @@ -690,6 +690,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) debugBelch("stg_ctoi_V_info" ); } else if (c == (StgWord)&stg_BCO_info) { debugBelch("stg_BCO_info" ); + } else if (c == (StgWord)&stg_CASE_CONT_BCO_info) { + debugBelch("stg_CASE_CONT_BCO_info" ); } else if (c == (StgWord)&stg_apply_interp_info) { debugBelch("stg_apply_interp_info" ); } else if (c == (StgWord)&stg_ret_t_info) { ===================================== rts/RtsSymbols.c ===================================== @@ -639,7 +639,7 @@ extern char **environ; SymI_HasDataProto(stg_copySmallMutableArrayzh) \ SymI_HasDataProto(stg_casSmallArrayzh) \ SymI_HasDataProto(stg_copyArray_barrier) \ - SymI_HasDataProto(stg_newBCOzh) \ + SymI_HasDataProto(stg_newBCO2zh) \ SymI_HasDataProto(stg_newByteArrayzh) \ SymI_HasDataProto(stg_casIntArrayzh) \ SymI_HasDataProto(stg_casInt8Arrayzh) \ @@ -906,7 +906,10 @@ extern char **environ; SymI_HasProto(revertCAFs) \ SymI_HasProto(RtsFlags) \ SymI_NeedsDataProto(rts_breakpoint_io_action) \ - SymI_NeedsDataProto(rts_stop_next_breakpoint) \ + SymI_NeedsDataProto(rts_enableStopNextBreakpointAll) \ + SymI_NeedsDataProto(rts_disableStopNextBreakpointAll) \ + SymI_NeedsDataProto(rts_enableStopNextBreakpoint) \ + SymI_NeedsDataProto(rts_disableStopNextBreakpoint) \ SymI_NeedsDataProto(rts_stop_on_exception) \ SymI_HasProto(stopTimer) \ SymI_HasProto(n_capabilities) \ ===================================== rts/StgMiscClosures.cmm ===================================== @@ -464,6 +464,12 @@ INFO_TABLE_RET( stg_dead_thread, RET_SMALL, /* ---------------------------------------------------------------------------- Entry code for a BCO + + `stg_BCO` and `stg_CASE_CONT_BCO` distinguish between a BCO that refers to + non-local variables in its code (using a stack offset) and those that do not. + Only case-continuation BCOs should use non-local variables. + Otherwise, `stg_BCO` and `stg_CASE_CONT_BCO` behave the same. + See Note [Case continuation BCOs]. ------------------------------------------------------------------------- */ INFO_TABLE_FUN( stg_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) @@ -478,6 +484,15 @@ INFO_TABLE_FUN( stg_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) jump stg_yield_to_interpreter []; } +INFO_TABLE_FUN( stg_CASE_CONT_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) +{ + /* Exactly as for stg_BCO */ + Sp_adj(-2); + Sp(1) = R1; + Sp(0) = stg_apply_interp_info; + jump stg_yield_to_interpreter []; +} + /* ---------------------------------------------------------------------------- Info tables for indirections. ===================================== rts/include/rts/Constants.h ===================================== @@ -328,6 +328,12 @@ */ #define TSO_ALLOC_LIMIT 256 +/* + * Enables step-in mode for this thread -- it will stop at the immediate next + * breakpoint found in this thread. + */ +#define TSO_STOP_NEXT_BREAKPOINT 512 + /* * The number of times we spin in a spin lock before yielding (see * #3758). To tune this value, use the benchmark in #3758: run the ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -180,6 +180,7 @@ RTS_ENTRY(stg_BLOCKING_QUEUE_CLEAN); RTS_ENTRY(stg_BLOCKING_QUEUE_DIRTY); RTS_FUN(stg_BCO); +RTS_FUN(stg_CASE_CONT_BCO); RTS_ENTRY(stg_EVACUATED); RTS_ENTRY(stg_WEAK); RTS_ENTRY(stg_DEAD_WEAK); @@ -577,7 +578,7 @@ RTS_FUN_DECL(stg_deRefWeakzh); RTS_FUN_DECL(stg_runRWzh); -RTS_FUN_DECL(stg_newBCOzh); +RTS_FUN_DECL(stg_newBCO2zh); RTS_FUN_DECL(stg_mkApUpd0zh); RTS_FUN_DECL(stg_retryzh); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/758dc1b797d7e7c07100a64bdbd100… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/758dc1b797d7e7c07100a64bdbd100… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/per-thread-step-in] debugger/rts: Allow toggling step-in per thread
by Rodrigo Mesquita (＠alt-romes) 23 May '25

23 May '25

Rodrigo Mesquita pushed to branch wip/romes/per-thread-step-in at Glasgow Haskell Compiler / GHC Commits: ac7b34fd by Rodrigo Mesquita at 2025-05-23T15:54:43+01:00 debugger/rts: Allow toggling step-in per thread The RTS global flag `rts_stop_next_breakpoint` globally sets the interpreter to stop at the immediate next breakpoint. With this commit, single step mode can additionally be set per thread in the TSO flag (TSO_STOP_NEXT_BREAKPOINT). Being able to toggle "stop at next breakpoint" per thread is an important requirement for implementing "stepping out" of a function in a multi-threaded context. And, more generally, having a per-thread flag for single-stepping paves the way for multi-threaded debugging. That said, when we want to enable "single step" mode for the whole interpreted program we still want to stop at the immediate next breakpoint, whichever thread it belongs to. That's why we also keep the global `rts_stop_next_breakpoint` flag, with `rts_enableStopNextBreakpointAll` and `rts_disableStopNextBreakpointAll` helpers. Preparation for #26042 - - - - - 11 changed files: - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/tests/parse_tso_flags.hs - + libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Interpreter.c - rts/Interpreter.h - rts/RtsSymbols.c - rts/include/rts/Constants.h Changes: ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -624,6 +624,7 @@ data TsoFlags | TsoMarked | TsoSqueezed | TsoAllocLimit + | TsoStopNextBreakpoint | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug deriving (Eq, Show, Generic, Ord) ===================================== libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc ===================================== @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +#if __GLASGOW_HASKELL__ >= 913 + | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w) +#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] ===================================== libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc ===================================== @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +#if __GLASGOW_HASKELL__ >= 913 + | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w) +#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] ===================================== libraries/ghc-heap/tests/parse_tso_flags.hs ===================================== @@ -13,5 +13,6 @@ main = do assertEqual (parseTsoFlags 64) [TsoMarked] assertEqual (parseTsoFlags 128) [TsoSqueezed] assertEqual (parseTsoFlags 256) [TsoAllocLimit] + assertEqual (parseTsoFlags 512) [TsoStopNextBreakpoint] assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx] ===================================== libraries/ghci/GHCi/Debugger.hs ===================================== @@ -0,0 +1,67 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module GHCi.Debugger + ( + -- * Single step mode + rts_enableStopNextBreakpoint + , rts_enableStopNextBreakpointAll + , rts_disableStopNextBreakpoint + , rts_disableStopNextBreakpointAll + + -- * Stop on exception + , exceptionFlag + + -- * Breakpoint Callback + , BreakpointCallback + , breakPointIOAction + ) where + +import Prelude -- See note [Why do we import Prelude here?] + +import GHC.Base (ThreadId#, Addr#, Int#) +import Foreign.C (CInt) +import Foreign (StablePtr, Ptr) +import GHCi.RemoteTypes (HValue) + +-------------------------------------------------------------------------------- +-- Single step mode + +-- | Enables the single step mode for a specific thread, thus stopping only on +-- breakpoints in that thread. +foreign import ccall unsafe "rts_enableStopNextBreakpoint" + rts_enableStopNextBreakpoint :: ThreadId# -> IO () + +-- | Disables per-thread single-step mode. Note: if global single-step is +-- enabled we stop at all breakpoints regardless of the per-thread flag. +foreign import ccall unsafe "rts_disableStopNextBreakpoint" + rts_disableStopNextBreakpoint :: ThreadId# -> IO () + +-- | Enables the single step mode for all threads, thus stopping at any +-- existing breakpoint. +foreign import ccall unsafe "rts_enableStopNextBreakpointAll" + rts_enableStopNextBreakpointAll :: IO () + +-- | Disables the single step mode for all threads +foreign import ccall unsafe "rts_disableStopNextBreakpointAll" + rts_disableStopNextBreakpointAll :: IO () + +-------------------------------------------------------------------------------- + +foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt + +-------------------------------------------------------------------------------- + +type BreakpointCallback + = Addr# -- pointer to the breakpoint tick module name + -> Addr# -- pointer to the breakpoint tick module unit id + -> Int# -- breakpoint tick index + -> Addr# -- pointer to the breakpoint info module name + -> Addr# -- pointer to the breakpoint info module unit id + -> Int# -- breakpoint info index + -> Bool -- exception? + -> HValue -- the AP_STACK, or exception + -> IO () + +foreign import ccall "&rts_breakpoint_io_action" + breakPointIOAction :: Ptr (StablePtr BreakpointCallback) + ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP, - UnboxedTuples, LambdaCase #-} + UnboxedTuples, LambdaCase, UnliftedFFITypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -20,6 +20,7 @@ import GHCi.InfoTable #endif import qualified GHC.InfoProv as InfoProv +import GHCi.Debugger import GHCi.FFI import GHCi.Message import GHCi.ObjLink @@ -332,7 +333,7 @@ withBreakAction opts breakMVar statusMVar act stablePtr <- newStablePtr onBreak poke breakPointIOAction stablePtr when (breakOnException opts) $ poke exceptionFlag 1 - when (singleStep opts) $ setStepFlag + when (singleStep opts) rts_enableStopNextBreakpointAll return stablePtr -- Breaking on exceptions is not enabled by default, since it -- might be a bit surprising. The exception flag is turned off @@ -363,7 +364,7 @@ withBreakAction opts breakMVar statusMVar act resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr poke exceptionFlag 0 - resetStepFlag + rts_disableStopNextBreakpointAll freeStablePtr stablePtr resumeStmt @@ -396,28 +397,6 @@ abandonStmt hvref = do _ <- takeMVar resumeStatusMVar return () -foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt -foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt - -setStepFlag :: IO () -setStepFlag = poke stepFlag 1 -resetStepFlag :: IO () -resetStepFlag = poke stepFlag 0 - -type BreakpointCallback - = Addr# -- pointer to the breakpoint tick module name - -> Addr# -- pointer to the breakpoint tick module unit id - -> Int# -- breakpoint tick index - -> Addr# -- pointer to the breakpoint info module name - -> Addr# -- pointer to the breakpoint info module unit id - -> Int# -- breakpoint info index - -> Bool -- exception? - -> HValue -- the AP_STACK, or exception - -> IO () - -foreign import ccall "&rts_breakpoint_io_action" - breakPointIOAction :: Ptr (StablePtr BreakpointCallback) - noBreakStablePtr :: StablePtr BreakpointCallback noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction ===================================== libraries/ghci/ghci.cabal.in ===================================== @@ -60,6 +60,7 @@ library CPP-Options: -DHAVE_INTERNAL_INTERPRETER exposed-modules: GHCi.Run + GHCi.Debugger GHCi.CreateBCO GHCi.ObjLink GHCi.Signals ===================================== rts/Interpreter.c ===================================== @@ -243,9 +243,44 @@ allocate_NONUPD (Capability *cap, int n_words) return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } -int rts_stop_next_breakpoint = 0; int rts_stop_on_exception = 0; +/* --------------------------------------------------------------------------- + * Enabling and disabling global single step mode + * ------------------------------------------------------------------------ */ + +/* A global toggle for single-step mode. + * Unlike `TSO_STOP_NEXT_BREAKPOINT`, which sets single-step mode per-thread, + * `rts_stop_next_breakpoint` globally enables single-step mode. If enabled, we + * will stop at the immediate next breakpoint regardless of what thread it is in. */ +int rts_stop_next_breakpoint = 0; + +void rts_enableStopNextBreakpointAll(void) +{ + rts_stop_next_breakpoint = 1; +} + +void rts_disableStopNextBreakpointAll(void) +{ + rts_stop_next_breakpoint = 0; +} + +/* --------------------------------------------------------------------------- + * Enabling and disabling per-thread single step mode + * ------------------------------------------------------------------------ */ + +void rts_enableStopNextBreakpoint(StgPtr tso) +{ + ((StgTSO *)tso)->flags |= TSO_STOP_NEXT_BREAKPOINT; +} + +void rts_disableStopNextBreakpoint(StgPtr tso) +{ + ((StgTSO *)tso)->flags &= ~TSO_STOP_NEXT_BREAKPOINT; +} + +/* -------------------------------------------------------------------------- */ + #if defined(INTERP_STATS) #define N_CODES 128 @@ -1250,7 +1285,7 @@ run_BCO: int arg8_cc; #endif StgArrBytes *breakPoints; - int returning_from_break; + int returning_from_break, stop_next_breakpoint; // the io action to run at a breakpoint StgClosure *ioAction; @@ -1280,6 +1315,13 @@ run_BCO: returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; + // check whether this thread is set to stop at the immediate next + // breakpoint -- either by the global `rts_stop_next_breakpoint` + // flag, or by the local `TSO_STOP_NEXT_BREAKPOINT` + stop_next_breakpoint = + rts_stop_next_breakpoint || + cap->r.rCurrentTSO->flags & TSO_STOP_NEXT_BREAKPOINT; + #if defined(PROFILING) cap->r.rCCCS = pushCostCentre(cap->r.rCCCS, (CostCentre*)BCO_LIT(arg8_cc)); @@ -1291,20 +1333,20 @@ run_BCO: { breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array); - // 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 + // stop the current thread if either `stop_next_breakpoint` is + // true OR if the ignore count for this particular breakpoint is zero StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index]; - if (rts_stop_next_breakpoint == false && ignore_count > 0) + if (stop_next_breakpoint == false && ignore_count > 0) { // decrement and write back ignore count ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count; } - else if (rts_stop_next_breakpoint == true || ignore_count == 0) + else if (stop_next_breakpoint == true || ignore_count == 0) { // make sure we don't automatically stop at the // next breakpoint - rts_stop_next_breakpoint = false; + rts_stop_next_breakpoint = 0; + cap->r.rCurrentTSO->flags &= ~TSO_STOP_NEXT_BREAKPOINT; // allocate memory for a new AP_STACK, enough to // store the top stack frame plus an ===================================== rts/Interpreter.h ===================================== @@ -11,3 +11,8 @@ RTS_PRIVATE Capability *interpretBCO (Capability* cap); void interp_startup ( void ); void interp_shutdown ( void ); + +void rts_enableStopNextBreakpointAll ( void ); +void rts_disableStopNextBreakpointAll ( void ); +void rts_enableStopNextBreakpoint ( StgPtr ); +void rts_disableStopNextBreakpoint ( StgPtr ); ===================================== rts/RtsSymbols.c ===================================== @@ -906,7 +906,10 @@ extern char **environ; SymI_HasProto(revertCAFs) \ SymI_HasProto(RtsFlags) \ SymI_NeedsDataProto(rts_breakpoint_io_action) \ - SymI_NeedsDataProto(rts_stop_next_breakpoint) \ + SymI_NeedsDataProto(rts_enableStopNextBreakpointAll) \ + SymI_NeedsDataProto(rts_disableStopNextBreakpointAll) \ + SymI_NeedsDataProto(rts_enableStopNextBreakpoint) \ + SymI_NeedsDataProto(rts_disableStopNextBreakpoint) \ SymI_NeedsDataProto(rts_stop_on_exception) \ SymI_HasProto(stopTimer) \ SymI_HasProto(n_capabilities) \ ===================================== rts/include/rts/Constants.h ===================================== @@ -328,6 +328,12 @@ */ #define TSO_ALLOC_LIMIT 256 +/* + * Enables step-in mode for this thread -- it will stop at the immediate next + * breakpoint found in this thread. + */ +#define TSO_STOP_NEXT_BREAKPOINT 512 + /* * The number of times we spin in a spin lock before yielding (see * #3758). To tune this value, use the benchmark in #3758: run the View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ac7b34fd65dffa77a7c20e81511a6b0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ac7b34fd65dffa77a7c20e81511a6b0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/top-level-bcos-tag] 2 commits: debugger/rts: Allow toggling step-in per thread
by Rodrigo Mesquita (＠alt-romes) 23 May '25

23 May '25

Rodrigo Mesquita pushed to branch wip/romes/top-level-bcos-tag at Glasgow Haskell Compiler / GHC Commits: 36ed4158 by Rodrigo Mesquita at 2025-05-23T14:19:48+01:00 debugger/rts: Allow toggling step-in per thread The RTS global flag `rts_stop_next_breakpoint` globally sets the interpreter to stop at the immediate next breakpoint. With this commit, single step mode can additionally be set per thread in the TSO flag (TSO_STOP_NEXT_BREAKPOINT). Being able to toggle "stop at next breakpoint" per thread is an important requirement for implementing "stepping out" of a function in a multi-threaded context. And, more generally, having a per-thread flag for single-stepping paves the way for multi-threaded debugging. That said, when we want to enable "single step" mode for the whole interpreted program we still want to stop at the immediate next breakpoint, whichever thread it belongs to. That's why we also keep the global `rts_stop_next_breakpoint` flag, with `rts_enableStopNextBreakpointAll` and `rts_disableStopNextBreakpointAll` helpers. Preparation for #26042 - - - - - 758dc1b7 by Rodrigo Mesquita at 2025-05-23T15:23:39+01:00 rts: Case continuation BCOs This commit introduces the `stg_CASE_CONT_BCO` info table, which is identical to `stg_BCO` and shares the same closure type (== BCO). It changes the bytecode generator to always use `stg_CASE_CONT_BCO_info` when constructing case continuation BCOs, and remain using `stg_BCO` otherwise. This allows us to distinguish at runtime case continuation BCOs from other BCOs. In particular, this is relevant because, unlike other BCOs, the code of a case continuation BCO may refer to variables in its parent's stack frame (ie non-local variables), and therefore its frame position on the stack cannot be changed in isolation. The full motivation and details are in Note [Case continuation BCOs]. Towards #26042 - - - - - 25 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/StgToByteCode.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghci/GHCi/CreateBCO.hs - + libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/ResolvedBCO.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Interpreter.c - rts/Interpreter.h - rts/PrimOps.cmm - rts/Printer.c - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/rts/Constants.h - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3872,12 +3872,13 @@ primop MkApUpd0_Op "mkApUpd0#" GenPrimOp with out_of_line = True -primop NewBCOOp "newBCO#" GenPrimOp - ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) - { @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The +primop NewBCOOp "newBCO2#" GenPrimOp + Int8# -> ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) + { @'newBCO2#' is_case_cont instrs lits ptrs arity bitmap@ creates a new bytecode object. The resulting object encodes a function of the given arity with the instructions encoded in @instrs@, and a static reference table usage bitmap given by - @bitmap@. } + @bitmap@. The @is_case_cont@ boolean indicates whether the BCO is a case + continuation (see Note [Case continuation BCOs]) } with effect = ReadWriteEffect out_of_line = True ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -85,7 +85,7 @@ bcoFreeNames :: UnlinkedBCO -> UniqDSet Name bcoFreeNames bco = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] where - bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs _) = unionManyUniqDSets ( mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] : mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] : @@ -236,7 +236,8 @@ assembleBCO platform , protoBCOInstrs = instrs , protoBCOBitmap = bitmap , protoBCOBitmapSize = bsize - , protoBCOArity = arity }) = do + , protoBCOArity = arity + , protoBCOIsCaseCont = isCC }) = do -- pass 1: collect up the offsets of the local labels. let initial_offset = 0 @@ -266,7 +267,7 @@ assembleBCO platform let !insns_arr = mkBCOByteArray $ final_isn_array !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap - ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array) + ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array) isCC -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -53,7 +53,8 @@ data ProtoBCO a -- what the BCO came from, for debugging only protoBCOExpr :: Either [CgStgAlt] CgStgRhs, -- malloc'd pointers - protoBCOFFIs :: [FFIInfo] + protoBCOFFIs :: [FFIInfo], + protoBCOIsCaseCont :: !Bool -- See Note [Case continuation BCOs] } -- | A local block label (e.g. identifying a case alternative). ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -59,7 +59,7 @@ linkBCO -> UnlinkedBCO -> IO ResolvedBCO linkBCO interp pkgs_loaded le bco_ix - (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do + (UnlinkedBCO _ arity insns bitmap lits0 ptrs0 isCC) = do -- fromIntegral Word -> Word64 should be a no op if Word is Word64 -- otherwise it will result in a cast to longlong on 32bit systems. (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0) @@ -69,7 +69,7 @@ linkBCO interp pkgs_loaded le bco_ix insns bitmap (mkBCOByteArray lits') - (addListToSS emptySS ptrs)) + (addListToSS emptySS ptrs) isCC) lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word lookupLiteral interp pkgs_loaded le ptr = case ptr of ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -167,14 +167,108 @@ newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable) newtype AddrPtr = AddrPtr (RemotePtr ()) deriving (NFData) +{- +-------------------------------------------------------------------------------- +-- * Byte Code Objects (BCOs) +-------------------------------------------------------------------------------- + +Note [Case continuation BCOs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A stack with a BCO stack frame at the top looks like: + + (an StgBCO) + | ... | +---> +---------[1]--+ + +------------------+ | | info_tbl_ptr | ------+ + | OTHER FRAME | | +--------------+ | + +------------------+ | | StgArrBytes* | <--- the byte code + | ... | | +--------------+ | + +------------------+ | | ... | | + | fvs1 | | | + +------------------+ | | + | ... | | (StgInfoTable) | + +------------------+ | +----------+ <---+ + | args1 | | | ... | + +------------------+ | +----------+ + | some StgBCO* | -----+ | type=BCO | + +------------------+ +----------+ + Sp | stg_apply_interp | -----+ | ... | + +------------------+ | + | + | (StgInfoTable) + +----> +--------------+ + | ... | + +--------------+ + | type=RET_BCO | + +--------------+ + | ... | + + +The byte code for a BCO heap object makes use of arguments and free variables +which can typically be found within the BCO stack frame. In the code, these +variables are referenced via a statically known stack offset (tracked using +`BCEnv` in `StgToByteCode`). + +However, in /case continuation/ BCOs, the code may additionally refer to free +variables that are outside of that BCO's stack frame -- some free variables of a +case continuation BCO may only be found in the stack frame of a parent BCO. + +Yet, references to these out-of-frame variables are also done in terms of stack +offsets. Thus, they rely on the position of /another frame/ to be fixed. (See +Note [PUSH_L underflow] for more information about references to previous +frames and nested BCOs) + +This makes case continuation BCOs special: unlike normal BCOs, case cont BCO +frames cannot be moved on the stack independently from their parent BCOs. + +In order to be able to distinguish them at runtime, the code generator will use +distinct info table pointers for their closures, even though they will have the +same structure on the heap (StgBCO). Specifically: + + - Normal BCOs are always headed by the `stg_BCO_info` pointer. + - Case continuation BCOs are always headed by the `stg_CASE_CONT_BCO_info` pointer. + +A primary reason why we need to distinguish these two cases is to know where we +can insert a debugger step-out frame (`stg_stop_after_ret_frame`). In +particular, because case cont BCOs may refer to the parent frame, we must not +insert step-out frames between a case cont BCO and its parent. + +As an example, consider the following, where `y` is free in the case alternatives: + + f x y = case x of + True -> y - 1 + False -> y + 1 :: Int + +While interpreting f, the args x and y will be on the stack as part of f's frame. +In its body, a case continuation BCO is pushed (PUSH_ALTS) and then `x` is +entered to be evaluated. Upon entering `x`, the stack would look something like: + + <f arg 2> + <f arg 1> + ... + <Case continuation BCO Frame> + +We cannot insert a step out frame in between: + + + <f arg 2> + <f arg 1> + ... + <inserted step-out frame> <--- BAD! Breaks stack offsets in the case cont. + <Case continuation BCO Frame> + +Instead, we must traverse until the parent BCO and insert the step-out frame before it instead. +-} + data UnlinkedBCO = UnlinkedBCO { unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns - unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap + unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns + unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs + unlinkedBCOPtrs :: !(FlatBag BCOPtr), -- ptrs + unlinkedBCOIsCaseCont :: !Bool -- See Note [Case continuation BCOs] } instance NFData UnlinkedBCO where @@ -227,10 +321,11 @@ seqCgBreakInfo CgBreakInfo{..} = rnf cgb_resty instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs pi) = sep [text "BCO", ppr nm, text "with", ppr (sizeFlatBag lits), text "lits", - ppr (sizeFlatBag ptrs), text "ptrs" ] + ppr (sizeFlatBag ptrs), text "ptrs", + ppr pi, text "is_pos_indep"] instance Outputable CgBreakInfo where ppr info = text "CgBreakInfo" <+> ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -253,7 +253,11 @@ mkProtoBCO -> Int -- ^ arity -> WordOff -- ^ bitmap size -> [StgWord] -- ^ bitmap - -> Bool -- ^ True <=> is a return point, rather than a function + -> Bool -- ^ True <=> it's a case continuation, rather than a function + -- Used for + -- (A) Stack check collision and + -- (B) Mark the BCO wrt whether it contains non-local stack + -- references. See Note [Case continuation BCOs]. -> [FFIInfo] -> ProtoBCO Name mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis @@ -264,7 +268,8 @@ mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bit protoBCOBitmapSize = fromIntegral bitmap_size, protoBCOArity = arity, protoBCOExpr = origin, - protoBCOFFIs = ffis + protoBCOFFIs = ffis, + protoBCOIsCaseCont = is_ret } where #if MIN_VERSION_rts(1,0,3) @@ -353,6 +358,9 @@ schemeTopBind (id, rhs) -- Park the resulting BCO in the monad. Also requires the -- name of the variable to which this value was bound, -- so as to give the resulting BCO a name. +-- +-- The resulting ProtoBCO expects the free variables and the function arguments +-- to be in the stack directly before it. schemeR :: [Id] -- Free vars of the RHS, ordered as they -- will appear in the thunk. Empty for -- top-level things, which have no free vars. @@ -391,6 +399,8 @@ schemeR_wrk fvs nm original_body (args, body) -- them unlike constructor fields. szsb_args = map (wordsToBytes platform . idSizeW platform) all_args sum_szsb_args = sum szsb_args + -- Make a stack offset for each argument or free var -- they should + -- appear contiguous in the stack, in order. p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) -- make the arg bitmap @@ -1401,7 +1411,7 @@ Note [unboxed tuple bytecodes and tuple_BCO] tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name tupleBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} + 0{-no arity-} bitmap_size bitmap False{-not alts-} where {- The tuple BCO is never referred to by name, so we can get away @@ -1422,7 +1432,7 @@ tupleBCO platform args_info args = primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name primCallBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} + 0{-no arity-} bitmap_size bitmap False{-not alts-} where {- The primcall BCO is never referred to by name, so we can get away ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -26,12 +26,12 @@ module GHC.Exts -- ** Legacy interface for arrays of arrays module GHC.Internal.ArrayArray, -- * Primitive operations - {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} + {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 10.14", "These symbols should be imported from ghc-internal instead if needed."] #-} Prim.BCO, {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} Prim.mkApUpd0#, {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} - Prim.newBCO#, + IExts.newBCO#, module GHC.Prim, module GHC.Prim.Ext, -- ** Running 'RealWorld' state thread @@ -119,7 +119,7 @@ module GHC.Exts maxTupleSize ) where -import GHC.Internal.Exts +import GHC.Internal.Exts hiding ( newBCO# ) import GHC.Internal.ArrayArray import GHC.Prim hiding ( coerce @@ -132,7 +132,7 @@ import GHC.Prim hiding , isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned# -- deprecated - , BCO, mkApUpd0#, newBCO# + , BCO, mkApUpd0# -- Don't re-export vector FMA instructions , fmaddFloatX4# @@ -256,8 +256,10 @@ import GHC.Prim hiding , minWord8X32# , minWord8X64# ) +import qualified GHC.Internal.Exts as IExts + ( newBCO# ) import qualified GHC.Prim as Prim - ( BCO, mkApUpd0#, newBCO# ) + ( BCO, mkApUpd0# ) import GHC.Prim.Ext ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -624,6 +624,7 @@ data TsoFlags | TsoMarked | TsoSqueezed | TsoAllocLimit + | TsoStopNextBreakpoint | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug deriving (Eq, Show, Generic, Ord) ===================================== libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc ===================================== @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +#if __GLASGOW_HASKELL__ >= 913 + | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w) +#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] ===================================== libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc ===================================== @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +#if __GLASGOW_HASKELL__ >= 913 + | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w) +#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] ===================================== libraries/ghc-heap/tests/parse_tso_flags.hs ===================================== @@ -13,5 +13,6 @@ main = do assertEqual (parseTsoFlags 64) [TsoMarked] assertEqual (parseTsoFlags 128) [TsoSqueezed] assertEqual (parseTsoFlags 256) [TsoAllocLimit] + assertEqual (parseTsoFlags 512) [TsoStopNextBreakpoint] assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx] ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -163,6 +163,9 @@ module GHC.Internal.Exts -- * The maximum tuple size maxTupleSize, + + -- * Interpreter + newBCO# ) where import GHC.Internal.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge#, whereFrom# ) @@ -469,3 +472,18 @@ resizeSmallMutableArray# arr0 szNew a s0 = -- accessible\" by word. considerAccessible :: Bool considerAccessible = True + +-------------------------------------------------------------------------------- +-- Interpreter + +{-| +@'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The +resulting object encodes a function of the given arity with the instructions +encoded in @instrs@, and a static reference table usage bitmap given by +@bitmap@. + +Note: Case continuation BCOs, with non-local stack references, must be +constructed using @'newBCO2#' 1@ instead. See Note [Case continuation BCOs]. +-} +newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) +newBCO# b1 b2 a1 i1 b3 s = newBCO2# (intToInt8# 0#) b1 b2 a1 i1 b3 s ===================================== libraries/ghci/GHCi/CreateBCO.hs ===================================== @@ -87,11 +87,11 @@ linkBCO' arr ResolvedBCO{..} = do literals_barr = barr (getBCOByteArray resolvedBCOLits) PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs + let is_case_cont | resolvedBCOIsCaseCont = intToInt8# 1# + | otherwise = intToInt8# 0# IO $ \s -> case unsafeFreezeArray# marr s of { (# s, arr #) -> - case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io -> - io s - }} + newBCO2# is_case_cont insns_barr literals_barr arr arity# bitmap_barr s } -- we recursively link any sub-BCOs while making the ptrs array ===================================== libraries/ghci/GHCi/Debugger.hs ===================================== @@ -0,0 +1,67 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module GHCi.Debugger + ( + -- * Single step mode + rts_enableStopNextBreakpoint + , rts_enableStopNextBreakpointAll + , rts_disableStopNextBreakpoint + , rts_disableStopNextBreakpointAll + + -- * Stop on exception + , exceptionFlag + + -- * Breakpoint Callback + , BreakpointCallback + , breakPointIOAction + ) where + +import Prelude -- See note [Why do we import Prelude here?] + +import GHC.Base (ThreadId#, Addr#, Int#) +import Foreign.C (CInt) +import Foreign (StablePtr, Ptr) +import GHCi.RemoteTypes (HValue) + +-------------------------------------------------------------------------------- +-- Single step mode + +-- | Enables the single step mode for a specific thread, thus stopping only on +-- breakpoints in that thread. +foreign import ccall unsafe "rts_enableStopNextBreakpoint" + rts_enableStopNextBreakpoint :: ThreadId# -> IO () + +-- | Disables per-thread single-step mode. Note: if global single-step is +-- enabled we stop at all breakpoints regardless of the per-thread flag. +foreign import ccall unsafe "rts_disableStopNextBreakpoint" + rts_disableStopNextBreakpoint :: ThreadId# -> IO () + +-- | Enables the single step mode for all threads, thus stopping at any +-- existing breakpoint. +foreign import ccall unsafe "rts_enableStopNextBreakpointAll" + rts_enableStopNextBreakpointAll :: IO () + +-- | Disables the single step mode for all threads +foreign import ccall unsafe "rts_disableStopNextBreakpointAll" + rts_disableStopNextBreakpointAll :: IO () + +-------------------------------------------------------------------------------- + +foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt + +-------------------------------------------------------------------------------- + +type BreakpointCallback + = Addr# -- pointer to the breakpoint tick module name + -> Addr# -- pointer to the breakpoint tick module unit id + -> Int# -- breakpoint tick index + -> Addr# -- pointer to the breakpoint info module name + -> Addr# -- pointer to the breakpoint info module unit id + -> Int# -- breakpoint info index + -> Bool -- exception? + -> HValue -- the AP_STACK, or exception + -> IO () + +foreign import ccall "&rts_breakpoint_io_action" + breakPointIOAction :: Ptr (StablePtr BreakpointCallback) + ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -45,7 +45,8 @@ data ResolvedBCO resolvedBCOBitmap :: BCOByteArray Word, -- ^ bitmap resolvedBCOLits :: BCOByteArray Word, -- ^ non-ptrs - subword sized entries still take up a full (host) word - resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ^ ptrs + resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr), -- ^ ptrs + resolvedBCOIsCaseCont :: !Bool -- ^ See Note [Case continuation BCOs] } deriving (Generic, Show) @@ -86,7 +87,8 @@ instance Binary ResolvedBCO where put resolvedBCOBitmap put resolvedBCOLits put resolvedBCOPtrs - get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get + put resolvedBCOIsCaseCont + get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get <*> get -- See Note [BCOByteArray serialization] instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP, - UnboxedTuples, LambdaCase #-} + UnboxedTuples, LambdaCase, UnliftedFFITypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -20,6 +20,7 @@ import GHCi.InfoTable #endif import qualified GHC.InfoProv as InfoProv +import GHCi.Debugger import GHCi.FFI import GHCi.Message import GHCi.ObjLink @@ -332,7 +333,7 @@ withBreakAction opts breakMVar statusMVar act stablePtr <- newStablePtr onBreak poke breakPointIOAction stablePtr when (breakOnException opts) $ poke exceptionFlag 1 - when (singleStep opts) $ setStepFlag + when (singleStep opts) rts_enableStopNextBreakpointAll return stablePtr -- Breaking on exceptions is not enabled by default, since it -- might be a bit surprising. The exception flag is turned off @@ -363,7 +364,7 @@ withBreakAction opts breakMVar statusMVar act resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr poke exceptionFlag 0 - resetStepFlag + rts_disableStopNextBreakpointAll freeStablePtr stablePtr resumeStmt @@ -396,28 +397,6 @@ abandonStmt hvref = do _ <- takeMVar resumeStatusMVar return () -foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt -foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt - -setStepFlag :: IO () -setStepFlag = poke stepFlag 1 -resetStepFlag :: IO () -resetStepFlag = poke stepFlag 0 - -type BreakpointCallback - = Addr# -- pointer to the breakpoint tick module name - -> Addr# -- pointer to the breakpoint tick module unit id - -> Int# -- breakpoint tick index - -> Addr# -- pointer to the breakpoint info module name - -> Addr# -- pointer to the breakpoint info module unit id - -> Int# -- breakpoint info index - -> Bool -- exception? - -> HValue -- the AP_STACK, or exception - -> IO () - -foreign import ccall "&rts_breakpoint_io_action" - breakPointIOAction :: Ptr (StablePtr BreakpointCallback) - noBreakStablePtr :: StablePtr BreakpointCallback noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction ===================================== libraries/ghci/ghci.cabal.in ===================================== @@ -60,6 +60,7 @@ library CPP-Options: -DHAVE_INTERNAL_INTERPRETER exposed-modules: GHCi.Run + GHCi.Debugger GHCi.CreateBCO GHCi.ObjLink GHCi.Signals ===================================== rts/Interpreter.c ===================================== @@ -203,14 +203,14 @@ PUSH_L instruction. |---------| | BCO_1 | -<-┐ -|---------| +|---------| | ......... | |---------| | PUSH_L <n> | BCO_N | ->-┘ |---------| Here BCO_N is syntactically nested within the code for BCO_1 and will result -in code that references the prior stack frame of BCO_1 for some of it's local +in code that references the prior stack frame of BCO_1 for some of its local variables. If a stack overflow happens between the creation of the stack frame for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving BCO_1 in place, invalidating a simple offset based reference to the outer stack @@ -243,9 +243,44 @@ allocate_NONUPD (Capability *cap, int n_words) return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } -int rts_stop_next_breakpoint = 0; int rts_stop_on_exception = 0; +/* --------------------------------------------------------------------------- + * Enabling and disabling global single step mode + * ------------------------------------------------------------------------ */ + +/* A global toggle for single-step mode. + * Unlike `TSO_STOP_NEXT_BREAKPOINT`, which sets single-step mode per-thread, + * `rts_stop_next_breakpoint` globally enables single-step mode. If enabled, we + * will stop at the immediate next breakpoint regardless of what thread it is in. */ +int rts_stop_next_breakpoint = 0; + +void rts_enableStopNextBreakpointAll(void) +{ + rts_stop_next_breakpoint = 1; +} + +void rts_disableStopNextBreakpointAll(void) +{ + rts_stop_next_breakpoint = 0; +} + +/* --------------------------------------------------------------------------- + * Enabling and disabling per-thread single step mode + * ------------------------------------------------------------------------ */ + +void rts_enableStopNextBreakpoint(StgPtr tso) +{ + ((StgTSO *)tso)->flags |= TSO_STOP_NEXT_BREAKPOINT; +} + +void rts_disableStopNextBreakpoint(StgPtr tso) +{ + ((StgTSO *)tso)->flags &= ~TSO_STOP_NEXT_BREAKPOINT; +} + +/* -------------------------------------------------------------------------- */ + #if defined(INTERP_STATS) #define N_CODES 128 @@ -508,14 +543,35 @@ interpretBCO (Capability* cap) // // We have a BCO application to perform. Stack looks like: // - // | .... | - // +---------------+ - // | arg1 | - // +---------------+ - // | BCO | - // +---------------+ - // Sp | RET_BCO | - // +---------------+ + // + // (an StgBCO) + // +---> +---------[1]--+ + // | | stg_BCO_info | ------+ + // | +--------------+ | + // | | StgArrBytes* | <--- the byte code + // | ... | | +--------------+ | + // +------------------+ | | ... | | + // | fvs1 | | | + // +------------------+ | | + // | ... | | (StgInfoTable) | + // +------------------+ | +----------+ <---+ + // | args1 | | | ... | + // +------------------+ | +----------+ + // | some StgBCO* | -----+ | type=BCO | + // +------------------+ +----------+ + // Sp | stg_apply_interp | -----+ | ... | + // +------------------+ | + // | + // | (StgInfoTable) + // +----> +--------------+ + // | ... | + // +--------------+ + // | type=RET_BCO | + // +--------------+ + // | ... | + // + // [1] An StgBCO's info table pointer may also be stg_CASE_CONT_BCO_info. + // See Note [Case continuation BCOs]. // else if (SpW(0) == (W_)&stg_apply_interp_info) { obj = UNTAG_CLOSURE((StgClosure *)ReadSpW(1)); @@ -1250,7 +1306,7 @@ run_BCO: int arg8_cc; #endif StgArrBytes *breakPoints; - int returning_from_break; + int returning_from_break, stop_next_breakpoint; // the io action to run at a breakpoint StgClosure *ioAction; @@ -1280,6 +1336,13 @@ run_BCO: returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; + // check whether this thread is set to stop at the immediate next + // breakpoint -- either by the global `rts_stop_next_breakpoint` + // flag, or by the local `TSO_STOP_NEXT_BREAKPOINT` + stop_next_breakpoint = + rts_stop_next_breakpoint || + cap->r.rCurrentTSO->flags & TSO_STOP_NEXT_BREAKPOINT; + #if defined(PROFILING) cap->r.rCCCS = pushCostCentre(cap->r.rCCCS, (CostCentre*)BCO_LIT(arg8_cc)); @@ -1291,20 +1354,20 @@ run_BCO: { breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array); - // 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 + // stop the current thread if either `stop_next_breakpoint` is + // true OR if the ignore count for this particular breakpoint is zero StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index]; - if (rts_stop_next_breakpoint == false && ignore_count > 0) + if (stop_next_breakpoint == false && ignore_count > 0) { // decrement and write back ignore count ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count; } - else if (rts_stop_next_breakpoint == true || ignore_count == 0) + else if (stop_next_breakpoint == true || ignore_count == 0) { // make sure we don't automatically stop at the // next breakpoint - rts_stop_next_breakpoint = false; + rts_stop_next_breakpoint = 0; + cap->r.rCurrentTSO->flags &= ~TSO_STOP_NEXT_BREAKPOINT; // allocate memory for a new AP_STACK, enough to // store the top stack frame plus an @@ -1477,7 +1540,7 @@ run_BCO: // Here we make sure references we push are tagged. // See Note [CBV Functions and the interpreter] in Info.hs - //Safe some memory reads if we already have a tag. + //Save some memory reads if we already have a tag. if(GET_CLOSURE_TAG(tagged_obj) == 0) { StgClosure *obj = UNTAG_CLOSURE(tagged_obj); switch ( get_itbl(obj)->type ) { ===================================== rts/Interpreter.h ===================================== @@ -11,3 +11,8 @@ RTS_PRIVATE Capability *interpretBCO (Capability* cap); void interp_startup ( void ); void interp_shutdown ( void ); + +void rts_enableStopNextBreakpointAll ( void ); +void rts_disableStopNextBreakpointAll ( void ); +void rts_enableStopNextBreakpoint ( StgPtr ); +void rts_disableStopNextBreakpoint ( StgPtr ); ===================================== rts/PrimOps.cmm ===================================== @@ -55,6 +55,7 @@ import CLOSURE stg_AP_STACK_info; import CLOSURE stg_AP_info; import CLOSURE stg_ARR_WORDS_info; import CLOSURE stg_BCO_info; +import CLOSURE stg_CASE_CONT_BCO_info; import CLOSURE stg_C_FINALIZER_LIST_info; import CLOSURE stg_DEAD_WEAK_info; import CLOSURE stg_END_STM_WATCH_QUEUE_closure; @@ -2434,7 +2435,8 @@ stg_deRefStablePtrzh ( P_ sp ) Bytecode object primitives ------------------------------------------------------------------------- */ -stg_newBCOzh ( P_ instrs, +stg_newBCO2zh ( CBool is_case_cont, + P_ instrs, P_ literals, P_ ptrs, W_ arity, @@ -2449,7 +2451,16 @@ stg_newBCOzh ( P_ instrs, bco = Hp - bytes + WDS(1); // No memory barrier necessary as this is a new allocation. - SET_HDR(bco, stg_BCO_info, CCS_MAIN); + if (is_case_cont > 0) { + /* Uses stg_CASE_CONT_BCO_info to construct the BCO frame (rather than stg_BCO_info). + * Case continuations may contain non-local references to parent frames. The distinct info table + * tag allows the RTS to identify such non-local frames. + * See Note [Case continuation BCOs] + */ + SET_HDR(bco, stg_CASE_CONT_BCO_info, CCS_MAIN); + } else { + SET_HDR(bco, stg_BCO_info, CCS_MAIN); + } StgBCO_instrs(bco) = instrs; StgBCO_literals(bco) = literals; ===================================== rts/Printer.c ===================================== @@ -690,6 +690,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) debugBelch("stg_ctoi_V_info" ); } else if (c == (StgWord)&stg_BCO_info) { debugBelch("stg_BCO_info" ); + } else if (c == (StgWord)&stg_CASE_CONT_BCO_info) { + debugBelch("stg_CASE_CONT_BCO_info" ); } else if (c == (StgWord)&stg_apply_interp_info) { debugBelch("stg_apply_interp_info" ); } else if (c == (StgWord)&stg_ret_t_info) { ===================================== rts/RtsSymbols.c ===================================== @@ -639,7 +639,7 @@ extern char **environ; SymI_HasDataProto(stg_copySmallMutableArrayzh) \ SymI_HasDataProto(stg_casSmallArrayzh) \ SymI_HasDataProto(stg_copyArray_barrier) \ - SymI_HasDataProto(stg_newBCOzh) \ + SymI_HasDataProto(stg_newBCO2zh) \ SymI_HasDataProto(stg_newByteArrayzh) \ SymI_HasDataProto(stg_casIntArrayzh) \ SymI_HasDataProto(stg_casInt8Arrayzh) \ @@ -906,7 +906,8 @@ extern char **environ; SymI_HasProto(revertCAFs) \ SymI_HasProto(RtsFlags) \ SymI_NeedsDataProto(rts_breakpoint_io_action) \ - SymI_NeedsDataProto(rts_stop_next_breakpoint) \ + SymI_NeedsDataProto(rts_enableStopNextBreakpointAll) \ + SymI_NeedsDataProto(rts_disableStopNextBreakpointAll) \ SymI_NeedsDataProto(rts_stop_on_exception) \ SymI_HasProto(stopTimer) \ SymI_HasProto(n_capabilities) \ ===================================== rts/StgMiscClosures.cmm ===================================== @@ -464,6 +464,12 @@ INFO_TABLE_RET( stg_dead_thread, RET_SMALL, /* ---------------------------------------------------------------------------- Entry code for a BCO + + `stg_BCO` and `stg_CASE_CONT_BCO` distinguish between a BCO that refers to + non-local variables in its code (using a stack offset) and those that do not. + Only case-continuation BCOs should use non-local variables. + Otherwise, `stg_BCO` and `stg_CASE_CONT_BCO` behave the same. + See Note [Case continuation BCOs]. ------------------------------------------------------------------------- */ INFO_TABLE_FUN( stg_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) @@ -478,6 +484,15 @@ INFO_TABLE_FUN( stg_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) jump stg_yield_to_interpreter []; } +INFO_TABLE_FUN( stg_CASE_CONT_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) +{ + /* Exactly as for stg_BCO */ + Sp_adj(-2); + Sp(1) = R1; + Sp(0) = stg_apply_interp_info; + jump stg_yield_to_interpreter []; +} + /* ---------------------------------------------------------------------------- Info tables for indirections. ===================================== rts/include/rts/Constants.h ===================================== @@ -328,6 +328,12 @@ */ #define TSO_ALLOC_LIMIT 256 +/* + * Enables step-in mode for this thread -- it will stop at the immediate next + * breakpoint found in this thread. + */ +#define TSO_STOP_NEXT_BREAKPOINT 512 + /* * The number of times we spin in a spin lock before yielding (see * #3758). To tune this value, use the benchmark in #3758: run the ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -180,6 +180,7 @@ RTS_ENTRY(stg_BLOCKING_QUEUE_CLEAN); RTS_ENTRY(stg_BLOCKING_QUEUE_DIRTY); RTS_FUN(stg_BCO); +RTS_FUN(stg_CASE_CONT_BCO); RTS_ENTRY(stg_EVACUATED); RTS_ENTRY(stg_WEAK); RTS_ENTRY(stg_DEAD_WEAK); @@ -577,7 +578,7 @@ RTS_FUN_DECL(stg_deRefWeakzh); RTS_FUN_DECL(stg_runRWzh); -RTS_FUN_DECL(stg_newBCOzh); +RTS_FUN_DECL(stg_newBCO2zh); RTS_FUN_DECL(stg_mkApUpd0zh); RTS_FUN_DECL(stg_retryzh); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8c40855b50a9f9b82385a97f94efee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8c40855b50a9f9b82385a97f94efee… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 15 commits: base: Forward port changelog language from 9.12
by Marge Bot (＠marge-bot) 23 May '25

23 May '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e650ec3e by Ben Gamari at 2025-05-23T03:42:46-04:00 base: Forward port changelog language from 9.12 - - - - - 94cd9ca4 by Ben Gamari at 2025-05-23T03:42:46-04:00 base: Fix RestructuredText-isms in changelog - - - - - 7722232c by Ben Gamari at 2025-05-23T03:42:46-04:00 base: Note strictness changes made in 4.16.0.0 Addresses #25886. - - - - - 3f4b823c by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker: Factor out ProddableBlocks machinery - - - - - 6e23fef2 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker: Improve efficiency of proddable blocks structure Previously the linker's "proddable blocks" check relied on a simple linked list of spans. This resulted in extremely poor complexity while linking objects with lots of small sections (e.g. objects built with split sections). Rework the mechanism to instead use a simple interval set implemented via binary search. Fixes #26009. - - - - - ea74860c by Ben Gamari at 2025-05-23T03:43:28-04:00 testsuite: Add simple functional test for ProddableBlockSet - - - - - 74c4db46 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Drop check for LOAD_LIBRARY_SEARCH_*_DIRS The `LOAD_LIBRARY_SEARCH_USER_DIRS` and `LOAD_LIBRARY_SEARCH_DEFAULT_DIRS` were introduced in Windows Vista and have been available every since. As we no longer support Windows XP we can drop this check. Addresses #26009. - - - - - 972d81d6 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Clean up code style - - - - - 8a1073a5 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/Hash: Factor out hashBuffer This is a useful helper which can be used for non-strings as well. - - - - - 44f509f2 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Fix incorrect use of break in nested for Previously the happy path of PEi386 used `break` in a double-`for` loop resulting in redundant calls to `LoadLibraryEx`. Fixes #26052. - - - - - bfb12783 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts: Correctly mark const arguments - - - - - 08469ff8 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Don't repeatedly load DLLs Previously every DLL-imported symbol would result in a call to `LoadLibraryEx`. This ended up constituting over 40% of the runtime of `ghc --interactive -e 42` on Windows. Avoid this by maintaining a hash-set of loaded DLL names, skipping the call if we have already loaded the requested DLL. Addresses #26009. - - - - - 823d1ccf by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker: Expand comment describing ProddableBlockSet - - - - - f9501cef by Sylvain Henry at 2025-05-23T10:21:43-04:00 Remove emptyModBreaks Remove emptyModBreaks and track the absence of ModBreaks with `Maybe ModBreaks`. It avoids testing for null pointers... - - - - - f422b3c7 by Ben Gamari at 2025-05-23T10:21:45-04:00 base: Expose Backtraces constructor and fields This was specified in the proposal (CLC #199) yet somehow didn't make it into the implementation. Fixes #26049. - - - - - 30 changed files: - compiler/GHC.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - ghc/GHCi/UI.hs - libraries/base/changelog.md - libraries/base/src/Control/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - rts/Hash.c - rts/Hash.h - rts/Linker.c - rts/LinkerInternals.h - rts/PathUtils.c - rts/PathUtils.h - rts/linker/Elf.c - rts/linker/MachO.c - rts/linker/PEi386.c - rts/linker/PEi386.h - + rts/linker/ProddableBlocks.c - + rts/linker/ProddableBlocks.h - rts/rts.cabal - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - + testsuite/tests/rts/TestProddableBlockSet.c - testsuite/tests/rts/all.T Changes: ===================================== compiler/GHC.hs ===================================== @@ -1307,7 +1307,7 @@ typecheckModule pmod = do minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details, minf_iface = Nothing, minf_safe = safe, - minf_modBreaks = emptyModBreaks + minf_modBreaks = Nothing }} -- | Desugar a typechecked module. @@ -1461,7 +1461,7 @@ data ModuleInfo = ModuleInfo { minf_instances :: [ClsInst], minf_iface :: Maybe ModIface, minf_safe :: SafeHaskellMode, - minf_modBreaks :: ModBreaks + minf_modBreaks :: Maybe ModBreaks } -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. @@ -1490,7 +1490,7 @@ getPackageModuleInfo hsc_env mdl minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, minf_safe = getSafeMode $ mi_trust iface, - minf_modBreaks = emptyModBreaks + minf_modBreaks = Nothing })) availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv @@ -1567,7 +1567,7 @@ modInfoIface = minf_iface modInfoSafe :: ModuleInfo -> SafeHaskellMode modInfoSafe = minf_safe -modInfoModBreaks :: ModuleInfo -> ModBreaks +modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks modInfoModBreaks = minf_modBreaks isDictonaryId :: Id -> Bool ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -19,7 +19,7 @@ module GHC.ByteCode.Types , ItblEnv, ItblPtr(..) , AddrEnv, AddrPtr(..) , CgBreakInfo(..) - , ModBreaks (..), BreakIndex, emptyModBreaks + , ModBreaks (..), BreakIndex , CCostCentre , FlatBag, sizeFlatBag, fromSmallArray, elemsFlatBag ) where @@ -45,12 +45,11 @@ import Foreign import Data.Array import Data.ByteString (ByteString) import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList ) import GHC.Iface.Syntax -import Language.Haskell.Syntax.Module.Name (ModuleName, mkModuleNameFS) +import Language.Haskell.Syntax.Module.Name (ModuleName) import GHC.Unit.Types (UnitId(..)) -- ----------------------------------------------------------------------------- @@ -250,7 +249,7 @@ data CCostCentre -- | All the information about the breakpoints for a module data ModBreaks = ModBreaks - { modBreaks_flags :: ForeignRef BreakArray + { modBreaks_flags :: !(ForeignRef BreakArray) -- ^ The array of flags, one per breakpoint, -- indicating which breakpoints are enabled. , modBreaks_locs :: !(Array BreakIndex SrcSpan) @@ -281,20 +280,6 @@ seqModBreaks ModBreaks{..} = rnf modBreaks_module `seq` rnf modBreaks_module_unitid --- | Construct an empty ModBreaks -emptyModBreaks :: ModBreaks -emptyModBreaks = ModBreaks - { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" - -- ToDo: can we avoid this? - , modBreaks_locs = array (0,-1) [] - , modBreaks_vars = array (0,-1) [] - , modBreaks_decls = array (0,-1) [] - , modBreaks_ccs = array (0,-1) [] - , modBreaks_breakInfo = IntMap.empty - , modBreaks_module = mkModuleNameFS nilFS - , modBreaks_module_unitid = UnitId nilFS - } - {- Note [Field modBreaks_decls] ~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/HsToCore/Breakpoints.hs ===================================== @@ -18,6 +18,7 @@ import GHC.Utils.Outputable as Outputable import Data.List (intersperse) import Data.Array +import qualified Data.IntMap as IntMap -- | Initialize memory for breakpoint data that is shared between the bytecode -- generator and the interpreter. @@ -38,15 +39,16 @@ mkModBreaks interp mod extendedMixEntries locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ] varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ] declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ] - return $ emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks - , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks - , modBreaks_ccs = ccs - , modBreaks_module = moduleName mod - , modBreaks_module_unitid = toUnitId $ moduleUnit mod - } + return $ ModBreaks + { modBreaks_flags = breakArray + , modBreaks_locs = locsTicks + , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks + , modBreaks_ccs = ccs + , modBreaks_breakInfo = IntMap.empty + , modBreaks_module = moduleName mod + , modBreaks_module_unitid = toUnitId $ moduleUnit mod + } mkCCSArray :: Interp -> Module -> Int -> [Tick] ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -145,15 +145,17 @@ resolveFunctionBreakpoint inp = do validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing" validateBP _ fun_str (Just modl) = do isInterpr <- GHC.moduleIsInterpreted modl - (_, decls) <- getModBreak modl mb_err_msg <- case isInterpr of - False -> pure $ Just $ text "Module" <+> quotes (ppr modl) - <+> text "is not interpreted" - True -> case fun_str `elem` (intercalate "." <$> elems decls) of - False -> pure $ Just $ - text "No breakpoint found for" <+> quotes (text fun_str) - <+> text "in module" <+> quotes (ppr modl) - True -> pure Nothing + 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)) + if found + then pure Nothing + else pure $ Just $ text "No breakpoint found for" <+> quotes (text fun_str) + <+> text "in module" <+> quotes (ppr modl) pure mb_err_msg -- | The aim of this function is to find the breakpoints for all the RHSs of @@ -184,8 +186,7 @@ type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)] makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray) makeModuleLineMap m = do mi <- GHC.getModuleInfo m - return $ - mkTickArray . assocs . GHC.modBreaks_locs . GHC.modInfoModBreaks <$> mi + return $ mkTickArray . assocs . GHC.modBreaks_locs <$> (GHC.modInfoModBreaks =<< mi) where mkTickArray :: [(BreakIndex, SrcSpan)] -> TickArray mkTickArray ticks @@ -195,15 +196,12 @@ makeModuleLineMap m = do max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ] srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ] --- | Get the 'modBreaks_locs' and 'modBreaks_decls' of the given 'Module' +-- | Get the 'ModBreaks' of the given 'Module' when available getModBreak :: GHC.GhcMonad m - => Module -> m (Array Int SrcSpan, Array Int [String]) + => Module -> m (Maybe ModBreaks) getModBreak m = do mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m - let modBreaks = GHC.modInfoModBreaks mod_info - let ticks = GHC.modBreaks_locs modBreaks - let decls = GHC.modBreaks_decls modBreaks - return (ticks, decls) + pure $ GHC.modInfoModBreaks mod_info -------------------------------------------------------------------------------- -- Getting current breakpoint information ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -522,9 +522,8 @@ result_fs = fsLit "_result" -- | Read the 'ModBreaks' of the given home 'Module' from the 'HomeUnitGraph'. readModBreaks :: HscEnv -> Module -> IO ModBreaks -readModBreaks hsc_env mod = - getModBreaks . expectJust <$> - HUG.lookupHugByModule mod (hsc_HUG hsc_env) +readModBreaks hsc_env mod = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule mod (hsc_HUG hsc_env) + bindLocalsAtBreakpoint :: HscEnv ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -435,22 +435,24 @@ handleSeqHValueStatus interp unit_env eval_status = resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt let put x = putStrLn ("*** Ignoring breakpoint " ++ (showSDocUnsafe x)) + let nothing_case = put $ brackets . ppr $ mkGeneralSrcSpan (fsLit "<unknown>") case maybe_break of - Nothing -> + Nothing -> nothing_case -- Nothing case - should not occur! -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq - put $ brackets . ppr $ - mkGeneralSrcSpan (fsLit "<unknown>") Just break -> do let bi = evalBreakpointToId break -- Just case: Stopped at a breakpoint, extract SrcSpan information -- from the breakpoint. - breaks_tick <- getModBreaks . expectJust <$> + mb_modbreaks <- getModBreaks . expectJust <$> lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env) - put $ brackets . ppr $ - (modBreaks_locs breaks_tick) ! ibi_tick_index bi + case mb_modbreaks of + -- Nothing case - should not occur! We should have the appropriate + -- breakpoint information + Nothing -> nothing_case + Just modbreaks -> put $ brackets . ppr $ (modBreaks_locs modbreaks) ! ibi_tick_index bi -- resume the seq (:force) processing in the iserv process withForeignRef resume_ctxt_fhv $ \hval -> do @@ -737,14 +739,14 @@ fromEvalResult :: EvalResult a -> IO a fromEvalResult (EvalException e) = throwIO (fromSerializableException e) fromEvalResult (EvalSuccess a) = return a -getModBreaks :: HomeModInfo -> ModBreaks +getModBreaks :: HomeModInfo -> Maybe ModBreaks getModBreaks hmi | Just linkable <- homeModInfoByteCode hmi, -- The linkable may have 'DotO's as well; only consider BCOs. See #20570. [cbc] <- linkableBCOs linkable - = fromMaybe emptyModBreaks (bc_breaks cbc) + = bc_breaks cbc | otherwise - = emptyModBreaks -- probably object code + = Nothing -- probably object code -- | Interpreter uses Profiling way interpreterProfiled :: Interp -> Bool ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -439,8 +439,8 @@ schemeER_wrk d p rhs = schemeE d 0 p rhs -- -- If the breakpoint is inlined from another module, look it up in the home -- package table. --- If the module doesn't exist there, or its module pointer is null (which means --- that the 'ModBreaks' value is uninitialized), skip the instruction. +-- If the module doesn't exist there, or if the 'ModBreaks' value is +-- uninitialized, skip the instruction (i.e. return Nothing). break_info :: HscEnv -> Module -> @@ -449,18 +449,11 @@ break_info :: BcM (Maybe ModBreaks) break_info hsc_env mod current_mod current_mod_breaks | mod == current_mod - = pure $ check_mod_ptr =<< current_mod_breaks + = pure current_mod_breaks | otherwise = ioToBc (lookupHpt (hsc_HPT hsc_env) (moduleName mod)) >>= \case - Just hp -> pure $ check_mod_ptr (getModBreaks hp) + Just hp -> pure $ getModBreaks hp Nothing -> pure Nothing - where - check_mod_ptr mb - | mod_ptr <- modBreaks_module mb - , not $ nullFS $ moduleNameFS mod_ptr - = Just mb - | otherwise - = Nothing getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] getVarOffSets platform depth env = map getOffSet ===================================== ghc/GHCi/UI.hs ===================================== @@ -3629,8 +3629,10 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 -- Return all possible bids for a given Module bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String] bidsByModule nonquals mod = do - (_, decls) <- getModBreak mod - let bids = nub $ declPath <$> elems decls + mb_decls <- fmap GHC.modBreaks_decls <$> getModBreak mod + let bids = case mb_decls of + Just decls -> nub $ declPath <$> elems decls + Nothing -> [] pure $ case (moduleName mod) `elem` nonquals of True -> bids False -> (combineModIdent (showModule mod)) <$> bids @@ -3656,11 +3658,14 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 -- declarations. See Note [Field modBreaks_decls] in GHC.ByteCode.Types addNestedDecls :: GhciMonad m => (String, Module) -> m [String] addNestedDecls (ident, mod) = do - (_, decls) <- getModBreak mod - let (mod_str, topLvl, _) = splitIdent ident - ident_decls = [ elm | elm@(el : _) <- elems decls, el == topLvl ] - bids = nub $ declPath <$> ident_decls - pure $ map (combineModIdent mod_str) bids + mb_decls <- fmap GHC.modBreaks_decls <$> getModBreak mod + case mb_decls of + Nothing -> pure [] + Just decls -> do + let (mod_str, topLvl, _) = splitIdent ident + ident_decls = [ elm | elm@(el : _) <- elems decls, el == topLvl ] + bids = nub $ declPath <$> ident_decls + pure $ map (combineModIdent mod_str) bids completeModule = wrapIdentCompleterMod $ \w -> do hsc_env <- GHC.getSession @@ -4066,7 +4071,7 @@ breakById inp = do case mb_error of Left sdoc -> printForUser sdoc Right (mod, mod_info, fun_str) -> do - let modBreaks = GHC.modInfoModBreaks mod_info + let modBreaks = expectJust (GHC.modInfoModBreaks mod_info) findBreakAndSet mod $ \_ -> findBreakForBind fun_str modBreaks breakSyntax :: a ===================================== libraries/base/changelog.md ===================================== @@ -22,11 +22,13 @@ * `GHC.TypeNats.Internal` * `GHC.ExecutionStack.Internal`. * Deprecate `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) + * Expose constructor and field of `Backtraces` from `Control.Exception.Backtrace`, as per [CLC #199](https://github.com/haskell/core-libraries-committee/issues/199#issuecomment-1954662391) * Fix incorrect results of `integerPowMod` when the base is 0 and the exponent is negative, and `integerRecipMod` when the modulus is zero ([#26017](https://gitlab.haskell.org/ghc/ghc/-/issues/26017)). -## 4.21.0.0 *TBA* +## 4.21.0.0 *December 2024* + * Shipped with GHC 9.12.1 * Change `SrcLoc` to be a strict and unboxed (finishing [CLC proposal #55](https://github.com/haskell/core-libraries-committee/issues/55)) * Introduce `Data.Bounded` module exporting the `Bounded` typeclass (finishing [CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208)) * Deprecate export of `Bounded` class from `Data.Enum` ([CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208)) @@ -311,29 +313,29 @@ * Re-export the `IsList` typeclass from the new `GHC.IsList` module. - * There's a new special function ``withDict`` in ``GHC.Exts``: :: + * There's a new special function `withDict` in `GHC.Exts`: :: withDict :: forall {rr :: RuntimeRep} cls meth (r :: TYPE rr). WithDict cls meth => meth -> (cls => r) -> r - where ``cls`` must be a class containing exactly one method, whose type - must be ``meth``. + where `cls` must be a class containing exactly one method, whose type + must be `meth`. - This function converts ``meth`` to a type class dictionary. - It removes the need for ``unsafeCoerce`` in implementation of reflection + This function converts `meth` to a type class dictionary. + It removes the need for `unsafeCoerce` in implementation of reflection libraries. It should be used with care, because it can introduce incoherent instances. - For example, the ``withTypeable`` function from the - ``Type.Reflection`` module can now be defined as: :: + For example, the `withTypeable` function from the + `Type.Reflection` module can now be defined as: :: withTypeable :: forall k (a :: k) rep (r :: TYPE rep). () => TypeRep a -> (Typeable a => r) -> r withTypeable rep k = withDict @(Typeable a) rep k Note that the explicit type application is required, as the call to - ``withDict`` would be ambiguous otherwise. + `withDict` would be ambiguous otherwise. - This replaces the old ``GHC.Exts.magicDict``, which required + This replaces the old `GHC.Exts.magicDict`, which required an intermediate data type and was less reliable. * `Data.Word.Word64` and `Data.Int.Int64` are now always represented by @@ -351,17 +353,17 @@ * Shipped with GHC 9.2.4 - * winio: make consoleReadNonBlocking not wait for any events at all. + * winio: make `consoleReadNonBlocking` not wait for any events at all. - * winio: Add support to console handles to handleToHANDLE + * winio: Add support to console handles to `handleToHANDLE` ## 4.16.2.0 *May 2022* * Shipped with GHC 9.2.2 - * Export GHC.Event.Internal on Windows (#21245) + * Export `GHC.Event.Internal` on Windows (#21245) - # Documentation Fixes + * Documentation Fixes ## 4.16.1.0 *Feb 2022* @@ -430,10 +432,17 @@ - Newtypes `And`, `Ior`, `Xor` and `Iff` which wrap their argument, and whose `Semigroup` instances are defined using `(.&.)`, `(.|.)`, `xor` - and ```\x y -> complement (x `xor` y)```, respectively. + and `\x y -> complement (x `xor` y)`, respectively. - `oneBits :: FiniteBits a => a`, `oneBits = complement zeroBits`. + * Various folding operations in `GHC.List` are now implemented via strict + folds: + - `sum` + - `product` + - `maximum` + - `minimum` + ## 4.15.0.0 *Feb 2021* * Shipped with GHC 9.0.1 ===================================== libraries/base/src/Control/Exception/Backtrace.hs ===================================== @@ -51,7 +51,7 @@ module Control.Exception.Backtrace , getBacktraceMechanismState , setBacktraceMechanismState -- * Collecting backtraces - , Backtraces + , Backtraces(..) , displayBacktraces , collectBacktraces ) where ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -9,7 +9,7 @@ module GHC.Internal.Exception.Backtrace , getBacktraceMechanismState , setBacktraceMechanismState -- * Collecting backtraces - , Backtraces + , Backtraces(..) , displayBacktraces , collectBacktraces ) where ===================================== rts/Hash.c ===================================== @@ -94,13 +94,13 @@ hashWord(const HashTable *table, StgWord key) } int -hashStr(const HashTable *table, StgWord w) +hashBuffer(const HashTable *table, const void *buf, size_t len) { - const char *key = (char*) w; + const char *key = (char*) buf; #if WORD_SIZE_IN_BITS == 64 - StgWord h = XXH3_64bits_withSeed (key, strlen(key), 1048583); + StgWord h = XXH3_64bits_withSeed (key, len, 1048583); #else - StgWord h = XXH32 (key, strlen(key), 1048583); + StgWord h = XXH32 (key, len, 1048583); #endif /* Mod the size of the hash table (a power of 2) */ @@ -114,6 +114,13 @@ hashStr(const HashTable *table, StgWord w) return bucket; } +int +hashStr(const HashTable *table, StgWord w) +{ + const char *key = (char*) w; + return hashBuffer(table, key, strlen(key)); +} + STATIC_INLINE int compareWord(StgWord key1, StgWord key2) { ===================================== rts/Hash.h ===================================== @@ -69,6 +69,10 @@ void * removeStrHashTable ( StrHashTable *table, const char * key, */ typedef int HashFunction(const HashTable *table, StgWord key); typedef int CompareFunction(StgWord key1, StgWord key2); + +// Helper for implementing hash functions +int hashBuffer(const HashTable *table, const void *buf, size_t len); + int hashWord(const HashTable *table, StgWord key); int hashStr(const HashTable *table, StgWord w); void insertHashTable_ ( HashTable *table, StgWord key, @@ -79,6 +83,7 @@ void * removeHashTable_ ( HashTable *table, StgWord key, const void *data, HashFunction f, CompareFunction cmp ); + /* Freeing hash tables */ void freeHashTable ( HashTable *table, void (*freeDataFun)(void *) ); ===================================== rts/Linker.c ===================================== @@ -1194,7 +1194,7 @@ void freeObjectCode (ObjectCode *oc) stgFree(oc->sections); } - freeProddableBlocks(oc); + freeProddableBlocks(&oc->proddables); freeSegments(oc); /* Free symbol_extras. On x86_64 Windows, symbol_extras are allocated @@ -1279,7 +1279,7 @@ mkOc( ObjectType type, pathchar *path, char *image, int imageSize, oc->sections = NULL; oc->n_segments = 0; oc->segments = NULL; - oc->proddables = NULL; + initProddableBlockSet(&oc->proddables); oc->foreign_exports = NULL; #if defined(NEED_SYMBOL_EXTRAS) oc->symbol_extras = NULL; @@ -1834,50 +1834,6 @@ OStatus getObjectLoadStatus (pathchar *path) return r; } -/* ----------------------------------------------------------------------------- - * Sanity checking. For each ObjectCode, maintain a list of address ranges - * which may be prodded during relocation, and abort if we try and write - * outside any of these. - */ -void -addProddableBlock ( ObjectCode* oc, void* start, int size ) -{ - ProddableBlock* pb - = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock"); - - IF_DEBUG(linker, debugBelch("addProddableBlock: %p %p %d\n", oc, start, size)); - ASSERT(size > 0); - pb->start = start; - pb->size = size; - pb->next = oc->proddables; - oc->proddables = pb; -} - -void -checkProddableBlock (ObjectCode *oc, void *addr, size_t size ) -{ - ProddableBlock* pb; - - for (pb = oc->proddables; pb != NULL; pb = pb->next) { - char* s = (char*)(pb->start); - char* e = s + pb->size; - char* a = (char*)addr; - if (a >= s && (a+size) <= e) return; - } - barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr); -} - -void freeProddableBlocks (ObjectCode *oc) -{ - ProddableBlock *pb, *next; - - for (pb = oc->proddables; pb != NULL; pb = next) { - next = pb->next; - stgFree(pb); - } - oc->proddables = NULL; -} - /* ----------------------------------------------------------------------------- * Section management. */ ===================================== rts/LinkerInternals.h ===================================== @@ -12,6 +12,7 @@ #include "RtsSymbols.h" #include "Hash.h" #include "linker/M32Alloc.h" +#include "linker/ProddableBlocks.h" #if RTS_LINKER_USE_MMAP #include <sys/mman.h> @@ -175,14 +176,6 @@ struct _Section { struct SectionFormatInfo* info; }; -typedef - struct _ProddableBlock { - void* start; - int size; - struct _ProddableBlock* next; - } - ProddableBlock; - typedef struct _Segment { void *start; /* page aligned start address of a segment */ size_t size; /* page rounded size of a segment */ @@ -328,7 +321,7 @@ struct _ObjectCode { /* SANITY CHECK ONLY: a list of the only memory regions which may safely be prodded during relocation. Any attempt to prod outside one of these is an error in the linker. */ - ProddableBlock* proddables; + ProddableBlockSet proddables; #if defined(NEED_SYMBOL_EXTRAS) SymbolExtra *symbol_extras; @@ -434,10 +427,6 @@ void exitLinker( void ); void freeObjectCode (ObjectCode *oc); SymbolAddr* loadSymbol(SymbolName *lbl, RtsSymbolInfo *pinfo); -void addProddableBlock ( ObjectCode* oc, void* start, int size ); -void checkProddableBlock (ObjectCode *oc, void *addr, size_t size ); -void freeProddableBlocks (ObjectCode *oc); - void addSection (Section *s, SectionKind kind, SectionAlloc alloc, void* start, StgWord size, StgWord mapped_offset, void* mapped_start, StgWord mapped_size); ===================================== rts/PathUtils.c ===================================== @@ -13,7 +13,7 @@ #include <wchar.h> #endif -pathchar* pathdup(pathchar *path) +pathchar* pathdup(const pathchar *path) { pathchar *ret; #if defined(mingw32_HOST_OS) @@ -26,7 +26,7 @@ pathchar* pathdup(pathchar *path) return ret; } -pathchar* pathdir(pathchar *path) +pathchar* pathdir(const pathchar *path) { pathchar *ret; #if defined(mingw32_HOST_OS) @@ -40,7 +40,8 @@ pathchar* pathdir(pathchar *path) stgFree(drive); stgFree(dirName); #else - pathchar* dirName = dirname(path); + // N.B. cast is safe as we do not modify dirName + const pathchar* dirName = dirname((pathchar *) path); size_t memberLen = pathlen(dirName); ret = stgMallocBytes(pathsize * (memberLen + 2), "pathdir(path)"); strcpy(ret, dirName); @@ -50,7 +51,7 @@ pathchar* pathdir(pathchar *path) return ret; } -pathchar* mkPath(char* path) +pathchar* mkPath(const char* path) { #if defined(mingw32_HOST_OS) size_t required = mbstowcs(NULL, path, 0); @@ -66,7 +67,7 @@ pathchar* mkPath(char* path) #endif } -HsBool endsWithPath(pathchar* base, pathchar* str) { +HsBool endsWithPath(const pathchar* base, const pathchar* str) { int blen = pathlen(base); int slen = pathlen(str); return (blen >= slen) && (0 == pathcmp(base + blen - slen, str)); ===================================== rts/PathUtils.h ===================================== @@ -37,9 +37,9 @@ #include "BeginPrivate.h" -pathchar* pathdup(pathchar *path); -pathchar* pathdir(pathchar *path); -pathchar* mkPath(char* path); -HsBool endsWithPath(pathchar* base, pathchar* str); +pathchar* pathdup(const pathchar *path); +pathchar* pathdir(const pathchar *path); +pathchar* mkPath(const char* path); +HsBool endsWithPath(const pathchar* base, const pathchar* str); #include "EndPrivate.h" ===================================== rts/linker/Elf.c ===================================== @@ -924,7 +924,7 @@ ocGetNames_ELF ( ObjectCode* oc ) oc->sections[i].info->stubs = NULL; #endif - addProddableBlock(oc, start, size); + addProddableBlock(&oc->proddables, start, size); } else { addSection(&oc->sections[i], kind, alloc, oc->image+offset, size, 0, 0, 0); @@ -1272,7 +1272,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, debugBelch("Reloc: P = %p S = %p A = %p type=%d\n", (void*)P, (void*)S, (void*)A, reloc_type )); #if defined(DEBUG) - checkProddableBlock ( oc, pP, sizeof(Elf_Word) ); + checkProddableBlock ( &oc->proddables, pP, sizeof(Elf_Word) ); #else (void) pP; /* suppress unused varialbe warning in non-debug build */ #endif @@ -1684,7 +1684,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC, #if defined(DEBUG) IF_DEBUG(linker_verbose,debugBelch("Reloc: P = %p S = %p A = %p\n", (void*)P, (void*)S, (void*)A )); - checkProddableBlock(oc, (void*)P, sizeof(Elf_Word)); + checkProddableBlock(&oc->proddables, (void*)P, sizeof(Elf_Word)); #endif #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH) ===================================== rts/linker/MachO.c ===================================== @@ -253,7 +253,7 @@ resolveImports( return 0; } - checkProddableBlock(oc, + checkProddableBlock(&oc->proddables, ((void**)(oc->image + sect->offset)) + i, sizeof(void *)); ((void**)(oc->image + sect->offset))[i] = addr; @@ -287,7 +287,7 @@ decodeAddend(ObjectCode * oc, Section * section, MachORelocationInfo * ri) { /* the instruction. It is 32bit wide */ uint32_t * p = (uint32_t*)((uint8_t*)section->start + ri->r_address); - checkProddableBlock(oc, (void*)p, 1 << ri->r_length); + checkProddableBlock(&oc->proddables, (void*)p, 1 << ri->r_length); switch(ri->r_type) { case ARM64_RELOC_UNSIGNED: { @@ -364,7 +364,7 @@ encodeAddend(ObjectCode * oc, Section * section, MachORelocationInfo * ri, int64_t addend) { uint32_t * p = (uint32_t*)((uint8_t*)section->start + ri->r_address); - checkProddableBlock(oc, (void*)p, 1 << ri->r_length); + checkProddableBlock(&oc->proddables, (void*)p, 1 << ri->r_length); switch (ri->r_type) { case ARM64_RELOC_UNSIGNED: { @@ -788,7 +788,7 @@ relocateSection(ObjectCode* oc, int curSection) default: barf("Unknown size."); } - checkProddableBlock(oc,thingPtr,relocLenBytes); + checkProddableBlock(&oc->proddables,thingPtr,relocLenBytes); /* * With SIGNED_N the relocation is not at the end of the @@ -1034,9 +1034,9 @@ relocateSection(ObjectCode* oc, int curSection) */ if (0 == reloc->r_extern) { if (reloc->r_pcrel) { - checkProddableBlock(oc, (void *)((char *)thing + baseValue), 1); + checkProddableBlock(&oc->proddables, (void *)((char *)thing + baseValue), 1); } else { - checkProddableBlock(oc, (void *)thing, 1); + checkProddableBlock(&oc->proddables, (void *)thing, 1); } } @@ -1343,7 +1343,7 @@ ocGetNames_MachO(ObjectCode* oc) secArray[sec_idx].info->stub_size = 0; secArray[sec_idx].info->stubs = NULL; #endif - addProddableBlock(oc, start, section->size); + addProddableBlock(&oc->proddables, start, section->size); } curMem = (char*) secMem + section->size; ===================================== rts/linker/PEi386.c ===================================== @@ -378,7 +378,7 @@ static size_t makeSymbolExtra_PEi386( #endif static void addDLLHandle( - pathchar* dll_name, + const pathchar* dll_name, HINSTANCE instance); static bool verifyCOFFHeader( @@ -427,8 +427,52 @@ const int default_alignment = 8; the pointer as a redirect. Essentially it's a DATA DLL reference. */ const void* __rts_iob_func = (void*)&__acrt_iob_func; +/* + * Note [Avoiding repeated DLL loading] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * As LoadLibraryEx tends to be expensive and addDLL_PEi386 is called on every + * DLL-imported symbol, we use a hash-map to keep track of which DLLs have + * already been loaded. This hash-map is keyed on the dll_name passed to + * addDLL_PEi386 and is mapped to its HINSTANCE. This serves as a quick check + * to avoid repeated calls to LoadLibraryEx for the identical DLL. See #26009. + */ + +typedef struct { + HashTable *hash; +} LoadedDllCache; + +LoadedDllCache loaded_dll_cache; + +static void initLoadedDllCache(LoadedDllCache *cache) { + cache->hash = allocHashTable(); +} + +static int hash_path(const HashTable *table, StgWord w) +{ + const pathchar *key = (pathchar*) w; + return hashBuffer(table, key, sizeof(pathchar) * wcslen(key)); +} + +static int compare_path(StgWord key1, StgWord key2) +{ + return wcscmp((pathchar*) key1, (pathchar*) key2) == 0; +} + +static void addLoadedDll(LoadedDllCache *cache, const pathchar *dll_name, HINSTANCE instance) +{ + insertHashTable_(cache->hash, (StgWord) dll_name, instance, hash_path); +} + +static HINSTANCE isDllLoaded(const LoadedDllCache *cache, const pathchar *dll_name) +{ + void *result = lookupHashTable_(cache->hash, (StgWord) dll_name, hash_path, compare_path); + return (HINSTANCE) result; +} + void initLinker_PEi386(void) { + initLoadedDllCache(&loaded_dll_cache); + if (!ghciInsertSymbolTable(WSTR("(GHCi/Ld special symbols)"), symhash, "__image_base__", GetModuleHandleW (NULL), HS_BOOL_TRUE, @@ -440,10 +484,11 @@ void initLinker_PEi386(void) addDLLHandle(WSTR("*.exe"), GetModuleHandle(NULL)); #endif - /* Register the cleanup routine as an exit handler, this gives other exit handlers - a chance to run which may need linker information. Exit handlers are ran in - reverse registration order so this needs to be before the linker loads anything. */ - atexit (exitLinker_PEi386); + /* Register the cleanup routine as an exit handler, this gives other exit handlers + * a chance to run which may need linker information. Exit handlers are ran in + * reverse registration order so this needs to be before the linker loads anything. + */ + atexit (exitLinker_PEi386); } void exitLinker_PEi386(void) @@ -454,7 +499,7 @@ void exitLinker_PEi386(void) static OpenedDLL* opened_dlls = NULL; /* Adds a DLL instance to the list of DLLs in which to search for symbols. */ -static void addDLLHandle(pathchar* dll_name, HINSTANCE instance) { +static void addDLLHandle(const pathchar* dll_name, HINSTANCE instance) { IF_DEBUG(linker, debugBelch("addDLLHandle(%" PATH_FMT ")...\n", dll_name)); /* At this point, we actually know what was loaded. @@ -796,14 +841,19 @@ uint8_t* getSymShortName ( COFF_HEADER_INFO *info, COFF_symbol* sym ) } const char * -addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) +addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded ) { - /* ------------------- Win32 DLL loader ------------------- */ - - pathchar* buf; - HINSTANCE instance; - - IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name)); + /* ------------------- Win32 DLL loader ------------------- */ + IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name)); + + // See Note [Avoiding repeated DLL loading] + HINSTANCE instance = isDllLoaded(&loaded_dll_cache, dll_name); + if (instance) { + if (loaded) { + *loaded = instance; + } + return NULL; + } /* The file name has no suffix (yet) so that we can try both foo.dll and foo.drv @@ -816,45 +866,32 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) extension. */ size_t bufsize = pathlen(dll_name) + 10; - buf = stgMallocBytes(bufsize * sizeof(wchar_t), "addDLL"); + pathchar *buf = stgMallocBytes(bufsize * sizeof(wchar_t), "addDLL"); /* These are ordered by probability of success and order we'd like them. */ const wchar_t *formats[] = { L"%ls.DLL", L"%ls.DRV", L"lib%ls.DLL", L"%ls" }; const DWORD flags[] = { LOAD_LIBRARY_SEARCH_USER_DIRS | LOAD_LIBRARY_SEARCH_DEFAULT_DIRS, 0 }; - int cFormat, cFlag; - int flags_start = 1; /* Assume we don't support the new API. */ - - /* Detect if newer API are available, if not, skip the first flags entry. */ - if (GetProcAddress((HMODULE)LoadLibraryW(L"Kernel32.DLL"), "AddDllDirectory")) { - flags_start = 0; - } - /* Iterate through the possible flags and formats. */ - for (cFlag = flags_start; cFlag < 2; cFlag++) - { - for (cFormat = 0; cFormat < 4; cFormat++) - { + for (int cFlag = 0; cFlag < 2; cFlag++) { + for (int cFormat = 0; cFormat < 4; cFormat++) { snwprintf(buf, bufsize, formats[cFormat], dll_name); instance = LoadLibraryExW(buf, NULL, flags[cFlag]); if (instance == NULL) { - if (GetLastError() != ERROR_MOD_NOT_FOUND) - { + if (GetLastError() != ERROR_MOD_NOT_FOUND) { goto error; } - } - else - { - break; /* We're done. DLL has been loaded. */ + } else { + goto loaded; /* We're done. DLL has been loaded. */ } } } - /* Check if we managed to load the DLL. */ - if (instance == NULL) { - goto error; - } + // We failed to load + goto error; +loaded: + addLoadedDll(&loaded_dll_cache, dll_name, instance); addDLLHandle(buf, instance); if (loaded) { *loaded = instance; @@ -1658,7 +1695,7 @@ ocGetNames_PEi386 ( ObjectCode* oc ) } addSection(section, kind, SECTION_NOMEM, start, sz, 0, 0, 0); - addProddableBlock(oc, oc->sections[i].start, sz); + addProddableBlock(&oc->proddables, oc->sections[i].start, sz); } /* Copy exported symbols into the ObjectCode. */ @@ -1690,7 +1727,7 @@ ocGetNames_PEi386 ( ObjectCode* oc ) SECTIONKIND_RWDATA, SECTION_MALLOC, bss, globalBssSize, 0, 0, 0); IF_DEBUG(linker_verbose, debugBelch("bss @ %p %" FMT_Word "\n", bss, globalBssSize)); - addProddableBlock(oc, bss, globalBssSize); + addProddableBlock(&oc->proddables, bss, globalBssSize); } else { addSection(&oc->sections[oc->n_sections-1], SECTIONKIND_OTHER, SECTION_NOMEM, NULL, 0, 0, 0, 0); @@ -2067,13 +2104,13 @@ ocResolve_PEi386 ( ObjectCode* oc ) IF_DEBUG(linker_verbose, debugBelch("S=%zx\n", S)); /* All supported relocations write at least 4 bytes */ - checkProddableBlock(oc, pP, 4); + checkProddableBlock(&oc->proddables, pP, 4); switch (reloc->Type) { #if defined(x86_64_HOST_ARCH) case 1: /* R_X86_64_64 (ELF constant 1) - IMAGE_REL_AMD64_ADDR64 (PE constant 1) */ { uint64_t A; - checkProddableBlock(oc, pP, 8); + checkProddableBlock(&oc->proddables, pP, 8); A = *(uint64_t*)pP; *(uint64_t *)pP = S + A; break; @@ -2114,7 +2151,7 @@ ocResolve_PEi386 ( ObjectCode* oc ) { /* mingw will emit this for a pc-rel 64 relocation */ uint64_t A; - checkProddableBlock(oc, pP, 8); + checkProddableBlock(&oc->proddables, pP, 8); A = *(uint64_t*)pP; *(uint64_t *)pP = S + A - (intptr_t)pP; break; ===================================== rts/linker/PEi386.h ===================================== @@ -45,7 +45,7 @@ typedef struct _COFF_HEADER_INFO { void initLinker_PEi386( void ); void exitLinker_PEi386( void ); -const char * addDLL_PEi386( pathchar *dll_name, HINSTANCE *instance ); +const char * addDLL_PEi386( const pathchar *dll_name, HINSTANCE *instance ); void freePreloadObjectFile_PEi386( ObjectCode *oc ); bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f); ===================================== rts/linker/ProddableBlocks.c ===================================== @@ -0,0 +1,137 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2025 + * + * RTS Object Linker + * + * ---------------------------------------------------------------------------*/ + + +/* + * Note [Proddable blocks] + * ~~~~~~~~~~~~~~~~~~~~~~~ + * For each ObjectCode, we maintain a ProddableBlockSet representing the set of + * address ranges containing data belonging to the object. This set is + * represented here as an array of intervals sorted by start address. This + * allows us to efficiently query and insert via binary search. Array resizing + * is done according to an exponential growth schedule. + * + * While performing relocations we check against this set and and abort if we + * try and write outside any of these. + */ + +#include "Rts.h" +#include "RtsUtils.h" +#include "linker/ProddableBlocks.h" + +#include <stdlib.h> +#include <string.h> + +typedef struct _ProddableBlock { + uintptr_t start; // inclusive + uintptr_t end; // inclusive +} ProddableBlock; + +void +initProddableBlockSet ( ProddableBlockSet* set ) +{ + set->data = NULL; + set->capacity = 0; + set->size = 0; +} + +void +freeProddableBlocks (ProddableBlockSet *set) +{ + stgFree(set->data); + set->data = NULL; + set->size = 0; + set->capacity = 0; +} + +// Binary search for the first interval with start >= value. Returns index or +// size if none. +static size_t +findLower(const ProddableBlockSet *set, uintptr_t value) +{ + size_t l = 0; + size_t r = set->size; + while (l < r) { + size_t mid = l + (r - l) / 2; + if (set->data[mid].start < value) { + l = mid + 1; + } else { + r = mid; + } + } + return l; +} + +// Check whether a given value is a member of the set. +bool +containsSpan ( const ProddableBlockSet *set, uintptr_t start, uintptr_t end ) +{ + size_t i = findLower(set, start+1); + return i > 0 + && set->data[i-1].start <= start + && end <= set->data[i-1].end; +} + +void +checkProddableBlock (const ProddableBlockSet *set, void *addr, size_t size ) +{ + if (! containsSpan(set, (uintptr_t) addr, (uintptr_t) addr+size)) { + barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr); + } +} + +// Ensure capacity for at least new_capacity intervals +static void +ensureCapacity(ProddableBlockSet *set, size_t new_capacity) { + if (new_capacity > set->capacity) { + size_t cap = set->capacity ? set->capacity * 2 : 4; + if (cap < new_capacity) { + cap = new_capacity; + } + ProddableBlock *tmp = stgReallocBytes(set->data, cap * sizeof(ProddableBlock), "addProddableBlock"); + set->data = tmp; + set->capacity = cap; + } +} + +void +addProddableBlock ( ProddableBlockSet* set, void* start_ptr, size_t size ) +{ + const uintptr_t start = (uintptr_t) start_ptr; + const uintptr_t end = (uintptr_t) start + size; + size_t i = findLower(set, start); + + // check previous interval if it is overlapping or adjacent + if (i > 0 && start <= set->data[i-1].end + 1) { + // merge with left interval + i--; + if (end > set->data[i].end) { + set->data[i].end = end; + } + } else { + // insert new interval + ensureCapacity(set, set->size + 1); + memmove(&set->data[i+1], &set->data[i], sizeof(ProddableBlock) * (set->size - i)); + set->data[i].start = start; + set->data[i].end = end; + set->size++; + } + + // coalesce overlaps on right + size_t j = i; + while (j < set->size && set->data[j].start <= set->data[i].end + 1) { + set->data[i].end = set->data[j].end; + j++; + } + + if (j != i) { + memmove(&set->data[i+1], &set->data[j], sizeof(ProddableBlock) * (set->size - j)); + set->size -= j - i - 1; + } +} + ===================================== rts/linker/ProddableBlocks.h ===================================== @@ -0,0 +1,38 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2025 + * + * RTS Object Linker + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +#include <stdbool.h> +#include <stddef.h> +#include <stdint.h> + +// An interval set on uintptr_t. +struct _ProddableBlock; + +typedef struct { + size_t size; + size_t capacity; + // sorted list of disjoint (start,end) pairs + struct _ProddableBlock *data; +} ProddableBlockSet; + +void initProddableBlockSet ( ProddableBlockSet* set ); + +// Insert an interval. +void addProddableBlock ( ProddableBlockSet* set, void* start, size_t size ); + +// Check that an address belongs to the set. +void checkProddableBlock (const ProddableBlockSet *set, void *addr, size_t size ); + + +// Free a set. +void freeProddableBlocks (ProddableBlockSet *set); + +// For testing. +bool containsSpan ( const ProddableBlockSet *set, uintptr_t start, uintptr_t end ); ===================================== rts/rts.cabal ===================================== @@ -491,6 +491,7 @@ library linker/MachO.c linker/macho/plt.c linker/macho/plt_aarch64.c + linker/ProddableBlocks.c linker/PEi386.c linker/SymbolExtras.c linker/elf_got.c ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -322,7 +322,7 @@ module Control.Exception.Backtrace where type BacktraceMechanism :: * data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace type Backtraces :: * - data Backtraces = ... + data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]} collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces displayBacktraces :: Backtraces -> GHC.Internal.Base.String getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -322,7 +322,7 @@ module Control.Exception.Backtrace where type BacktraceMechanism :: * data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace type Backtraces :: * - data Backtraces = ... + data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]} collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces displayBacktraces :: Backtraces -> GHC.Internal.Base.String getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -322,7 +322,7 @@ module Control.Exception.Backtrace where type BacktraceMechanism :: * data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace type Backtraces :: * - data Backtraces = ... + data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]} collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces displayBacktraces :: Backtraces -> GHC.Internal.Base.String getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -322,7 +322,7 @@ module Control.Exception.Backtrace where type BacktraceMechanism :: * data BacktraceMechanism = CostCentreBacktrace | HasCallStackBacktrace | ExecutionBacktrace | IPEBacktrace type Backtraces :: * - data Backtraces = ... + data Backtraces = Backtraces {btrCostCentre :: GHC.Internal.Maybe.Maybe (GHC.Internal.Ptr.Ptr GHC.Internal.Stack.CCS.CostCentreStack), btrHasCallStack :: GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.CallStack, btrExecutionStack :: GHC.Internal.Maybe.Maybe [GHC.Internal.ExecutionStack.Internal.Location], btrIpe :: GHC.Internal.Maybe.Maybe [GHC.Internal.Stack.CloneStack.StackEntry]} collectBacktraces :: (?callStack::GHC.Internal.Stack.Types.CallStack) => GHC.Internal.Types.IO Backtraces displayBacktraces :: Backtraces -> GHC.Internal.Base.String getBacktraceMechanismState :: BacktraceMechanism -> GHC.Internal.Types.IO GHC.Internal.Types.Bool ===================================== testsuite/tests/rts/TestProddableBlockSet.c ===================================== @@ -0,0 +1,33 @@ +#include <assert.h> +#include <stdbool.h> +#include <stdint.h> +#include <stddef.h> + +// Excerpted from ProddableBlocks.h +typedef struct { + size_t size; + size_t capacity; + // sorted list of disjoint (start,end) pairs + struct _ProddableBlock *data; +} ProddableBlockSet; + +void initProddableBlockSet ( ProddableBlockSet* set ); +void addProddableBlock ( ProddableBlockSet* set, void* start, size_t size ); +bool containsSpan ( const ProddableBlockSet *set, uintptr_t start, uintptr_t end ); + +int main () { + ProddableBlockSet set; + initProddableBlockSet(&set); + addProddableBlock(&set, (void*) 0x20, 0x10); + addProddableBlock(&set, (void*) 0x30, 0x10); + addProddableBlock(&set, (void*) 0x100, 0x10); + + assert( containsSpan(&set, 0x20, 0x30)); + assert( containsSpan(&set, 0x30, 0x29)); + assert(!containsSpan(&set, 0x30, 0x49)); + assert(!containsSpan(&set, 0x60, 0x70)); + assert(!containsSpan(&set, 0x90, 0x110)); + assert( containsSpan(&set, 0x100, 0x101)); + return 0; +} + ===================================== testsuite/tests/rts/all.T ===================================== @@ -641,3 +641,5 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru # N.B. This will likely issue a warning on stderr but we merely care that the # program doesn't crash. test('T25560', [req_c_rts, ignore_stderr], compile_and_run, ['']) + +test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0fdcb69d4a5553e05ca9709c0413f1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0fdcb69d4a5553e05ca9709c0413f1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25992] Further wibbles
by Simon Peyton Jones (＠simonpj) 23 May '25

23 May '25

Simon Peyton Jones pushed to branch wip/T25992 at Glasgow Haskell Compiler / GHC Commits: 8e5f3bd4 by Simon Peyton Jones at 2025-05-23T09:40:33+01:00 Further wibbles - - - - - 4 changed files: - compiler/GHC/Tc/Solver/Default.hs - + testsuite/tests/typecheck/should_compile/T25992.hs - + testsuite/tests/typecheck/should_compile/T25992.stderr - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -247,11 +247,11 @@ tryUnsatisfiableGivens wc = ; solveAgainIf did_work final_wc } where go_wc (WC { wc_simple = wtds, wc_impl = impls, wc_errors = errs }) - = do impls' <- mapMaybeBagM go_impl impls + = do impls' <- mapBagM go_impl impls return $ WC { wc_simple = wtds, wc_impl = impls', wc_errors = errs } go_impl impl | isSolvedStatus (ic_status impl) - = return $ Just impl + = return impl -- Is there a Given with type "Unsatisfiable msg"? -- If so, use it to solve all other Wanteds. | unsat_given:_ <- mapMaybe unsatisfiableEv_maybe (ic_given impl) @@ -271,7 +271,7 @@ unsatisfiableEv_maybe v = (v,) <$> isUnsatisfiableCt_maybe (idType v) -- | We have an implication with an 'Unsatisfiable' Given; use that Given to -- solve all the other Wanted constraints, including those nested within -- deeper implications. -solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS (Maybe Implication) +solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS Implication solveImplicationUsingUnsatGiven unsat_given@(given_ev,_) impl@(Implic { ic_wanted = wtd, ic_tclvl = tclvl, ic_binds = ev_binds_var @@ -279,7 +279,7 @@ solveImplicationUsingUnsatGiven | isCoEvBindsVar ev_binds_var -- We can't use Unsatisfiable evidence in kinds. -- See Note [Coercion evidence only] in GHC.Tc.Types.Evidence. - = return $ Just impl + = return impl | otherwise = do { wcs <- nestImplicTcS ev_binds_var tclvl $ go_wc wtd ; setImplicationStatus $ @@ -290,7 +290,7 @@ solveImplicationUsingUnsatGiven go_wc :: WantedConstraints -> TcS WantedConstraints go_wc wc@(WC { wc_simple = wtds, wc_impl = impls }) = do { mapBagM_ go_simple wtds - ; impls <- mapMaybeBagM (solveImplicationUsingUnsatGiven unsat_given) impls + ; impls <- mapBagM (solveImplicationUsingUnsatGiven unsat_given) impls ; return $ wc { wc_simple = emptyBag, wc_impl = impls } } go_simple :: Ct -> TcS () go_simple ct = case ctEvidence ct of ===================================== testsuite/tests/typecheck/should_compile/T25992.hs ===================================== @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wredundant-constraints #-} + +module T25992 where + +data P a = P + +instance Eq a => Semigroup (P a) where + P <> P = P ===================================== testsuite/tests/typecheck/should_compile/T25992.stderr ===================================== @@ -0,0 +1,3 @@ + T25992.hs:7:10: error: [GHC-30606] [-Wredundant-constraints, Werror=redundant-constraints] + • Redundant constraint: Eq a + • In the instance declaration for ‘Semigroup (P a)’ ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -941,3 +941,4 @@ test('T25597', normal, compile, ['']) test('T25960', normal, compile, ['']) test('T26020', normal, compile, ['']) test('T26020a', [extra_files(['T26020a_help.hs'])], multimod_compile, ['T26020a', '-v0']) +test('T25992', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e5f3bd4c27578ad355bbdeeaf1283a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e5f3bd4c27578ad355bbdeeaf1283a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/top-level-bcos-tag] 2 commits: debugger/rts: Allow toggling step-in per thread
by Rodrigo Mesquita (＠alt-romes) 23 May '25

23 May '25

Rodrigo Mesquita pushed to branch wip/romes/top-level-bcos-tag at Glasgow Haskell Compiler / GHC Commits: b0249bf0 by Rodrigo Mesquita at 2025-05-23T09:04:51+01:00 debugger/rts: Allow toggling step-in per thread The RTS global flag `rts_stop_next_breakpoint` globally sets the interpreter to stop at the immediate next breakpoint. With this commit, single step mode can additionally be set per thread in the TSO flag (TSO_STOP_NEXT_BREAKPOINT). Being able to toggle "stop at next breakpoint" per thread is an important requirement for implementing "stepping out" of a function in a multi-threaded context. And, more generally, having a per-thread flag for single-stepping paves the way for multi-threaded debugging. That said, when we want to enable "single step" mode for the whole interpreted program we still want to stop at the immediate next breakpoint, whichever thread it belongs to. That's why we also keep the global `rts_stop_next_breakpoint` flag, with `rts_enableStopNextBreakpointAll` and `rts_disableStopNextBreakpointAll` helpers. Preparation for #26042 - - - - - 8c40855b by Rodrigo Mesquita at 2025-05-23T09:16:43+01:00 rts: Case continuation BCOs This commit introduces the `stg_CASE_CONT_BCO` info table, which is identical to `stg_BCO` and shares the same closure type (== BCO). It changes the bytecode generator to always use `stg_CASE_CONT_BCO_info` when constructing case continuation BCOs, and remain using `stg_BCO` otherwise. This allows us to distinguish at runtime case continuation BCOs from other BCOs. In particular, this is relevant because, unlike other BCOs, the code of a case continuation BCO may refer to variables in its parent's stack frame (ie non-local variables), and therefore its frame position on the stack cannot be changed in isolation. The full motivation and details are in Note [Case continuation BCOs]. Towards #26042 - - - - - 25 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/StgToByteCode.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghci/GHCi/CreateBCO.hs - + libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/ResolvedBCO.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Interpreter.c - rts/Interpreter.h - rts/PrimOps.cmm - rts/Printer.c - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/rts/Constants.h - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3872,12 +3872,13 @@ primop MkApUpd0_Op "mkApUpd0#" GenPrimOp with out_of_line = True -primop NewBCOOp "newBCO#" GenPrimOp - ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) - { @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The +primop NewBCOOp "newBCO2#" GenPrimOp + Int8# -> ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) + { @'newBCO2#' is_case_cont instrs lits ptrs arity bitmap@ creates a new bytecode object. The resulting object encodes a function of the given arity with the instructions encoded in @instrs@, and a static reference table usage bitmap given by - @bitmap@. } + @bitmap@. The @is_case_cont@ boolean indicates whether the BCO is a case + continuation (see Note [Case continuation BCOs]) } with effect = ReadWriteEffect out_of_line = True ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -85,7 +85,7 @@ bcoFreeNames :: UnlinkedBCO -> UniqDSet Name bcoFreeNames bco = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] where - bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs _) = unionManyUniqDSets ( mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] : mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] : @@ -236,7 +236,8 @@ assembleBCO platform , protoBCOInstrs = instrs , protoBCOBitmap = bitmap , protoBCOBitmapSize = bsize - , protoBCOArity = arity }) = do + , protoBCOArity = arity + , protoBCOIsCaseCont = isCC }) = do -- pass 1: collect up the offsets of the local labels. let initial_offset = 0 @@ -266,7 +267,7 @@ assembleBCO platform let !insns_arr = mkBCOByteArray $ final_isn_array !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap - ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array) + ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array) isCC -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -53,7 +53,8 @@ data ProtoBCO a -- what the BCO came from, for debugging only protoBCOExpr :: Either [CgStgAlt] CgStgRhs, -- malloc'd pointers - protoBCOFFIs :: [FFIInfo] + protoBCOFFIs :: [FFIInfo], + protoBCOIsCaseCont :: !Bool -- See Note [Case continuation BCOs] } -- | A local block label (e.g. identifying a case alternative). ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -59,7 +59,7 @@ linkBCO -> UnlinkedBCO -> IO ResolvedBCO linkBCO interp pkgs_loaded le bco_ix - (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do + (UnlinkedBCO _ arity insns bitmap lits0 ptrs0 isCC) = do -- fromIntegral Word -> Word64 should be a no op if Word is Word64 -- otherwise it will result in a cast to longlong on 32bit systems. (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0) @@ -69,7 +69,7 @@ linkBCO interp pkgs_loaded le bco_ix insns bitmap (mkBCOByteArray lits') - (addListToSS emptySS ptrs)) + (addListToSS emptySS ptrs) isCC) lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word lookupLiteral interp pkgs_loaded le ptr = case ptr of ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -167,14 +167,108 @@ newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable) newtype AddrPtr = AddrPtr (RemotePtr ()) deriving (NFData) +{- +-------------------------------------------------------------------------------- +-- * Byte Code Objects (BCOs) +-------------------------------------------------------------------------------- + +Note [Case continuation BCOs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A stack with a BCO stack frame at the top looks like: + + (an StgBCO) + | ... | +---> +---------[1]--+ + +------------------+ | | info_tbl_ptr | ------+ + | OTHER FRAME | | +--------------+ | + +------------------+ | | StgArrBytes* | <--- the byte code + | ... | | +--------------+ | + +------------------+ | | ... | | + | fvs1 | | | + +------------------+ | | + | ... | | (StgInfoTable) | + +------------------+ | +----------+ <---+ + | args1 | | | ... | + +------------------+ | +----------+ + | some StgBCO* | -----+ | type=BCO | + +------------------+ +----------+ + Sp | stg_apply_interp | -----+ | ... | + +------------------+ | + | + | (StgInfoTable) + +----> +--------------+ + | ... | + +--------------+ + | type=RET_BCO | + +--------------+ + | ... | + + +The byte code for a BCO heap object makes use of arguments and free variables +which can typically be found within the BCO stack frame. In the code, these +variables are referenced via a statically known stack offset (tracked using +`BCEnv` in `StgToByteCode`). + +However, in /case continuation/ BCOs, the code may additionally refer to free +variables that are outside of that BCO's stack frame -- some free variables of a +case continuation BCO may only be found in the stack frame of a parent BCO. + +Yet, references to these out-of-frame variables are also done in terms of stack +offsets. Thus, they rely on the position of /another frame/ to be fixed. (See +Note [PUSH_L underflow] for more information about references to previous +frames and nested BCOs) + +This makes case continuation BCOs special: unlike normal BCOs, case cont BCO +frames cannot be moved on the stack independently from their parent BCOs. + +In order to be able to distinguish them at runtime, the code generator will use +distinct info table pointers for their closures, even though they will have the +same structure on the heap (StgBCO). Specifically: + + - Normal BCOs are always headed by the `stg_BCO_info` pointer. + - Case continuation BCOs are always headed by the `stg_CASE_CONT_BCO_info` pointer. + +A primary reason why we need to distinguish these two cases is to know where we +can insert a debugger step-out frame (`stg_stop_after_ret_frame`). In +particular, because case cont BCOs may refer to the parent frame, we must not +insert step-out frames between a case cont BCO and its parent. + +As an example, consider the following, where `y` is free in the case alternatives: + + f x y = case x of + True -> y - 1 + False -> y + 1 :: Int + +While interpreting f, the args x and y will be on the stack as part of f's frame. +In its body, a case continuation BCO is pushed (PUSH_ALTS) and then `x` is +entered to be evaluated. Upon entering `x`, the stack would look something like: + + <f arg 2> + <f arg 1> + ... + <Case continuation BCO Frame> + +We cannot insert a step out frame in between: + + + <f arg 2> + <f arg 1> + ... + <inserted step-out frame> <--- BAD! Breaks stack offsets in the case cont. + <Case continuation BCO Frame> + +Instead, we must traverse until the parent BCO and insert the step-out frame before it instead. +-} + data UnlinkedBCO = UnlinkedBCO { unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns - unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap + unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns + unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs + unlinkedBCOPtrs :: !(FlatBag BCOPtr), -- ptrs + unlinkedBCOIsCaseCont :: !Bool -- See Note [Case continuation BCOs] } instance NFData UnlinkedBCO where @@ -227,10 +321,11 @@ seqCgBreakInfo CgBreakInfo{..} = rnf cgb_resty instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs pi) = sep [text "BCO", ppr nm, text "with", ppr (sizeFlatBag lits), text "lits", - ppr (sizeFlatBag ptrs), text "ptrs" ] + ppr (sizeFlatBag ptrs), text "ptrs", + ppr pi, text "is_pos_indep"] instance Outputable CgBreakInfo where ppr info = text "CgBreakInfo" <+> ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -253,7 +253,11 @@ mkProtoBCO -> Int -- ^ arity -> WordOff -- ^ bitmap size -> [StgWord] -- ^ bitmap - -> Bool -- ^ True <=> is a return point, rather than a function + -> Bool -- ^ True <=> it's a case continuation, rather than a function + -- Used for + -- (A) Stack check collision and + -- (B) Mark the BCO wrt whether it contains non-local stack + -- references. See Note [Case continuation BCOs]. -> [FFIInfo] -> ProtoBCO Name mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis @@ -264,7 +268,8 @@ mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bit protoBCOBitmapSize = fromIntegral bitmap_size, protoBCOArity = arity, protoBCOExpr = origin, - protoBCOFFIs = ffis + protoBCOFFIs = ffis, + protoBCOIsCaseCont = is_ret } where #if MIN_VERSION_rts(1,0,3) @@ -353,6 +358,9 @@ schemeTopBind (id, rhs) -- Park the resulting BCO in the monad. Also requires the -- name of the variable to which this value was bound, -- so as to give the resulting BCO a name. +-- +-- The resulting ProtoBCO expects the free variables and the function arguments +-- to be in the stack directly before it. schemeR :: [Id] -- Free vars of the RHS, ordered as they -- will appear in the thunk. Empty for -- top-level things, which have no free vars. @@ -391,6 +399,8 @@ schemeR_wrk fvs nm original_body (args, body) -- them unlike constructor fields. szsb_args = map (wordsToBytes platform . idSizeW platform) all_args sum_szsb_args = sum szsb_args + -- Make a stack offset for each argument or free var -- they should + -- appear contiguous in the stack, in order. p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) -- make the arg bitmap @@ -1401,7 +1411,7 @@ Note [unboxed tuple bytecodes and tuple_BCO] tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name tupleBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} + 0{-no arity-} bitmap_size bitmap False{-not alts-} where {- The tuple BCO is never referred to by name, so we can get away @@ -1422,7 +1432,7 @@ tupleBCO platform args_info args = primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name primCallBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} + 0{-no arity-} bitmap_size bitmap False{-not alts-} where {- The primcall BCO is never referred to by name, so we can get away ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -26,12 +26,12 @@ module GHC.Exts -- ** Legacy interface for arrays of arrays module GHC.Internal.ArrayArray, -- * Primitive operations - {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} + {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 10.14", "These symbols should be imported from ghc-internal instead if needed."] #-} Prim.BCO, {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} Prim.mkApUpd0#, {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} - Prim.newBCO#, + IExts.newBCO#, module GHC.Prim, module GHC.Prim.Ext, -- ** Running 'RealWorld' state thread @@ -119,7 +119,7 @@ module GHC.Exts maxTupleSize ) where -import GHC.Internal.Exts +import GHC.Internal.Exts hiding ( newBCO# ) import GHC.Internal.ArrayArray import GHC.Prim hiding ( coerce @@ -132,7 +132,7 @@ import GHC.Prim hiding , isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned# -- deprecated - , BCO, mkApUpd0#, newBCO# + , BCO, mkApUpd0# -- Don't re-export vector FMA instructions , fmaddFloatX4# @@ -256,8 +256,10 @@ import GHC.Prim hiding , minWord8X32# , minWord8X64# ) +import qualified GHC.Internal.Exts as IExts + ( newBCO# ) import qualified GHC.Prim as Prim - ( BCO, mkApUpd0#, newBCO# ) + ( BCO, mkApUpd0# ) import GHC.Prim.Ext ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -624,6 +624,7 @@ data TsoFlags | TsoMarked | TsoSqueezed | TsoAllocLimit + | TsoStopNextBreakpoint | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug deriving (Eq, Show, Generic, Ord) ===================================== libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc ===================================== @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +#if __GLASGOW_HASKELL__ >= 913 + | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w) +#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] ===================================== libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc ===================================== @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +#if __GLASGOW_HASKELL__ >= 913 + | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w) +#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] ===================================== libraries/ghc-heap/tests/parse_tso_flags.hs ===================================== @@ -13,5 +13,6 @@ main = do assertEqual (parseTsoFlags 64) [TsoMarked] assertEqual (parseTsoFlags 128) [TsoSqueezed] assertEqual (parseTsoFlags 256) [TsoAllocLimit] + assertEqual (parseTsoFlags 512) [TsoStopNextBreakpoint] assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx] ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -163,6 +163,9 @@ module GHC.Internal.Exts -- * The maximum tuple size maxTupleSize, + + -- * Interpreter + newBCO# ) where import GHC.Internal.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge#, whereFrom# ) @@ -469,3 +472,18 @@ resizeSmallMutableArray# arr0 szNew a s0 = -- accessible\" by word. considerAccessible :: Bool considerAccessible = True + +-------------------------------------------------------------------------------- +-- Interpreter + +{-| +@'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The +resulting object encodes a function of the given arity with the instructions +encoded in @instrs@, and a static reference table usage bitmap given by +@bitmap@. + +Note: Case continuation BCOs, with non-local stack references, must be +constructed using @'newBCO2#' 1@ instead. See Note [Case continuation BCOs]. +-} +newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) +newBCO# b1 b2 a1 i1 b3 s = newBCO2# (intToInt8# 0#) b1 b2 a1 i1 b3 s ===================================== libraries/ghci/GHCi/CreateBCO.hs ===================================== @@ -87,11 +87,11 @@ linkBCO' arr ResolvedBCO{..} = do literals_barr = barr (getBCOByteArray resolvedBCOLits) PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs + let is_case_cont | resolvedBCOIsCaseCont = intToInt8# 1# + | otherwise = intToInt8# 0# IO $ \s -> case unsafeFreezeArray# marr s of { (# s, arr #) -> - case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io -> - io s - }} + newBCO2# is_case_cont insns_barr literals_barr arr arity# bitmap_barr s } -- we recursively link any sub-BCOs while making the ptrs array ===================================== libraries/ghci/GHCi/Debugger.hs ===================================== @@ -0,0 +1,67 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module GHCi.Debugger + ( + -- * Single step mode + rts_enableStopNextBreakpoint + , rts_enableStopNextBreakpointAll + , rts_disableStopNextBreakpoint + , rts_disableStopNextBreakpointAll + + -- * Stop on exception + , exceptionFlag + + -- * Breakpoint Callback + , BreakpointCallback + , breakPointIOAction + ) where + +import Prelude -- See note [Why do we import Prelude here?] + +import GHC.Base (ThreadId#, Addr#, Int#) +import Foreign.C (CInt) +import Foreign (StablePtr, Ptr, Storable (..)) +import GHCi.RemoteTypes (HValue) + +-------------------------------------------------------------------------------- +-- Single step mode + +-- | Enables the single step mode for a specific thread, thus stopping only on +-- breakpoints in that thread. +foreign import ccall unsafe "rts_enableStopNextBreakpoint" + rts_enableStopNextBreakpoint :: ThreadId# -> IO () + +-- | Disables per-thread single-step mode. Note: if global single-step is +-- enabled we stop at all breakpoints regardless of the per-thread flag. +foreign import ccall unsafe "rts_disableStopNextBreakpoint" + rts_disableStopNextBreakpoint :: ThreadId# -> IO () + +-- | Enables the single step mode for all threads, thus stopping at any +-- existing breakpoint. +foreign import ccall unsafe "rts_enableStopNextBreakpointAll" + rts_enableStopNextBreakpointAll :: IO () + +-- | Disables the single step mode for all threads +foreign import ccall unsafe "rts_disableStopNextBreakpointAll" + rts_disableStopNextBreakpointAll :: IO () + +-------------------------------------------------------------------------------- + +foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt + +-------------------------------------------------------------------------------- + +type BreakpointCallback + = Addr# -- pointer to the breakpoint tick module name + -> Addr# -- pointer to the breakpoint tick module unit id + -> Int# -- breakpoint tick index + -> Addr# -- pointer to the breakpoint info module name + -> Addr# -- pointer to the breakpoint info module unit id + -> Int# -- breakpoint info index + -> Bool -- exception? + -> HValue -- the AP_STACK, or exception + -> IO () + +foreign import ccall "&rts_breakpoint_io_action" + breakPointIOAction :: Ptr (StablePtr BreakpointCallback) + ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -45,7 +45,8 @@ data ResolvedBCO resolvedBCOBitmap :: BCOByteArray Word, -- ^ bitmap resolvedBCOLits :: BCOByteArray Word, -- ^ non-ptrs - subword sized entries still take up a full (host) word - resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ^ ptrs + resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr), -- ^ ptrs + resolvedBCOIsCaseCont :: !Bool -- ^ See Note [Case continuation BCOs] } deriving (Generic, Show) @@ -86,7 +87,8 @@ instance Binary ResolvedBCO where put resolvedBCOBitmap put resolvedBCOLits put resolvedBCOPtrs - get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get + put resolvedBCOIsCaseCont + get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get <*> get -- See Note [BCOByteArray serialization] instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP, - UnboxedTuples, LambdaCase #-} + UnboxedTuples, LambdaCase, UnliftedFFITypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -20,6 +20,7 @@ import GHCi.InfoTable #endif import qualified GHC.InfoProv as InfoProv +import GHCi.Debugger import GHCi.FFI import GHCi.Message import GHCi.ObjLink @@ -332,7 +333,7 @@ withBreakAction opts breakMVar statusMVar act stablePtr <- newStablePtr onBreak poke breakPointIOAction stablePtr when (breakOnException opts) $ poke exceptionFlag 1 - when (singleStep opts) $ setStepFlag + when (singleStep opts) rts_enableStopNextBreakpointAll return stablePtr -- Breaking on exceptions is not enabled by default, since it -- might be a bit surprising. The exception flag is turned off @@ -363,7 +364,7 @@ withBreakAction opts breakMVar statusMVar act resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr poke exceptionFlag 0 - resetStepFlag + rts_disableStopNextBreakpointAll freeStablePtr stablePtr resumeStmt @@ -396,28 +397,6 @@ abandonStmt hvref = do _ <- takeMVar resumeStatusMVar return () -foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt -foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt - -setStepFlag :: IO () -setStepFlag = poke stepFlag 1 -resetStepFlag :: IO () -resetStepFlag = poke stepFlag 0 - -type BreakpointCallback - = Addr# -- pointer to the breakpoint tick module name - -> Addr# -- pointer to the breakpoint tick module unit id - -> Int# -- breakpoint tick index - -> Addr# -- pointer to the breakpoint info module name - -> Addr# -- pointer to the breakpoint info module unit id - -> Int# -- breakpoint info index - -> Bool -- exception? - -> HValue -- the AP_STACK, or exception - -> IO () - -foreign import ccall "&rts_breakpoint_io_action" - breakPointIOAction :: Ptr (StablePtr BreakpointCallback) - noBreakStablePtr :: StablePtr BreakpointCallback noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction ===================================== libraries/ghci/ghci.cabal.in ===================================== @@ -60,6 +60,7 @@ library CPP-Options: -DHAVE_INTERNAL_INTERPRETER exposed-modules: GHCi.Run + GHCi.Debugger GHCi.CreateBCO GHCi.ObjLink GHCi.Signals ===================================== rts/Interpreter.c ===================================== @@ -203,14 +203,14 @@ PUSH_L instruction. |---------| | BCO_1 | -<-┐ -|---------| +|---------| | ......... | |---------| | PUSH_L <n> | BCO_N | ->-┘ |---------| Here BCO_N is syntactically nested within the code for BCO_1 and will result -in code that references the prior stack frame of BCO_1 for some of it's local +in code that references the prior stack frame of BCO_1 for some of its local variables. If a stack overflow happens between the creation of the stack frame for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving BCO_1 in place, invalidating a simple offset based reference to the outer stack @@ -243,9 +243,44 @@ allocate_NONUPD (Capability *cap, int n_words) return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } -int rts_stop_next_breakpoint = 0; int rts_stop_on_exception = 0; +/* --------------------------------------------------------------------------- + * Enabling and disabling global single step mode + * ------------------------------------------------------------------------ */ + +/* A global toggle for single-step mode. + * Unlike `TSO_STOP_NEXT_BREAKPOINT`, which sets single-step mode per-thread, + * `rts_stop_next_breakpoint` globally enables single-step mode. If enabled, we + * will stop at the immediate next breakpoint regardless of what thread it is in. */ +int rts_stop_next_breakpoint = 0; + +void rts_enableStopNextBreakpointAll(void) +{ + rts_stop_next_breakpoint = 1; +} + +void rts_disableStopNextBreakpointAll(void) +{ + rts_stop_next_breakpoint = 0; +} + +/* --------------------------------------------------------------------------- + * Enabling and disabling per-thread single step mode + * ------------------------------------------------------------------------ */ + +void rts_enableStopNextBreakpoint(StgPtr tso) +{ + ((StgTSO *)tso)->flags |= TSO_STOP_NEXT_BREAKPOINT; +} + +void rts_disableStopNextBreakpoint(StgPtr tso) +{ + ((StgTSO *)tso)->flags &= ~TSO_STOP_NEXT_BREAKPOINT; +} + +/* -------------------------------------------------------------------------- */ + #if defined(INTERP_STATS) #define N_CODES 128 @@ -508,14 +543,35 @@ interpretBCO (Capability* cap) // // We have a BCO application to perform. Stack looks like: // - // | .... | - // +---------------+ - // | arg1 | - // +---------------+ - // | BCO | - // +---------------+ - // Sp | RET_BCO | - // +---------------+ + // + // (an StgBCO) + // +---> +---------[1]--+ + // | | stg_BCO_info | ------+ + // | +--------------+ | + // | | StgArrBytes* | <--- the byte code + // | ... | | +--------------+ | + // +------------------+ | | ... | | + // | fvs1 | | | + // +------------------+ | | + // | ... | | (StgInfoTable) | + // +------------------+ | +----------+ <---+ + // | args1 | | | ... | + // +------------------+ | +----------+ + // | some StgBCO* | -----+ | type=BCO | + // +------------------+ +----------+ + // Sp | stg_apply_interp | -----+ | ... | + // +------------------+ | + // | + // | (StgInfoTable) + // +----> +--------------+ + // | ... | + // +--------------+ + // | type=RET_BCO | + // +--------------+ + // | ... | + // + // [1] An StgBCO's info table pointer may also be stg_CASE_CONT_BCO_info. + // See Note [Case continuation BCOs]. // else if (SpW(0) == (W_)&stg_apply_interp_info) { obj = UNTAG_CLOSURE((StgClosure *)ReadSpW(1)); @@ -1250,7 +1306,7 @@ run_BCO: int arg8_cc; #endif StgArrBytes *breakPoints; - int returning_from_break; + int returning_from_break, stop_next_breakpoint; // the io action to run at a breakpoint StgClosure *ioAction; @@ -1280,6 +1336,13 @@ run_BCO: returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; + // check whether this thread is set to stop at the immediate next + // breakpoint -- either by the global `rts_stop_next_breakpoint` + // flag, or by the local `TSO_STOP_NEXT_BREAKPOINT` + stop_next_breakpoint = + rts_stop_next_breakpoint || + cap->r.rCurrentTSO->flags & TSO_STOP_NEXT_BREAKPOINT; + #if defined(PROFILING) cap->r.rCCCS = pushCostCentre(cap->r.rCCCS, (CostCentre*)BCO_LIT(arg8_cc)); @@ -1291,20 +1354,20 @@ run_BCO: { breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array); - // 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 + // stop the current thread if either `stop_next_breakpoint` is + // true OR if the ignore count for this particular breakpoint is zero StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index]; - if (rts_stop_next_breakpoint == false && ignore_count > 0) + if (stop_next_breakpoint == false && ignore_count > 0) { // decrement and write back ignore count ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count; } - else if (rts_stop_next_breakpoint == true || ignore_count == 0) + else if (stop_next_breakpoint == true || ignore_count == 0) { // make sure we don't automatically stop at the // next breakpoint - rts_stop_next_breakpoint = false; + rts_stop_next_breakpoint = 0; + cap->r.rCurrentTSO->flags &= ~TSO_STOP_NEXT_BREAKPOINT; // allocate memory for a new AP_STACK, enough to // store the top stack frame plus an @@ -1477,7 +1540,7 @@ run_BCO: // Here we make sure references we push are tagged. // See Note [CBV Functions and the interpreter] in Info.hs - //Safe some memory reads if we already have a tag. + //Save some memory reads if we already have a tag. if(GET_CLOSURE_TAG(tagged_obj) == 0) { StgClosure *obj = UNTAG_CLOSURE(tagged_obj); switch ( get_itbl(obj)->type ) { ===================================== rts/Interpreter.h ===================================== @@ -11,3 +11,8 @@ RTS_PRIVATE Capability *interpretBCO (Capability* cap); void interp_startup ( void ); void interp_shutdown ( void ); + +void rts_enableStopNextBreakpointAll ( void ); +void rts_disableStopNextBreakpointAll ( void ); +void rts_enableStopNextBreakpoint ( StgPtr ); +void rts_disableStopNextBreakpoint ( StgPtr ); ===================================== rts/PrimOps.cmm ===================================== @@ -55,6 +55,7 @@ import CLOSURE stg_AP_STACK_info; import CLOSURE stg_AP_info; import CLOSURE stg_ARR_WORDS_info; import CLOSURE stg_BCO_info; +import CLOSURE stg_CASE_CONT_BCO_info; import CLOSURE stg_C_FINALIZER_LIST_info; import CLOSURE stg_DEAD_WEAK_info; import CLOSURE stg_END_STM_WATCH_QUEUE_closure; @@ -2434,7 +2435,8 @@ stg_deRefStablePtrzh ( P_ sp ) Bytecode object primitives ------------------------------------------------------------------------- */ -stg_newBCOzh ( P_ instrs, +stg_newBCO2zh ( CBool is_case_cont, + P_ instrs, P_ literals, P_ ptrs, W_ arity, @@ -2449,7 +2451,16 @@ stg_newBCOzh ( P_ instrs, bco = Hp - bytes + WDS(1); // No memory barrier necessary as this is a new allocation. - SET_HDR(bco, stg_BCO_info, CCS_MAIN); + if (is_case_cont > 0) { + /* Uses stg_CASE_CONT_BCO_info to construct the BCO frame (rather than stg_BCO_info). + * Case continuations may contain non-local references to parent frames. The distinct info table + * tag allows the RTS to identify such non-local frames. + * See Note [Case continuation BCOs] + */ + SET_HDR(bco, stg_CASE_CONT_BCO_info, CCS_MAIN); + } else { + SET_HDR(bco, stg_BCO_info, CCS_MAIN); + } StgBCO_instrs(bco) = instrs; StgBCO_literals(bco) = literals; ===================================== rts/Printer.c ===================================== @@ -690,6 +690,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) debugBelch("stg_ctoi_V_info" ); } else if (c == (StgWord)&stg_BCO_info) { debugBelch("stg_BCO_info" ); + } else if (c == (StgWord)&stg_CASE_CONT_BCO_info) { + debugBelch("stg_CASE_CONT_BCO_info" ); } else if (c == (StgWord)&stg_apply_interp_info) { debugBelch("stg_apply_interp_info" ); } else if (c == (StgWord)&stg_ret_t_info) { ===================================== rts/RtsSymbols.c ===================================== @@ -639,7 +639,7 @@ extern char **environ; SymI_HasDataProto(stg_copySmallMutableArrayzh) \ SymI_HasDataProto(stg_casSmallArrayzh) \ SymI_HasDataProto(stg_copyArray_barrier) \ - SymI_HasDataProto(stg_newBCOzh) \ + SymI_HasDataProto(stg_newBCO2zh) \ SymI_HasDataProto(stg_newByteArrayzh) \ SymI_HasDataProto(stg_casIntArrayzh) \ SymI_HasDataProto(stg_casInt8Arrayzh) \ @@ -906,7 +906,8 @@ extern char **environ; SymI_HasProto(revertCAFs) \ SymI_HasProto(RtsFlags) \ SymI_NeedsDataProto(rts_breakpoint_io_action) \ - SymI_NeedsDataProto(rts_stop_next_breakpoint) \ + SymI_NeedsDataProto(rts_enableStopNextBreakpointAll) \ + SymI_NeedsDataProto(rts_disableStopNextBreakpointAll) \ SymI_NeedsDataProto(rts_stop_on_exception) \ SymI_HasProto(stopTimer) \ SymI_HasProto(n_capabilities) \ ===================================== rts/StgMiscClosures.cmm ===================================== @@ -464,6 +464,12 @@ INFO_TABLE_RET( stg_dead_thread, RET_SMALL, /* ---------------------------------------------------------------------------- Entry code for a BCO + + `stg_BCO` and `stg_CASE_CONT_BCO` distinguish between a BCO that refers to + non-local variables in its code (using a stack offset) and those that do not. + Only case-continuation BCOs should use non-local variables. + Otherwise, `stg_BCO` and `stg_CASE_CONT_BCO` behave the same. + See Note [Case continuation BCOs]. ------------------------------------------------------------------------- */ INFO_TABLE_FUN( stg_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) @@ -478,6 +484,15 @@ INFO_TABLE_FUN( stg_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) jump stg_yield_to_interpreter []; } +INFO_TABLE_FUN( stg_CASE_CONT_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) +{ + /* Exactly as for stg_BCO */ + Sp_adj(-2); + Sp(1) = R1; + Sp(0) = stg_apply_interp_info; + jump stg_yield_to_interpreter []; +} + /* ---------------------------------------------------------------------------- Info tables for indirections. ===================================== rts/include/rts/Constants.h ===================================== @@ -328,6 +328,12 @@ */ #define TSO_ALLOC_LIMIT 256 +/* + * Enables step-in mode for this thread -- it will stop at the immediate next + * breakpoint found in this thread. + */ +#define TSO_STOP_NEXT_BREAKPOINT 512 + /* * The number of times we spin in a spin lock before yielding (see * #3758). To tune this value, use the benchmark in #3758: run the ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -180,6 +180,7 @@ RTS_ENTRY(stg_BLOCKING_QUEUE_CLEAN); RTS_ENTRY(stg_BLOCKING_QUEUE_DIRTY); RTS_FUN(stg_BCO); +RTS_FUN(stg_CASE_CONT_BCO); RTS_ENTRY(stg_EVACUATED); RTS_ENTRY(stg_WEAK); RTS_ENTRY(stg_DEAD_WEAK); @@ -577,7 +578,7 @@ RTS_FUN_DECL(stg_deRefWeakzh); RTS_FUN_DECL(stg_runRWzh); -RTS_FUN_DECL(stg_newBCOzh); +RTS_FUN_DECL(stg_newBCO2zh); RTS_FUN_DECL(stg_mkApUpd0zh); RTS_FUN_DECL(stg_retryzh); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aef9228695b5aaeda7e0aa8a3b4418… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aef9228695b5aaeda7e0aa8a3b4418… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] Specialise: Improve specialisation by refactoring interestingDict
by Andreas Klebinger (＠AndreasK) 23 May '25

23 May '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: fcb5f7ee by Andreas Klebinger at 2025-05-23T10:09:16+02:00 Specialise: Improve specialisation by refactoring interestingDict This MR addresses #26051, which concerns missed type-class specialisation. The main payload of the MR is to completely refactor the key function `interestingDict` in GHC.Core.Opt.Specialise The main change is that we now also look at the structure of the dictionary we consider specializing on, rather than only the type. See the big `Note [Interesting dictionary arguments]` - - - - - 15 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/TcType.hs - + testsuite/tests/perf/should_run/SpecTyFamRun.hs - + testsuite/tests/perf/should_run/SpecTyFamRun.stdout - + testsuite/tests/perf/should_run/SpecTyFam_Import.hs - testsuite/tests/perf/should_run/all.T - + testsuite/tests/simplCore/should_compile/T26051.hs - + testsuite/tests/simplCore/should_compile/T26051.stderr - + testsuite/tests/simplCore/should_compile/T26051_Import.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 @@ -14,9 +16,9 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) -import GHC.Core.Multiplicity -import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith ) +import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) import GHC.Core.Predicate +import GHC.Core.Class( classMethods ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad import qualified GHC.Core.Subst as Core @@ -26,12 +28,12 @@ import GHC.Core.Make ( mkLitRubbish ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable - , mkCast, exprType + , mkCast, exprType, exprIsHNF , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Core.Opt.Arity( collectBindersPushingCo ) --- import GHC.Core.Ppr( pprIds ) +import GHC.Core.Ppr( pprIds ) import GHC.Builtin.Types ( unboxedUnitTy ) @@ -64,8 +66,11 @@ import GHC.Unit.Module.ModGuts import GHC.Core.Unfold import Data.List( partition ) --- import Data.List.NonEmpty ( NonEmpty (..) ) import GHC.Core.Subst (substTickish) +import GHC.Core.TyCon (tyConClass_maybe) +import GHC.Core.DataCon (dataConTyCon) + +import Control.Monad {- ************************************************************************ @@ -1585,9 +1590,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- switch off specialisation for inline functions = -- pprTrace "specCalls: some" (vcat - -- [ text "function" <+> ppr fn - -- , text "calls:" <+> ppr calls_for_me - -- , text "subst" <+> ppr (se_subst env) ]) $ + -- [ text "function" <+> ppr fn + -- , text "calls:" <+> ppr calls_for_me + -- , text "subst" <+> ppr (se_subst env) ]) $ foldlM spec_call ([], [], emptyUDs) calls_for_me | otherwise -- No calls or RHS doesn't fit our preconceptions @@ -1635,21 +1640,21 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , rule_bndrs, rule_lhs_args , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args --- ; pprTrace "spec_call" (vcat --- [ text "fun: " <+> ppr fn --- , text "call info: " <+> ppr _ci --- , text "useful: " <+> ppr useful --- , text "rule_bndrs:" <+> ppr rule_bndrs --- , text "lhs_args: " <+> ppr rule_lhs_args --- , text "spec_bndrs1:" <+> ppr spec_bndrs1 --- , text "leftover_bndrs:" <+> pprIds leftover_bndrs --- , text "spec_args: " <+> ppr spec_args --- , text "dx_binds: " <+> ppr dx_binds --- , text "rhs_bndrs" <+> ppr rhs_bndrs --- , text "rhs_body" <+> ppr rhs_body --- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) --- , ppr dx_binds ]) $ --- return () + ; when False $ pprTrace "spec_call" (vcat + [ text "fun: " <+> ppr fn + , text "call info: " <+> ppr _ci + , text "useful: " <+> ppr useful + , text "rule_bndrs:" <+> ppr rule_bndrs + , text "lhs_args: " <+> ppr rule_lhs_args + , text "spec_bndrs1:" <+> ppr spec_bndrs1 + , text "leftover_bndrs:" <+> pprIds leftover_bndrs + , text "spec_args: " <+> ppr spec_args + , text "dx_binds: " <+> ppr dx_binds + , text "rhs_bndrs" <+> ppr rhs_bndrs + , text "rhs_body" <+> ppr rhs_body + , text "rhs_env2: " <+> ppr (se_subst rhs_env2) + , ppr dx_binds ]) $ + return () ; let all_rules = rules_acc ++ existing_rules -- all_rules: we look both in the rules_acc (generated by this invocation @@ -3043,30 +3048,15 @@ mkCallUDs' env f args -- For "invisibleFunArg", which are the type-class dictionaries, -- we decide on a case by case basis if we want to specialise -- on this argument; if so, SpecDict, if not UnspecArg - mk_spec_arg arg (Anon pred af) + mk_spec_arg arg (Anon _pred af) | isInvisibleFunArg af - , interestingDict arg (scaledThing pred) + , interestingDict env arg + -- , interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg | otherwise = UnspecArg -{- -Note [Ticks on applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Ticks such as source location annotations can sometimes make their way -onto applications (see e.g. #21697). So if we see something like - - App (Tick _ f) e - -we need to descend below the tick to find what the real function being -applied is. - -The resulting RULE also has to be able to match this annotated use -site, so we only look through ticks that RULE matching looks through -(see Note [Tick annotations in RULE matching] in GHC.Core.Rules). --} - wantCallsFor :: SpecEnv -> Id -> Bool -- See Note [wantCallsFor] wantCallsFor _env f @@ -3086,8 +3076,60 @@ wantCallsFor _env f WorkerLikeId {} -> True RepPolyId {} -> True -{- Note [wantCallsFor] -~~~~~~~~~~~~~~~~~~~~~~ +interestingDict :: SpecEnv -> CoreExpr -> Bool +-- This is a subtle and important function +-- See Note [Interesting dictionary arguments] +interestingDict env (Var v) -- See (ID3) and (ID5) + | Just rhs <- maybeUnfoldingTemplate (idUnfolding v) + -- might fail for loop breaker dicts but that seems fine. + = interestingDict env rhs + +interestingDict env arg -- Main Plan: use exprIsConApp_maybe + | Cast inner_arg _ <- arg -- See (ID5) + = if | isConstraintKind $ typeKind $ exprType inner_arg + -- If coercions were always homo-kinded, we'd know + -- that this would be the only case + -> interestingDict env inner_arg + + -- Check for an implicit parameter at the top + | Just (cls,_) <- getClassPredTys_maybe arg_ty + , isIPClass cls -- See (ID4) + -> False + + -- Otherwise we are unwrapping a unary type class + | otherwise + -> exprIsHNF arg -- See (ID7) + + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg + , Just cls <- tyConClass_maybe (dataConTyCon data_con) + , not_ip_like -- See (ID4) + = if null (classMethods cls) -- See (ID6) + then any (interestingDict env) args + else True + + | otherwise + = not (exprIsTrivial arg) && not_ip_like -- See (ID8) + where + arg_ty = exprType arg + not_ip_like = not (couldBeIPLike arg_ty) + in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding + +{- Note [Ticks on applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticks such as source location annotations can sometimes make their way +onto applications (see e.g. #21697). So if we see something like + + App (Tick _ f) e + +we need to descend below the tick to find what the real function being +applied is. + +The resulting RULE also has to be able to match this annotated use +site, so we only look through ticks that RULE matching looks through +(see Note [Tick annotations in RULE matching] in GHC.Core.Rules). + +Note [wantCallsFor] +~~~~~~~~~~~~~~~~~~~ `wantCallsFor env f` says whether the Specialiser should collect calls for function `f`; other thing being equal, the fewer calls we collect the better. It is False for things we can't specialise: @@ -3113,44 +3155,91 @@ collect usage info for imported overloaded functions. Note [Interesting dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In `mkCallUDs` we only use `SpecDict` for dictionaries of which -`interestingDict` holds. Otherwise we use `UnspecArg`. Two reasons: - -* Consider this - \a.\d:Eq a. let f = ... in ...(f d)... - There really is not much point in specialising f wrt the dictionary d, - because the code for the specialised f is not improved at all, because - d is lambda-bound. We simply get junk specialisations. - -* Consider this (#25703): - f :: (Eq a, Show b) => a -> b -> INt - goo :: forall x. (Eq x) => x -> blah - goo @x (d:Eq x) (arg:x) = ...(f @x @Int d $fShowInt)... - If we built a `ci_key` with a (SpecDict d) for `d`, we would end up - discarding the call at the `\d`. But if we use `UnspecArg` for that - uninteresting `d`, we'll get a `ci_key` of - f @x @Int UnspecArg (SpecDict $fShowInt) - and /that/ can float out to f's definition and specialise nicely. - Hooray. (NB: the call can float only if `-fpolymorphic-specialisation` - is on; otherwise it'll be trapped by the `\@x -> ...`.)( - -What is "interesting"? (See `interestingDict`.) Just that it has *some* -structure. But what about variables? We look in the variable's /unfolding/. -And that means that we must be careful to ensure that dictionaries /have/ -unfoldings, - -* cloneBndrSM discards non-Stable unfoldings -* specBind updates the unfolding after specialisation - See Note [Update unfolding after specialisation] -* bindAuxiliaryDict adds an unfolding for an aux dict - see Note [Specialisation modulo dictionary selectors] -* specCase adds unfoldings for the new bindings it creates - -We accidentally lost accurate tracking of local variables for a long -time, because cloned variables didn't have unfoldings. But makes a -massive difference in a few cases, eg #5113. For nofib as a -whole it's only a small win: 2.2% improvement in allocation for ansi, -1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. +Consider this + \a.\d:Eq a. let f = ... in ...(f d)... +There really is not much point in specialising f wrt the dictionary d, +because the code for the specialised f is not improved at all, because +d is lambda-bound. We simply get junk specialisations. + +What is "interesting"? Our Main Plan is to use `exprIsConApp_maybe` to see +if the argument is a dictionary constructor applied to some arguments, in which +case we can clearly specialise. But there are wrinkles: + +(ID1) Note that we look at the argument /term/, not its /type/. Suppose the + argument is + (% d1, d2 %) |> co + where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family. + Then its type (F Int a) looks very un-informative, but the term is super + helpful. See #19747 (where missing this point caused a 70x slow down) + and #7785. + +(ID2) Note that the Main Plan works fine for an argument that is a DFun call, + e.g. $fOrdList $dOrdInt + because `exprIsConApp_maybe` cleverly deals with DFunId applications. Good! + +(ID3) For variables, we look in the variable's /unfolding/. And that means + that we must be careful to ensure that dictionaries /have/ unfoldings: + * cloneBndrSM discards non-Stable unfoldings + * specBind updates the unfolding after specialisation + See Note [Update unfolding after specialisation] + * bindAuxiliaryDict adds an unfolding for an aux dict + see Note [Specialisation modulo dictionary selectors] + * specCase adds unfoldings for the new bindings it creates + + We accidentally lost accurate tracking of local variables for a long + time, because cloned variables didn't have unfoldings. But makes a + massive difference in a few cases, eg #5113. For nofib as a + whole it's only a small win: 2.2% improvement in allocation for ansi, + 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. + +(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains + an implicit parameter, because implicit parameters are emphatically not singleton + types. See #25999: + useImplicit :: (?i :: Int) => Int + useImplicit = ?i + 1 + + foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit) + Both calls to `useImplicit` are at type `?i::Int`, but they pass different values. + We must not specialise on implicit parameters! Hence the call to `couldBeIPLike`. + +(ID5) Suppose the argument is (e |> co). Can we rely on `exprIsConApp_maybe` to deal + with the coercion. No! That only works if (co :: C t1 ~ C t2) with the same type + constructor at the top of both sides. But see the example in (ID1), where that + is not true. For thes same reason, we can't rely on `exprIsConApp_maybe` to look + through unfoldings (because there might be a cast inside), hence dealing with + expandable unfoldings in `interestingDict` directly. + +(ID6) The Main Plan says that it's worth specialising if the argument is an application + of a dictionary contructor. But what if the dictionary has no methods? Then we + gain nothing by specialising, unless the /superclasses/ are interesting. A case + in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class + with N superclasses and no methods. + +(ID7) A unary (single-method) class is currently represented by (meth |> co). We + will unwrap the cast (see (ID5)) and then want to reply "yes" if the method + has any struture. We rather arbitrarily use `exprIsHNF` for this. (We plan a + new story for unary classes, see #23109, and this special case will become + irrelevant.) + +(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a + non-trivial argument as interesting. In T19695 we have this: + askParams :: Monad m => blah + mhelper :: MonadIO m => blah + mhelper (d:MonadIO m) = ...(askParams @m ($p1 d)).... + where `$p1` is the superclass selector for `MonadIO`. Now, if `mhelper` is + specialised at `Handler` we'll get this call in the specialised `$smhelper`: + askParams @Handler ($p1 $fMonadIOHandler) + and we /definitely/ want to specialise that, even though the argument isn't + visibly a dictionary application. In fact the specialiser fires the superclass + selector rule (see Note [Fire rules in the specialiser]), so we get + askParams @Handler ($cp1MonadIO $fMonadIOIO) + but it /still/ doesn't look like a dictionary application. + + Conclusion: we optimistically assume that any non-trivial argument is worth + specialising on. + + So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look + under type-family casts (ID1) and constraint tuples (ID6). Note [Update unfolding after specialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3178,6 +3267,7 @@ Consider (#21848) Now `f` turns into: f @a @b (dd :: D a) (ds :: Show b) a b + = let dc :: D a = %p1 dd -- Superclass selection in meth @a dc .... meth @a dc .... @@ -3193,27 +3283,6 @@ in the NonRec case of specBind. (This is too exotic to trouble with the Rec case.) -} -interestingDict :: CoreExpr -> Type -> Bool --- A dictionary argument is interesting if it has *some* structure, --- see Note [Interesting dictionary arguments] --- NB: "dictionary" arguments include constraints of all sorts, --- including equality constraints; hence the Coercion case --- To make this work, we need to ensure that dictionaries have --- unfoldings in them. -interestingDict arg arg_ty - | not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value] - | otherwise = go arg - where - go (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v - go (Type _) = False - go (Coercion _) = False - go (App fn (Type _)) = go fn - go (App fn (Coercion _)) = go fn - go (Tick _ a) = go a - go (Cast e _) = go e - go _ = True - thenUDs :: UsageDetails -> UsageDetails -> UsageDetails thenUDs (MkUD {ud_binds = db1, ud_calls = calls1}) (MkUD {ud_binds = db2, ud_calls = calls2}) ===================================== compiler/GHC/Core/Predicate.hs ===================================== @@ -24,7 +24,7 @@ module GHC.Core.Predicate ( classMethodTy, classMethodInstTy, -- Implicit parameters - isIPLikePred, mentionsIP, isIPTyCon, isIPClass, + couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass, isCallStackTy, isCallStackPred, isCallStackPredTy, isExceptionContextPred, isExceptionContextTy, isIPPred_maybe, @@ -126,9 +126,12 @@ isDictTy ty = isClassPred pred where (_, pred) = splitInvisPiTys ty +-- | Is the type *guaranteed* to determine the value? +-- +-- Might say No even if the type does determine the value. (See the Note) typeDeterminesValue :: Type -> Bool -- See Note [Type determines value] -typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty) +typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty) getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of @@ -171,6 +174,10 @@ So we treat implicit params just like ordinary arguments for the purposes of specialisation. Note that we still want to specialise functions with implicit params if they have *other* dicts which are class params; see #17930. + +It's also not always possible to infer that a type determines the value +if type families are in play. See #19747 for one such example. + -} -- --------------------- Equality predicates --------------------------------- @@ -421,44 +428,44 @@ isCallStackTy ty | otherwise = False --- --------------------- isIPLike and mentionsIP -------------------------- +-- --------------------- couldBeIPLike and mightMentionIP -------------------------- -- See Note [Local implicit parameters] -isIPLikePred :: Type -> Bool +couldBeIPLike :: Type -> Bool -- Is `pred`, or any of its superclasses, an implicit parameter? -- See Note [Local implicit parameters] -isIPLikePred pred = - mentions_ip_pred initIPRecTc (const True) (const True) pred - -mentionsIP :: (Type -> Bool) -- ^ predicate on the string - -> (Type -> Bool) -- ^ predicate on the type - -> Class - -> [Type] -> Bool --- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if: +couldBeIPLike pred + = might_mention_ip1 initIPRecTc (const True) (const True) pred + +mightMentionIP :: (Type -> Bool) -- ^ predicate on the string + -> (Type -> Bool) -- ^ predicate on the type + -> Class + -> [Type] -> Bool +-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if: -- -- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@ -- are both @True@, -- - or any superclass of @cls tys@ has this property. -- -- See Note [Local implicit parameters] -mentionsIP = mentions_ip initIPRecTc +mightMentionIP = might_mention_ip initIPRecTc -mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool -mentions_ip rec_clss str_cond ty_cond cls tys +might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool +might_mention_ip rec_clss str_cond ty_cond cls tys | Just (str_ty, ty) <- isIPPred_maybe cls tys = str_cond str_ty && ty_cond ty | otherwise - = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys) + = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys) | sc_sel_id <- classSCSelIds cls ] -mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool -mentions_ip_pred rec_clss str_cond ty_cond ty +might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool +might_mention_ip1 rec_clss str_cond ty_cond ty | Just (cls, tys) <- getClassPredTys_maybe ty , let tc = classTyCon cls , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss else checkRecTc rec_clss tc - = mentions_ip rec_clss' str_cond ty_cond cls tys + = might_mention_ip rec_clss' str_cond ty_cond cls tys | otherwise = False -- Includes things like (D []) where D is -- a Constraint-ranged family; #7785 @@ -471,7 +478,7 @@ initIPRecTc = setRecTcMaxBound 1 initRecTc See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict. -The function isIPLikePred tells if this predicate, or any of its +The function couldBeIPLike tells if this predicate, or any of its superclasses, is an implicit parameter. Why are implicit parameters special? Unlike normal classes, we can @@ -479,7 +486,7 @@ have local instances for implicit parameters, in the form of let ?x = True in ... So in various places we must be careful not to assume that any value of the right type will do; we must carefully look for the innermost binding. -So isIPLikePred checks whether this is an implicit parameter, or has +So couldBeIPLike checks whether this is an implicit parameter, or has a superclass that is an implicit parameter. Several wrinkles @@ -520,16 +527,16 @@ Small worries (Sept 20): think nothing does. * I'm a little concerned about type variables; such a variable might be instantiated to an implicit parameter. I don't think this - matters in the cases for which isIPLikePred is used, and it's pretty + matters in the cases for which couldBeIPLike is used, and it's pretty obscure anyway. * The superclass hunt stops when it encounters the same class again, but in principle we could have the same class, differently instantiated, and the second time it could have an implicit parameter I'm going to treat these as problems for another day. They are all exotic. -Note [Using typesAreApart when calling mentionsIP] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We call 'mentionsIP' in two situations: +Note [Using typesAreApart when calling mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We call 'mightMentionIP' in two situations: (1) to check that a predicate does not contain any implicit parameters IP str ty, for a fixed literal str and any type ty, ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -1914,7 +1914,7 @@ growThetaTyVars theta tcvs | otherwise = transCloVarSet mk_next seed_tcvs where seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips - (ips, non_ips) = partition isIPLikePred theta + (ips, non_ips) = partition couldBeIPLike theta -- See Note [Inheriting implicit parameters] mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -749,7 +749,7 @@ shortCutSolver dflags ev_w ev_i -- programs should typecheck regardless of whether we take this step or -- not. See Note [Shortcut solving] - , not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627) + , not (couldBeIPLike (ctEvPred ev_w)) -- Not for implicit parameters (#18627) , not (xopt LangExt.IncoherentInstances dflags) -- If IncoherentInstances is on then we cannot rely on coherence of proofs ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -2040,10 +2040,10 @@ solveOneFromTheOther ct_i ct_w is_wsc_orig_w = isWantedSuperclassOrigin orig_w different_level_strategy -- Both Given - | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert - | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork + | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert + | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork -- See Note [Replacement vs keeping] part (1) - -- For the isIPLikePred case see Note [Shadowing of implicit parameters] + -- For the couldBeIPLike case see Note [Shadowing of implicit parameters] -- in GHC.Tc.Solver.Dict same_level_strategy -- Both Given ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -401,8 +401,8 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'? does_not_mention_ip_for :: Type -> DictCt -> Bool does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys }) - = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys - -- See Note [Using typesAreApart when calling mentionsIP] + = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys + -- See Note [Using typesAreApart when calling mightMentionIP] -- in GHC.Core.Predicate updInertIrreds :: IrredCt -> TcS () @@ -534,7 +534,7 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName ; let contains_callstack_or_exceptionCtx = - mentionsIP + mightMentionIP (const True) -- NB: the name of the call-stack IP is irrelevant -- e.g (?foo :: CallStack) counts! @@ -552,9 +552,9 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) -- Return a predicate that decides whether a type is CallStack -- or ExceptionContext, accounting for e.g. type family reduction, as - -- per Note [Using typesAreApart when calling mentionsIP]. + -- per Note [Using typesAreApart when calling mightMentionIP]. -- - -- See Note [Using isCallStackTy in mentionsIP]. + -- See Note [Using isCallStackTy in mightMentionIP]. is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool) is_tyConTy is_eq tc_name = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name @@ -582,14 +582,14 @@ in a different context! See also Note [Shadowing of implicit parameters], which deals with a similar problem with Given implicit parameter constraints. -Note [Using isCallStackTy in mentionsIP] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Using isCallStackTy in mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To implement Note [Don't add HasCallStack constraints to the solved set], we need to check whether a constraint contains a HasCallStack or HasExceptionContext constraint. We do this using the 'mentionsIP' function, but as per -Note [Using typesAreApart when calling mentionsIP] we don't want to simply do: +Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do: - mentionsIP + mightMentionIP (const True) -- (ignore the implicit parameter string) (isCallStackTy <||> isExceptionContextTy) ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -155,7 +155,7 @@ module GHC.Tc.Utils.TcType ( mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, - isClassPred, isEqPred, isIPLikePred, isEqClassPred, + isClassPred, isEqPred, couldBeIPLike, isEqClassPred, isEqualityClass, mkClassPred, tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, isRuntimeRepVar, isFixedRuntimeRepKind, @@ -1819,7 +1819,7 @@ pickCapturedPreds pickCapturedPreds qtvs theta = filter captured theta where - captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) + captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) -- Superclasses ===================================== testsuite/tests/perf/should_run/SpecTyFamRun.hs ===================================== @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fspecialise-aggressively #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +module Main(main) where + +import SpecTyFam_Import (specMe, MaybeShowNum) +import GHC.Exts + +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime. + +{-# NOINLINE foo #-} +foo :: Int -> (String,Int) +-- We want specMe to be specialized, but not inlined +foo x = specMe True x + +main = print $ sum $ map (snd . foo) [1..1000 :: Int] ===================================== testsuite/tests/perf/should_run/SpecTyFamRun.stdout ===================================== @@ -0,0 +1 @@ +500500 ===================================== testsuite/tests/perf/should_run/SpecTyFam_Import.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + +module SpecTyFam_Import (specMe, MaybeShowNum) where + +import Data.Kind + +type family MaybeShowNum a n :: Constraint where + MaybeShowNum a n = (Show a, Num n) + +{-# INLINABLE specMe #-} +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n) +specMe s !n = (show s, n+1 `div` 2) ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -423,3 +423,12 @@ test('ByteCodeAsm', ], compile_and_run, ['-package ghc']) + +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats +# See also #19747 +test('SpecTyFamRun', [ grep_errmsg(r'foo') + , extra_files(['SpecTyFam_Import.hs']) + , only_ways(['optasm']) + , collect_stats('bytes allocated', 5)], + multimod_compile_and_run, + ['SpecTyFamRun', '-O2']) ===================================== testsuite/tests/simplCore/should_compile/T26051.hs ===================================== @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fspecialise-aggressively #-} +{-# OPTIONS_GHC -fno-spec-constr #-} + +module T26051(main, foo) where + +import T26051_Import (specMe, MaybeShowNum) +import GHC.Exts + +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime. + +{-# OPAQUE foo #-} +foo :: Int -> (String,Int) +foo x = specMe True x + +main = print $ sum $ map (snd . foo) [1..1000 :: Int] ===================================== testsuite/tests/simplCore/should_compile/T26051.stderr ===================================== @@ -0,0 +1,78 @@ +[1 of 2] Compiling T26051_Import ( T26051_Import.hs, T26051_Import.o ) + +==================== Specialise ==================== +Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1} + +-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1} +specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n) +[LclIdX, + Arity=4, + Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10 + Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) -> + let { + $dNum :: Num n + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}] + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in + case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}] +specMe + = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) -> + let { + $dNum :: Num n + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}] + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in + case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) } + + + +[2 of 2] Compiling T26051 ( T26051.hs, T26051.o ) + +==================== Specialise ==================== +Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1} + +Rec { +-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0} +$dCTuple2 :: (Show Bool, Num Int) +[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt) + +-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1} +$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #) +[LclId, Arity=2] +$s$wspecMe + = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> + let { + $dNum :: Num Int + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] + $dNum = GHC.Internal.Num.$fNumInt } in + case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) } + +-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0} +$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int) +[LclId, + Arity=2, + Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) + Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case T26051_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}] +$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case T26051_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) } +end Rec } + +-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0} +foo [InlPrag=OPAQUE] :: Int -> (String, Int) +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}] +foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x + +-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0} +main :: State# RealWorld -> (# State# RealWorld, () #) +[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}] +main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.StdHandles.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta + +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} +main :: IO () +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] +main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ()) + + +------ Local rules for imported ids -------- +"SPEC/T26051 $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). T26051_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe +"SPEC/T26051 specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe + + ===================================== testsuite/tests/simplCore/should_compile/T26051_Import.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImplicitParams #-} + +module T26051_Import (specMe, MaybeShowNum) where + +import Data.Kind + +type family MaybeShowNum a n :: Constraint where + MaybeShowNum a n = (Show a, Num n) + +{-# INLINABLE specMe #-} +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n) +specMe s !n = (show s, n+1 `div` 2) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -548,3 +548,9 @@ test('T25965', normal, compile, ['-O']) test('T25703', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings']) test('T25703a', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings']) +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats +test('T26051', [ grep_errmsg(r'\$wspecMe') + , extra_files(['T26051_Import.hs']) + , only_ways(['optasm'])], + multimod_compile, + ['T26051', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcb5f7ee80167bce784ec9cf1ed55c5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcb5f7ee80167bce784ec9cf1ed55c5… You're receiving this email because of your account on gitlab.haskell.org.

1 0