[Git][ghc/ghc][wip/spj-apporv-Oct24] 34 commits: Refactor mkTopLevImportedEnv out of mkTopLevEnv
by Apoorv Ingle (＠ani) 23 May '25
by Apoorv Ingle (＠ani) 23 May '25
23 May '25
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
e46c6b18 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00
Refactor mkTopLevImportedEnv out of mkTopLevEnv
This makes the code clearer and allows the top-level import context to
be fetched directly from the HomeModInfo through the API (e.g. useful
for the debugger).
- - - - -
0ce0d263 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00
Export sizeOccEnv from GHC.Types.Name.Occurrence
Counts the number of OccNames in an OccEnv
- - - - -
165f98d8 by Simon Peyton Jones at 2025-05-06T09:02:39-04:00
Fix a bad untouchability bug im simplifyInfer
This patch addresses #26004. The root cause was that simplifyInfer
was willing to unify variables "far out". The fix, in
runTcSWithEvBinds', is to initialise the inert set given-eq level with
the current level. See
(TGE6) in Note [Tracking Given equalities]
in GHC.Tc.Solver.InertSet
Two loosely related refactors:
* Refactored approximateWCX to return just the free type
variables of the un-quantified constraints. That avoids duplication
of work (these free vars are needed in simplifyInfer) and makes it
clearer that the constraints themselves are irrelevant.
* A little local refactor of TcSMode, which reduces the number of
parameters to runTcSWithEvBinds
- - - - -
6e67fa08 by Ben Gamari at 2025-05-08T06:21:21-04:00
llvmGen: Fix built-in variable predicate
Previously the predicate to identify LLVM builtin global variables was
checking for `$llvm` rather than `@llvm` as it should.
- - - - -
a9d0a22c by Ben Gamari at 2025-05-08T06:21:22-04:00
llvmGen: Fix linkage of built-in arrays
LLVM now insists that built-in arrays use Appending linkage, not
Internal.
Fixes #25769.
- - - - -
9c6d2b1b by sheaf at 2025-05-08T06:22:11-04:00
Use mkTrAppChecked in ds_ev_typeable
This change avoids violating the invariant of mkTrApp according to which
the argument should not be a fully saturated function type.
This ensures we don't return false negatives for type equality
involving function types.
Fixes #25998
- - - - -
75cadf81 by Ryan Hendrickson at 2025-05-08T06:22:55-04:00
haddock: Preserve indentation in multiline examples
Intended for use with :{ :}, but doesn't look for those characters. Any
consecutive lines with birdtracks will only have initial whitespace
stripped up to the column of the first line.
- - - - -
fee9b351 by Cheng Shao at 2025-05-08T06:23:36-04:00
ci: re-enable chrome for wasm ghci browser tests
Currently only firefox is enabled for wasm ghci browser tests, for
some reason testing with chrome works on my machine but gets stuck on
gitlab instance runners. This patch re-enables testing with chrome by
passing `--no-sandbox`, since chrome sandboxing doesn't work in
containers without `--cap-add=SYS_ADMIN`.
- - - - -
282df905 by Vladislav Zavialov at 2025-05-09T03:18:25-04:00
Take subordinate 'type' specifiers into account
This patch fixes multiple bugs (#22581, #25983, #25984, #25991)
in name resolution of subordinate import lists.
Bug #22581
----------
In subordinate import lists, the use of the `type` namespace specifier
used to be ignored. For example, this import statement was incorrectly
accepted:
import Prelude (Bool(type True))
Now it results in an error message:
<interactive>:2:17: error: [GHC-51433]
In the import of ‘Prelude’:
a data type called ‘Bool’ is exported,
but its subordinate item ‘True’ is not in the type namespace.
Bug #25983
----------
In subordinate import lists within a `hiding` clause, non-existent
items led to a poor warning message with -Wdodgy-imports. Consider:
import Prelude hiding (Bool(X))
The warning message for this import statement used to misreport the
cause of the problem:
<interactive>:3:24: warning: [GHC-56449] [-Wdodgy-imports]
In the import of ‘Prelude’:
an item called ‘Bool’ is exported, but it is a type.
Now the warning message is correct:
<interactive>:2:24: warning: [GHC-10237] [-Wdodgy-imports]
In the import of ‘Prelude’:
a data type called ‘Bool’ is exported, but it does not export
any constructors or record fields called ‘X’.
Bug #25984
----------
In subordinate import lists within a `hiding` clause, non-existent
items resulted in the entire import declaration being discarded.
For example, this program was incorrectly accepted:
import Prelude hiding (Bool(True,X))
t = True
Now it results in an error message:
<interactive>:2:5: error: [GHC-88464]
Data constructor not in scope: True
Bug #25991
----------
In subordinate import lists, it was not possible to refer to a class
method if there was an associated type of the same name:
module M_helper where
class C a b where
type a # b
(#) :: a -> b -> ()
module M where
import M_helper (C((#)))
This import declaration failed with:
M.hs:2:28: error: [GHC-10237]
In the import of ‘M_helper’:
an item called ‘C’ is exported, but it does not export any children
(constructors, class methods or field names) called ‘#’.
Now it is accepted.
Summary
-------
The changes required to fix these bugs are almost entirely confined to
GHC.Rename.Names. Other than that, there is a new error constructor
BadImportNonTypeSubordinates with error code [GHC-51433].
Test cases:
T22581a T22581b T22581c T22581d
T25983a T25983b T25983c T25983d T25983e T25983f T25983g
T25984a T25984b
T25991a T25991b1 T25991b2
- - - - -
51b0ce8f by Simon Peyton Jones at 2025-05-09T03:19:07-04:00
Slighty improve `dropMisleading`
Fix #26105, by upgrading the (horrible, hacky) `dropMisleading`
function.
This fix makes things a bit better but does not cure the underlying
problem.
- - - - -
7b2d1e6d by Simon Peyton Jones at 2025-05-11T03:24:47-04:00
Refine `noGivenNewtypeReprEqs` to account for quantified constraints
This little MR fixes #26020. We are on the edge of completeness
for newtype equalities (that doesn't change) but this MR makes GHC
a bit more consistent -- and fixes the bug reported.
- - - - -
eaa8093b by Cheng Shao at 2025-05-11T03:25:28-04:00
wasm: mark freeJSVal as INLINE
This patch marks `freeJSVal` as `INLINE` for the wasm backend. I
noticed that the `freeJSVal` invocations are not inlined when
inspecting STG/Cmm dumps of downstream libraries that use release
build of the wasm backend. The performance benefit of inlining here is
very modest, but so is the cost anyway; if you are using `freeJSVal`
at all then you care about every potential chance to improve
performance :)
- - - - -
eac196df by Cheng Shao at 2025-05-11T03:25:28-04:00
wasm: add zero length fast path for fromJSString
This patch adds a zero length fast path for `fromJSString`; when
marshaling a zero-length `JSString` we don't need to allocate an empty
`ByteArray#` at all.
- - - - -
652cba7e by Peng Fan at 2025-05-14T04:24:35-04:00
Add LoongArch NCG support
Not supported before.
- - - - -
c01f4374 by Lin Runze at 2025-05-14T04:24:35-04:00
ci: Add LoongArch64 cross-compile CI for testing
- - - - -
ce6cf240 by Ben Gamari at 2025-05-14T04:25:18-04:00
rts/linker: Don't fail due to RTLD_NOW
In !12264 we started using the NativeObj machinery introduced some time
ago for loading of shared objects. One of the side-effects of this
change is shared objects are now loaded eagerly (i.e. with `RTLD_NOW`).
This is needed by NativeObj to ensure full visibility of the mappings of
the loaded object, which is in turn needed for safe shared object
unloading.
Unfortunately, this change subtly regressed, causing compilation
failures in some programs. Specifically, shared objects which refer to
undefined symbols (e.g. which may be usually provided by either the
executable image or libraries loaded via `dlopen`) will fail to load
with eager binding. This is problematic as GHC loads all package
dependencies while, e.g., evaluating TemplateHaskell splices. This
results in compilation failures in programs depending upon (but not
using at compile-time) packages with undefined symbol references.
To mitigate this NativeObj now first attempts to load an object via
eager binding, reverting to lazy binding (and disabling unloading) on
failure.
See Note [Don't fail due to RTLD_NOW].
Fixes #25943.
- - - - -
88ee8bb5 by Sylvain Henry at 2025-05-14T04:26:15-04:00
Deprecate GHC.JS.Prim.Internal.Build (#23432)
Deprecated as per CLC proposal 329 (https://github.com/haskell/core-libraries-committee/issues/329)
- - - - -
b4ed465b by Cheng Shao at 2025-05-14T04:26:57-04:00
libffi: update to 3.4.8
Bumps libffi submodule.
- - - - -
a3e71296 by Matthew Pickering at 2025-05-14T04:27:38-04:00
Remove leftover trace
- - - - -
2d0ecdc6 by Cheng Shao at 2025-05-14T04:28:19-04:00
Revert "ci: re-enable chrome for wasm ghci browser tests"
This reverts commit fee9b351fa5a35d5778d1252789eacaaf5663ae8.
Unfortunately the chrome test jobs may still timeout on certain
runners (e.g. OpenCape) for unknown reasons.
- - - - -
3b3a5dec by Ben Gamari at 2025-05-15T16:10:01-04:00
Don't emit unprintable characters when printing Uniques
When faced with an unprintable tag we now instead print the codepoint
number.
Fixes #25989.
(cherry picked from commit e832b1fadee66e8d6dd7b019368974756f8f8c46)
- - - - -
e1ef8974 by Mike Pilgrem at 2025-05-16T16:09:14-04:00
Translate iff in Haddock documentation into everyday English
- - - - -
235f5226 by Apoorv Ingle at 2025-05-19T14:25:26-05:00
- Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed.
- Make `tcExpr` take a `Maybe HsThingRn` which will be passed on to tcApp and used by splitHsApps to determine a more accurate `AppCtx`
- `tcXExpr` is less hacky now
- do not look through HsExpansion applications
- kill OrigPat and remove HsThingRn From VAExpansion
- look through XExpr ExpandedThingRn while inferring type of head
- always set in generated code after stepping inside a ExpandedThingRn
- fixing record update error messages
- remove special case of tcbody from tcLambdaMatches
- wrap last stmt expansion in a HsPar so that the error messages are prettier
- remove special case of dsExpr for ExpandedThingTc
- make EExpand (HsExpr GhcRn) instead of EExpand HsThingRn
- fixing error messages for rebindable
- - - - -
b4ec59e8 by Apoorv Ingle at 2025-05-19T14:25:26-05:00
some progress on tick
- - - - -
87c9b23a by Apoorv Ingle at 2025-05-19T14:25:26-05:00
remove adhoc cases from ticks
- - - - -
de43d1f3 by Apoorv Ingle at 2025-05-19T14:25:26-05:00
fix the case where head of the application chain is an expanded expression and the argument is a type application c.f. T19167.hs
- - - - -
418a83ec by Apoorv Ingle at 2025-05-19T14:25:26-05:00
move setQLInstLevel inside tcInstFun
- - - - -
2e45e697 by Apoorv Ingle at 2025-05-19T14:25:26-05:00
ignore ds warnings originating from gen locations
- - - - -
224d34a8 by Apoorv Ingle at 2025-05-19T14:25:26-05:00
filter expr stmts error msgs
- - - - -
38ca6121 by Apoorv Ingle at 2025-05-19T14:25:26-05:00
exception for AppDo while making error ctxt
- - - - -
e798161a by Apoorv Ingle at 2025-05-19T14:25:26-05:00
moving around things for locations and error ctxts
- - - - -
4e761612 by Apoorv Ingle at 2025-05-19T14:25:26-05:00
popErrCtxt doesn't push contexts and popErrCtxts in the first argument to bind and >> in do expansion statements
- - - - -
549ece3b by Apoorv Ingle at 2025-05-19T14:25:26-05:00
accept test cases with changed error messages
-------------------------
Metric Decrease:
T9020
-------------------------
- - - - -
3a7db680 by Apoorv Ingle at 2025-05-19T14:25:26-05:00
look through PopErrCtxt while splitting exprs in application chains
- - - - -
152 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/CodeGen.Platform.h
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/Dwarf/Constants.hs
- + compiler/GHC/CmmToAsm/LA64.hs
- + compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- + compiler/GHC/CmmToAsm/LA64/Cond.hs
- + compiler/GHC/CmmToAsm/LA64/Instr.hs
- + compiler/GHC/CmmToAsm/LA64/Ppr.hs
- + compiler/GHC/CmmToAsm/LA64/RegInfo.hs
- + compiler/GHC/CmmToAsm/LA64/Regs.hs
- compiler/GHC/CmmToAsm/PIC.hs
- compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs
- + compiler/GHC/CmmToAsm/Reg/Linear/LA64.hs
- compiler/GHC/CmmToAsm/Reg/Target.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/Driver/Backend.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Platform/LoongArch64.hs → compiler/GHC/Platform/LA64.hs
- compiler/GHC/Platform/Regs.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- + compiler/GHC/Tc/Gen/App.hs-boot
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Name/Occurrence.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/explicit_namespaces.rst
- hadrian/bindist/config.mk.in
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Settings/Builders/RunTest.hs
- libffi-tarballs
- libraries/base/changelog.md
- libraries/base/src/GHC/JS/Prim/Internal/Build.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Maybe.hs
- libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs
- rts/linker/LoadNativeObjPosix.c
- testsuite/tests/deSugar/should_compile/T10662.stderr
- testsuite/tests/deSugar/should_compile/T3263-1.stderr
- testsuite/tests/deSugar/should_compile/T3263-2.stderr
- testsuite/tests/default/default-fail05.stderr
- testsuite/tests/driver/RecompExports/RecompExports1.stderr
- testsuite/tests/driver/RecompExports/RecompExports4.stderr
- testsuite/tests/indexed-types/should_fail/T2693.stderr
- testsuite/tests/module/T21826.stderr
- testsuite/tests/module/mod81.stderr
- testsuite/tests/module/mod91.stderr
- testsuite/tests/plugins/test-defaulting-plugin.stderr
- testsuite/tests/polykinds/T13393.stderr
- testsuite/tests/printer/T17697.stderr
- + testsuite/tests/rename/should_compile/T22581c.hs
- + testsuite/tests/rename/should_compile/T22581c_helper.hs
- + testsuite/tests/rename/should_compile/T22581d.script
- + testsuite/tests/rename/should_compile/T22581d.stdout
- + testsuite/tests/rename/should_compile/T25983a.hs
- + testsuite/tests/rename/should_compile/T25983a.stderr
- + testsuite/tests/rename/should_compile/T25983b.hs
- + testsuite/tests/rename/should_compile/T25983b.stderr
- + testsuite/tests/rename/should_compile/T25983c.hs
- + testsuite/tests/rename/should_compile/T25983c.stderr
- + testsuite/tests/rename/should_compile/T25983d.hs
- + testsuite/tests/rename/should_compile/T25983d.stderr
- + testsuite/tests/rename/should_compile/T25983e.hs
- + testsuite/tests/rename/should_compile/T25983e.stderr
- + testsuite/tests/rename/should_compile/T25983f.hs
- + testsuite/tests/rename/should_compile/T25983f.stderr
- + testsuite/tests/rename/should_compile/T25983g.hs
- + testsuite/tests/rename/should_compile/T25983g.stderr
- + testsuite/tests/rename/should_compile/T25984a.hs
- + testsuite/tests/rename/should_compile/T25984a.stderr
- + testsuite/tests/rename/should_compile/T25984a_helper.hs
- + testsuite/tests/rename/should_compile/T25991a.hs
- + testsuite/tests/rename/should_compile/T25991a_helper.hs
- testsuite/tests/rename/should_compile/all.T
- + testsuite/tests/rename/should_fail/T22581a.hs
- + testsuite/tests/rename/should_fail/T22581a.stderr
- + testsuite/tests/rename/should_fail/T22581a_helper.hs
- + testsuite/tests/rename/should_fail/T22581b.hs
- + testsuite/tests/rename/should_fail/T22581b.stderr
- + testsuite/tests/rename/should_fail/T22581b_helper.hs
- + testsuite/tests/rename/should_fail/T25984b.hs
- + testsuite/tests/rename/should_fail/T25984b.stderr
- + testsuite/tests/rename/should_fail/T25991b1.hs
- + testsuite/tests/rename/should_fail/T25991b1.stderr
- + testsuite/tests/rename/should_fail/T25991b2.hs
- + testsuite/tests/rename/should_fail/T25991b2.stderr
- + testsuite/tests/rename/should_fail/T25991b_helper.hs
- testsuite/tests/rename/should_fail/T9006.stderr
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/rts/all.T
- testsuite/tests/typecheck/should_compile/T14590.stderr
- + testsuite/tests/typecheck/should_compile/T26020.hs
- + testsuite/tests/typecheck/should_compile/T26020a.hs
- + testsuite/tests/typecheck/should_compile/T26020a_help.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- testsuite/tests/typecheck/should_fail/T10971d.stderr
- testsuite/tests/typecheck/should_fail/T13311.stderr
- testsuite/tests/typecheck/should_fail/T24064.stderr
- + testsuite/tests/typecheck/should_fail/T26004.hs
- + testsuite/tests/typecheck/should_fail/T26004.stderr
- + testsuite/tests/typecheck/should_fail/T26015.hs
- + testsuite/tests/typecheck/should_fail/T26015.stderr
- testsuite/tests/typecheck/should_fail/T3613.stderr
- testsuite/tests/typecheck/should_fail/T7453.stderr
- testsuite/tests/typecheck/should_fail/T7851.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail128.stderr
- testsuite/tests/typecheck/should_fail/tcfail168.stderr
- + testsuite/tests/typecheck/should_run/T25998.hs
- + testsuite/tests/typecheck/should_run/T25998.stdout
- testsuite/tests/typecheck/should_run/all.T
- testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
- utils/ghc-toolchain/exe/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4dc324fdfa9c2844f996f3ee6473bd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4dc324fdfa9c2844f996f3ee6473bd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] base: Expose Backtraces constructor and fields
by Marge Bot (＠marge-bot) 23 May '25
by Marge Bot (＠marge-bot) 23 May '25
23 May '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
17db44c5 by Ben Gamari at 2025-05-23T15:13:16-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.
- - - - -
7 changed files:
- libraries/base/changelog.md
- libraries/base/src/Control/Exception/Backtrace.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- 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
Changes:
=====================================
libraries/base/changelog.md
=====================================
@@ -22,6 +22,7 @@
* `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)).
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/17db44c5b32fff82ea988fa4f1a233d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/17db44c5b32fff82ea988fa4f1a233d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e9de9e0b by Sylvain Henry at 2025-05-23T15:12:34-04:00
Remove emptyModBreaks
Remove emptyModBreaks and track the absence of ModBreaks with `Maybe
ModBreaks`. It avoids testing for null pointers...
- - - - -
8 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
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9de9e0bc2ac0ad6273fe6ee5960801…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9de9e0bc2ac0ad6273fe6ee5960801…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/step-out] debugger: Implement step-out feature
by Rodrigo Mesquita (＠alt-romes) 23 May '25
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:
73b258cc by Rodrigo Mesquita at 2025-05-23T17:32:20+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/73b258ccdb7b2f9c76c407f439f6e7b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73b258ccdb7b2f9c76c407f439f6e7b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/step-out] debugger: Implement step-out feature
by Rodrigo Mesquita (＠alt-romes) 23 May '25
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
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
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
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
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
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