[Git][ghc/ghc][wip/T23162-spj] 2 commits: Work in progress [skip ci]
by Simon Peyton Jones (＠simonpj) 23 Jul '25
by Simon Peyton Jones (＠simonpj) 23 Jul '25
23 Jul '25
Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
Commits:
b071f3c5 by Simon Peyton Jones at 2025-07-23T23:37:49+01:00
Work in progress [skip ci]
- - - - -
23570d20 by Simon Peyton Jones at 2025-07-23T23:38:25+01:00
Add hs-boot file [skip ci]
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/Solver/Monad.hs
- + compiler/GHC/Tc/Solver/Solve.hs-boot
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -86,14 +86,15 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
= assertPpr (ctEvRewriteRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $
do { simpleStage $ traceTcS "solveDict" (ppr dict_ct)
+ -- Look in the inert dictionaries
; tryInertDicts dict_ct
+
+ -- Try top-level instances
; tryInstances dict_ct
-- Try fundeps /after/ tryInstances:
-- see (DFL2) in Note [Do fundeps last]
--- ; doLocalFunDepImprovement dict_ct
- -- doLocalFunDepImprovement does StartAgain if there
- -- are any fundeps: see (DFL1) in Note [Do fundeps last]
+ ; doDictFunDepImprovement dict_ct
; simpleStage (updInertDicts dict_ct)
; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" }
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -10,6 +10,8 @@ module GHC.Tc.Solver.FunDeps (
import GHC.Prelude
+import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds )
+
import GHC.Tc.Instance.FunDeps
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
@@ -295,7 +297,7 @@ as the fundeps.
#7875 is a case in point.
-}
-doDictFunDepImprovement :: DictCt -> SolverStage Void
+doDictFunDepImprovement :: DictCt -> SolverStage ()
-- (doDictFunDepImprovement inst_envs cts)
-- * Generate the fundeps from interacting the
-- top-level `inst_envs` with the constraints `cts`
@@ -306,13 +308,26 @@ doDictFunDepImprovement :: DictCt -> SolverStage Void
-- are any fundeps: see (DFL1) in Note [Do fundeps last]
doDictFunDepImprovement dict_ct
- = do { inst_envs <- getInstEnvs
- ; imp_res1 <- do_dict_local_fds dict_ct
- ; if noImprovement imp_res1
- then do { imp_res2 <- do_one_top inst_envs dict_ct
- ; return (imp_res `plusImprovements` imp_res2) }
- else return (imp_res `plusImprovements` imp_res1) }
+ = Stage $
+ -- Local dictionaries
+ do { inst_envs <- getInstEnvs
+ ; imp1 <- solveFunDeps (do_dict_local_fds dict_ct)
+ ; if imp1 then start_again else
+ -- Top-level instances dictionaries
+ do { imp2 <- solveFunDeps (do_one_top inst_envs dict_ct)
+ ; if imp2 then start_again
+ else continueWith () } }
+ where
+ start_again = startAgainWith (CDictCan dict_ct)
+solveFunDeps :: TcS ImprovementResult -> TcS Bool
+solveFunDeps generate_eqs
+ = do { (eqs, imp1) <- generate_eqs
+ ; if isEmptyBag eqs
+ then return imp1
+ else do { imp2 <- nestFunDepsTcS $
+ solveWanteds eqs
+ ; return (imp1 || imp2) } }
do_one_top :: InstEnvs -> DictCt -> TcS ImprovementResult
do_one_top inst_envs (DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
@@ -340,7 +355,6 @@ do_dict_local_fds :: DictCt -> TcS ImprovementResult
-- Using functional dependencies, interact the DictCt with the
-- inert Givens and Wanteds, to produce new equalities
do_dict_local_fds dict_ct@(DictCt { di_cls = cls, di_ev = wanted_ev })
- -- locals contains all the Givens and earlier Wanteds
= do { inerts <- getInertCans
; foldM do_interaction noopImprovement $
findDictsByClass locals cls }
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1353,6 +1353,30 @@ nestTcS (TcS thing_inside)
; return res }
+nestFunDepsTcS :: TcS a -> TcS Bool
+nestFunDepsTcS (TcS thing_inside)
+ = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var
+ , tcs_unif_lvl = unif_lvl_var }) ->
+ do { inerts <- TcM.readTcRef inerts_var
+ ; new_inert_var <- TcM.newTcRef inerts
+ ; new_wl_var <- TcM.newTcRef emptyWorkList
+ ; new_unif_lvl_var <- TcM.newTcRef Nothing
+ ; let nest_env = env { tcs_inerts = new_inert_var
+ , tcs_worklist = new_wl_var
+ , tcs_unif_lvl = new_unif_lvl_var }
+
+ ; (inner_lvl, res) <- TcM.pushTcLevelM $
+ thing_inside nest_env
+
+ ; mb_lvl <- TcM.readTcRef new_unif_lvl_var
+ ; case mb_lvl of
+ Just lvl | lvl < inner_lvl
+ -> do { setUnificationFlag lvl
+ ; return True }
+ _ -> return False -- No unifications (except of vars
+ -- generated in the fundep stuff itself)
+ }
+
emitImplicationTcS :: TcLevel -> SkolemInfoAnon
-> [TcTyVar] -- Skolems
-> [EvVar] -- Givens
=====================================
compiler/GHC/Tc/Solver/Solve.hs-boot
=====================================
@@ -0,0 +1,6 @@
+module GHC.Tc.Solver.Solve where
+
+import GHC.Tc.Solver.Monad
+import GHC.Tc.Types.Constraint
+
+solveSimpleWanteds :: Cts -> TcS WantedConstraints
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9a428316d587d88158f56fc016125…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9a428316d587d88158f56fc016125…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Respect `-fdiagnostics-as-json` for error messages from pre-processors
by Marge Bot (＠marge-bot) 23 Jul '25
by Marge Bot (＠marge-bot) 23 Jul '25
23 Jul '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
84711c39 by Simon Hengel at 2025-07-23T18:27:34+07:00
Respect `-fdiagnostics-as-json` for error messages from pre-processors
(fixes #25480)
- - - - -
affcef9e by Simon Hengel at 2025-07-23T17:35:25-04:00
Include the rendered message in -fdiagnostics-as-json output
This implements #26173.
- - - - -
0c5588c5 by Ben Gamari at 2025-07-23T17:35:26-04:00
rts/Interpreter: Factor out ctoi tuple info tables into data
Instead of a massive case let's put this into data which we can reuse
elsewhere.
- - - - -
11 changed files:
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/SysTools/Process.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/9.14.1-notes.rst
- + docs/users_guide/diagnostics-as-json-schema-1_2.json
- docs/users_guide/using.rst
- ghc/GHCi/UI.hs
- rts/Interpreter.c
- testsuite/tests/driver/json.stderr
- testsuite/tests/driver/json_warn.stderr
Changes:
=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -1,7 +1,9 @@
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Driver.Errors (
- printOrThrowDiagnostics
+ reportError
+ , reportDiagnostic
, printMessages
+ , printOrThrowDiagnostics
, mkDriverPsHeaderMessage
) where
@@ -10,10 +12,33 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.Error
+import GHC.Utils.Json
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Logger
+reportError :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> SDoc -> IO ()
+reportError logger nameContext opts span doc = do
+ let
+ message :: MsgEnvelope DiagnosticMessage
+ message = mkErrorMsgEnvelope span nameContext DiagnosticMessage {
+ diagMessage = mkDecorated [doc]
+ , diagReason = ErrorWithoutFlag
+ , diagHints = []
+ }
+ printMessage logger NoDiagnosticOpts opts message
+
+reportDiagnostic :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> DiagnosticReason -> SDoc -> IO ()
+reportDiagnostic logger nameContext opts span reason doc = do
+ let
+ message :: MsgEnvelope DiagnosticMessage
+ message = mkMsgEnvelope opts span nameContext DiagnosticMessage {
+ diagMessage = mkDecorated [doc]
+ , diagReason = reason
+ , diagHints = []
+ }
+ printMessage logger NoDiagnosticOpts opts message
+
printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . sortMessages
where
@@ -22,9 +47,22 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) .
printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
printMessage logger msg_opts opts message
- | log_diags_as_json = logJsonMsg logger messageClass message
+ | log_diags_as_json = do
+ decorated <- decorateDiagnostic logflags messageClass location doc
+ let
+ rendered :: String
+ rendered = renderWithContext (log_default_user_context logflags) decorated
+
+ jsonMessage :: JsonDoc
+ jsonMessage = jsonDiagnostic rendered message
+
+ logJsonMsg logger messageClass jsonMessage
+
| otherwise = logMsg logger messageClass location doc
where
+ logflags :: LogFlags
+ logflags = logFlags logger
+
doc :: SDoc
doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
=====================================
compiler/GHC/SysTools/Process.hs
=====================================
@@ -26,6 +26,8 @@ import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Utils.CliOption
+import GHC.Driver.Errors (reportError)
+
import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )
import GHC.Data.FastString
@@ -286,8 +288,7 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
BuildMsg msg -> do
logInfo logger $ withPprStyle defaultUserStyle msg
BuildError loc msg -> do
- logMsg logger errorDiagnostic (mkSrcSpan loc loc)
- $ withPprStyle defaultUserStyle msg
+ reportError logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) msg
parseBuildMessages :: [String] -> [BuildMessage]
parseBuildMessages str = loop str Nothing
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -73,6 +73,9 @@ module GHC.Types.Error
, mkLocMessage
, mkLocMessageWarningGroups
, getCaretDiagnostic
+
+ , jsonDiagnostic
+
-- * Queries
, isIntrinsicErrorMessage
, isExtrinsicErrorMessage
@@ -109,7 +112,7 @@ import GHC.Utils.Panic
import GHC.Version (cProjectVersion)
import Data.Bifunctor
-import Data.Foldable ( fold, toList )
+import Data.Foldable
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.List ( intercalate )
@@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where
pprDiagnostic (errMsgDiagnostic envelope)
]
-instance (Diagnostic e) => ToJson (Messages e) where
- json msgs = JSArray . toList $ json <$> getMessages msgs
-
{- Note [Discarding Messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -573,7 +573,7 @@ instance ToJson DiagnosticCode where
{- Note [Diagnostic Message JSON Schema]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The below instance of ToJson must conform to the JSON schema
-specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
+specified in docs/users_guide/diagnostics-as-json-schema-1_2.json.
When the schema is altered, please bump the version.
If the content is altered in a backwards compatible way,
update the minor version (e.g. 1.3 ~> 1.4).
@@ -586,15 +586,17 @@ https://json-schema.org
-}
schemaVersion :: String
-schemaVersion = "1.1"
+schemaVersion = "1.2"
+
-- See Note [Diagnostic Message JSON Schema] before editing!
-instance Diagnostic e => ToJson (MsgEnvelope e) where
- json m = JSObject $ [
+jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc
+jsonDiagnostic rendered m = JSObject $ [
("version", JSString schemaVersion),
("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),
("span", json $ errMsgSpan m),
("severity", json $ errMsgSeverity m),
("code", maybe JSNull json (diagnosticCode diag)),
+ ("rendered", JSString rendered),
("message", JSArray $ map renderToJSString diagMsg),
("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ]
++ [ ("reason", reasonJson)
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -62,6 +62,8 @@ module GHC.Utils.Logger
, logJsonMsg
, logDumpMsg
+ , decorateDiagnostic
+
-- * Dumping
, defaultDumpAction
, putDumpFile
@@ -419,26 +421,62 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
MCInfo -> printErrs msg
MCFatal -> printErrs msg
MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message
- MCDiagnostic _sev _rea _code -> printDiagnostics
+ MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs
where
printOut = defaultLogActionHPrintDoc logflags False out
printErrs = defaultLogActionHPrintDoc logflags False err
putStrSDoc = defaultLogActionHPutStrDoc logflags False out
+
+-- This function is used by `defaultLogActionWithHandles` for non-JSON output,
+-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered`
+-- message on `-fdiagnostics-as-json`.
+--
+-- We would want to eventually consolidate this. However, this is currently
+-- not feasible for the following reasons:
+--
+-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we
+-- can not decorate the message in `printMessages`.
+--
+-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For
+-- that reason we can not decorate the message in `defaultLogActionWithHandles`.
+--
+-- See also Note [JSON Error Messages]:
+--
+-- `jsonLogAction` should be removed along with -ddump-json
+--
+-- Also note that (1) is the reason why some parts of the compiler produce
+-- diagnostics that don't respect `-fdiagnostics-as-json`.
+--
+-- The plan as I see it is as follows:
+--
+-- 1. Refactor all places in the compiler that report diagnostics to go
+-- through `GHC.Driver.Errors.printMessages`.
+--
+-- (It's easy to find all those places by looking for who creates
+-- MCDiagnostic, either directly or via `mkMCDiagnostic` or
+-- `errorDiagnostic`.)
+--
+-- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message
+-- decoration at one place (either `printMessages` or
+-- `defaultLogActionWithHandles`)
+--
+-- This story is tracked by #24113.
+decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
+decorateDiagnostic logflags msg_class srcSpan msg = addCaret
+ where
-- Pretty print the warning flag, if any (#10752)
+ message :: SDoc
message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
- printDiagnostics = do
+ addCaret :: IO SDoc
+ addCaret = do
caretDiagnostic <-
if log_show_caret logflags
then getCaretDiagnostic msg_class srcSpan
else pure empty
- printErrs $ getPprStyle $ \style ->
+ return $ getPprStyle $ \style ->
withPprStyle (setStyleColoured True style)
(message $+$ caretDiagnostic $+$ blankLine)
- -- careful (#2302): printErrs prints in UTF-8,
- -- whereas converting to string first and using
- -- hPutStr would just emit the low 8 bits of
- -- each unicode char.
-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
@@ -603,8 +641,8 @@ defaultTraceAction logflags title doc x =
logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
-logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
-logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d)
+logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
+logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
-- | Dump something
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -147,6 +147,11 @@ Compiler
integer operations. Also, ``shuffleFloatX4#`` and ``shuffleDoubleX2#`` no longer
require ``-mavx``.
+- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now
+ include the `rendered` diagnostics message, in the exact same format as what
+ GHC would have produced without -fdiagnostics-as-json (including ANSI escape
+ sequences).
+
GHCi
~~~~
=====================================
docs/users_guide/diagnostics-as-json-schema-1_2.json
=====================================
@@ -0,0 +1,144 @@
+{
+ "$schema": "https://json-schema.org/draft/2020-12/schema",
+ "title": "JSON Diagnostic Schema",
+ "description": "A Schema for specifying GHC diagnostics output as JSON",
+ "type": "object",
+ "properties": {
+ "version": {
+ "description": "The current JSON schema version this object conforms to",
+ "type": "string"
+ },
+ "ghcVersion": {
+ "description": "The GHC version",
+ "type": "string"
+ },
+ "span": {
+ "oneOf": [
+ { "$ref": "#/$defs/span" },
+ { "type": "null" }
+ ]
+ },
+ "severity": {
+ "description": "The diagnostic severity",
+ "type": "string",
+ "enum": [
+ "Warning",
+ "Error"
+ ]
+ },
+ "code": {
+ "description": "The diagnostic code (if it exists)",
+ "type": [
+ "integer",
+ "null"
+ ]
+ },
+ "rendered": {
+ "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)",
+ "type": "string"
+ },
+ "message": {
+ "description": "The string output of the diagnostic message by GHC",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "hints": {
+ "description": "The suggested fixes",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "reason" : {
+ "description": "The GHC flag that was responsible for the emission of the diagnostic message",
+ "oneOf": [
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by one or more GHC flags",
+ "properties": {
+ "flags": {
+ "type": "array",
+ "items": {
+ "description": "The name of a GHC flag controlling the diagnostic message",
+ "type": "string"
+ },
+ "minItems": 1
+ }
+ },
+ "required": ["flags"]
+ },
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by a GHC diagnostic message category",
+ "properties": {
+ "category": {
+ "description": "The name of the GHC diagnostic message category controlling the diagnostic message",
+ "type": "string"
+ }
+ },
+ "required": ["category"]
+ }
+ ]
+ }
+ },
+
+ "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.",
+ "required": [
+ "version",
+ "ghcVersion",
+ "span",
+ "severity",
+ "code",
+ "message",
+ "hints"
+ ],
+
+ "additionalProperties": false,
+ "$defs": {
+ "span": {
+ "description": "The span of the diagnostic",
+ "type": "object",
+ "properties": {
+ "file": {
+ "description": "The file in which the diagnostic occurs",
+ "type": "string"
+ },
+ "start": {
+ "description": "The start location of the diagnostic",
+ "$ref": "#/$defs/location"
+ },
+ "end": {
+ "description": "The end location of the diagnostic",
+ "$ref": "#/$defs/location"
+ }
+ },
+ "required": [
+ "file",
+ "start",
+ "end"
+ ],
+ "additionalProperties": false
+ },
+ "location": {
+ "description": "A location in a text file",
+ "type": "object",
+ "properties": {
+ "line": {
+ "description": "The line number",
+ "type": "integer"
+ },
+ "column": {
+ "description": "The column number",
+ "type": "integer"
+ }
+ },
+ "required": [
+ "line",
+ "column"
+ ],
+ "additionalProperties": false
+ }
+ }
+}
=====================================
docs/users_guide/using.rst
=====================================
@@ -1428,7 +1428,7 @@ messages and in GHCi:
a new line.
The structure of the output is described by a `JSON Schema <https://json-schema.org/>`_.
- The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_1.json>`.
+ The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`.
.. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩
:shortdesc: Use colors in error messages
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -53,7 +53,7 @@ import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.PatSyn
import GHC.Driver.Flags
-import GHC.Driver.Errors
+import GHC.Driver.Errors (printOrThrowDiagnostics)
import GHC.Driver.Errors.Types
import GHC.Driver.Phases
import GHC.Driver.Session as DynFlags
=====================================
rts/Interpreter.c
=====================================
@@ -473,6 +473,72 @@ void interp_shutdown( void ){
#endif
+const StgPtr ctoi_tuple_infos[] = {
+ (StgPtr) &stg_ctoi_t0_info,
+ (StgPtr) &stg_ctoi_t1_info,
+ (StgPtr) &stg_ctoi_t2_info,
+ (StgPtr) &stg_ctoi_t3_info,
+ (StgPtr) &stg_ctoi_t4_info,
+ (StgPtr) &stg_ctoi_t5_info,
+ (StgPtr) &stg_ctoi_t6_info,
+ (StgPtr) &stg_ctoi_t7_info,
+ (StgPtr) &stg_ctoi_t8_info,
+ (StgPtr) &stg_ctoi_t9_info,
+ (StgPtr) &stg_ctoi_t10_info,
+ (StgPtr) &stg_ctoi_t11_info,
+ (StgPtr) &stg_ctoi_t12_info,
+ (StgPtr) &stg_ctoi_t13_info,
+ (StgPtr) &stg_ctoi_t14_info,
+ (StgPtr) &stg_ctoi_t15_info,
+ (StgPtr) &stg_ctoi_t16_info,
+ (StgPtr) &stg_ctoi_t17_info,
+ (StgPtr) &stg_ctoi_t18_info,
+ (StgPtr) &stg_ctoi_t19_info,
+ (StgPtr) &stg_ctoi_t20_info,
+ (StgPtr) &stg_ctoi_t21_info,
+ (StgPtr) &stg_ctoi_t22_info,
+ (StgPtr) &stg_ctoi_t23_info,
+ (StgPtr) &stg_ctoi_t24_info,
+ (StgPtr) &stg_ctoi_t25_info,
+ (StgPtr) &stg_ctoi_t26_info,
+ (StgPtr) &stg_ctoi_t27_info,
+ (StgPtr) &stg_ctoi_t28_info,
+ (StgPtr) &stg_ctoi_t29_info,
+ (StgPtr) &stg_ctoi_t30_info,
+ (StgPtr) &stg_ctoi_t31_info,
+ (StgPtr) &stg_ctoi_t32_info,
+ (StgPtr) &stg_ctoi_t33_info,
+ (StgPtr) &stg_ctoi_t34_info,
+ (StgPtr) &stg_ctoi_t35_info,
+ (StgPtr) &stg_ctoi_t36_info,
+ (StgPtr) &stg_ctoi_t37_info,
+ (StgPtr) &stg_ctoi_t38_info,
+ (StgPtr) &stg_ctoi_t39_info,
+ (StgPtr) &stg_ctoi_t40_info,
+ (StgPtr) &stg_ctoi_t41_info,
+ (StgPtr) &stg_ctoi_t42_info,
+ (StgPtr) &stg_ctoi_t43_info,
+ (StgPtr) &stg_ctoi_t44_info,
+ (StgPtr) &stg_ctoi_t45_info,
+ (StgPtr) &stg_ctoi_t46_info,
+ (StgPtr) &stg_ctoi_t47_info,
+ (StgPtr) &stg_ctoi_t48_info,
+ (StgPtr) &stg_ctoi_t49_info,
+ (StgPtr) &stg_ctoi_t50_info,
+ (StgPtr) &stg_ctoi_t51_info,
+ (StgPtr) &stg_ctoi_t52_info,
+ (StgPtr) &stg_ctoi_t53_info,
+ (StgPtr) &stg_ctoi_t54_info,
+ (StgPtr) &stg_ctoi_t55_info,
+ (StgPtr) &stg_ctoi_t56_info,
+ (StgPtr) &stg_ctoi_t57_info,
+ (StgPtr) &stg_ctoi_t58_info,
+ (StgPtr) &stg_ctoi_t59_info,
+ (StgPtr) &stg_ctoi_t60_info,
+ (StgPtr) &stg_ctoi_t61_info,
+ (StgPtr) &stg_ctoi_t62_info,
+};
+
#if defined(PROFILING)
//
@@ -1828,82 +1894,11 @@ run_BCO:
SpW(-1) = BCO_PTR(o_tuple_bco);
SpW(-2) = tuple_info;
SpW(-3) = BCO_PTR(o_bco);
- W_ ctoi_t_offset;
int tuple_stack_words = (tuple_info >> 24) & 0xff;
- switch(tuple_stack_words) {
- case 0: ctoi_t_offset = (W_)&stg_ctoi_t0_info; break;
- case 1: ctoi_t_offset = (W_)&stg_ctoi_t1_info; break;
- case 2: ctoi_t_offset = (W_)&stg_ctoi_t2_info; break;
- case 3: ctoi_t_offset = (W_)&stg_ctoi_t3_info; break;
- case 4: ctoi_t_offset = (W_)&stg_ctoi_t4_info; break;
- case 5: ctoi_t_offset = (W_)&stg_ctoi_t5_info; break;
- case 6: ctoi_t_offset = (W_)&stg_ctoi_t6_info; break;
- case 7: ctoi_t_offset = (W_)&stg_ctoi_t7_info; break;
- case 8: ctoi_t_offset = (W_)&stg_ctoi_t8_info; break;
- case 9: ctoi_t_offset = (W_)&stg_ctoi_t9_info; break;
-
- case 10: ctoi_t_offset = (W_)&stg_ctoi_t10_info; break;
- case 11: ctoi_t_offset = (W_)&stg_ctoi_t11_info; break;
- case 12: ctoi_t_offset = (W_)&stg_ctoi_t12_info; break;
- case 13: ctoi_t_offset = (W_)&stg_ctoi_t13_info; break;
- case 14: ctoi_t_offset = (W_)&stg_ctoi_t14_info; break;
- case 15: ctoi_t_offset = (W_)&stg_ctoi_t15_info; break;
- case 16: ctoi_t_offset = (W_)&stg_ctoi_t16_info; break;
- case 17: ctoi_t_offset = (W_)&stg_ctoi_t17_info; break;
- case 18: ctoi_t_offset = (W_)&stg_ctoi_t18_info; break;
- case 19: ctoi_t_offset = (W_)&stg_ctoi_t19_info; break;
-
- case 20: ctoi_t_offset = (W_)&stg_ctoi_t20_info; break;
- case 21: ctoi_t_offset = (W_)&stg_ctoi_t21_info; break;
- case 22: ctoi_t_offset = (W_)&stg_ctoi_t22_info; break;
- case 23: ctoi_t_offset = (W_)&stg_ctoi_t23_info; break;
- case 24: ctoi_t_offset = (W_)&stg_ctoi_t24_info; break;
- case 25: ctoi_t_offset = (W_)&stg_ctoi_t25_info; break;
- case 26: ctoi_t_offset = (W_)&stg_ctoi_t26_info; break;
- case 27: ctoi_t_offset = (W_)&stg_ctoi_t27_info; break;
- case 28: ctoi_t_offset = (W_)&stg_ctoi_t28_info; break;
- case 29: ctoi_t_offset = (W_)&stg_ctoi_t29_info; break;
-
- case 30: ctoi_t_offset = (W_)&stg_ctoi_t30_info; break;
- case 31: ctoi_t_offset = (W_)&stg_ctoi_t31_info; break;
- case 32: ctoi_t_offset = (W_)&stg_ctoi_t32_info; break;
- case 33: ctoi_t_offset = (W_)&stg_ctoi_t33_info; break;
- case 34: ctoi_t_offset = (W_)&stg_ctoi_t34_info; break;
- case 35: ctoi_t_offset = (W_)&stg_ctoi_t35_info; break;
- case 36: ctoi_t_offset = (W_)&stg_ctoi_t36_info; break;
- case 37: ctoi_t_offset = (W_)&stg_ctoi_t37_info; break;
- case 38: ctoi_t_offset = (W_)&stg_ctoi_t38_info; break;
- case 39: ctoi_t_offset = (W_)&stg_ctoi_t39_info; break;
-
- case 40: ctoi_t_offset = (W_)&stg_ctoi_t40_info; break;
- case 41: ctoi_t_offset = (W_)&stg_ctoi_t41_info; break;
- case 42: ctoi_t_offset = (W_)&stg_ctoi_t42_info; break;
- case 43: ctoi_t_offset = (W_)&stg_ctoi_t43_info; break;
- case 44: ctoi_t_offset = (W_)&stg_ctoi_t44_info; break;
- case 45: ctoi_t_offset = (W_)&stg_ctoi_t45_info; break;
- case 46: ctoi_t_offset = (W_)&stg_ctoi_t46_info; break;
- case 47: ctoi_t_offset = (W_)&stg_ctoi_t47_info; break;
- case 48: ctoi_t_offset = (W_)&stg_ctoi_t48_info; break;
- case 49: ctoi_t_offset = (W_)&stg_ctoi_t49_info; break;
-
- case 50: ctoi_t_offset = (W_)&stg_ctoi_t50_info; break;
- case 51: ctoi_t_offset = (W_)&stg_ctoi_t51_info; break;
- case 52: ctoi_t_offset = (W_)&stg_ctoi_t52_info; break;
- case 53: ctoi_t_offset = (W_)&stg_ctoi_t53_info; break;
- case 54: ctoi_t_offset = (W_)&stg_ctoi_t54_info; break;
- case 55: ctoi_t_offset = (W_)&stg_ctoi_t55_info; break;
- case 56: ctoi_t_offset = (W_)&stg_ctoi_t56_info; break;
- case 57: ctoi_t_offset = (W_)&stg_ctoi_t57_info; break;
- case 58: ctoi_t_offset = (W_)&stg_ctoi_t58_info; break;
- case 59: ctoi_t_offset = (W_)&stg_ctoi_t59_info; break;
-
- case 60: ctoi_t_offset = (W_)&stg_ctoi_t60_info; break;
- case 61: ctoi_t_offset = (W_)&stg_ctoi_t61_info; break;
- case 62: ctoi_t_offset = (W_)&stg_ctoi_t62_info; break;
-
- default: barf("unsupported tuple size %d", tuple_stack_words);
+ if (tuple_stack_words > 62) {
+ barf("unsupported tuple size %d", tuple_stack_words);
}
-
+ W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
SpW(-4) = ctoi_t_offset;
Sp_subW(4);
goto nextInsn;
=====================================
testsuite/tests/driver/json.stderr
=====================================
@@ -1 +1 @@
-{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}
+{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"rendered":"json.hs:9:11: error: [GHC-48010]\n Empty list of alternatives in case expression\n Suggested fix:\n Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}
=====================================
testsuite/tests/driver/json_warn.stderr
=====================================
@@ -1,2 +1,2 @@
-{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
-{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}
+{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n Defined but not used: \u2018x\u2019\n","message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
+{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n In the use of \u2018head\u2019\n (imported from Prelude, but defined in GHC.Internal.List):\n \"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\"\n","message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46d49146f1c449641db3bb346e58d1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46d49146f1c449641db3bb346e58d1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/amg/castz] 2 commits: Accept output change for ghci024
by Adam Gundry (＠adamgundry) 23 Jul '25
by Adam Gundry (＠adamgundry) 23 Jul '25
23 Jul '25
Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC
Commits:
e7c9343f by Adam Gundry at 2025-07-23T20:53:56+01:00
Accept output change for ghci024
- - - - -
79d86db2 by Adam Gundry at 2025-07-23T20:53:56+01:00
Attempt to move cast zapping to the zonker
- - - - -
6 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Zonk/Type.hs
- testsuite/tests/ghci/scripts/ghci024.stdout
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -1783,6 +1783,7 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r, eb_info = info }) = do
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvExpr e) = return e
+dsEvTerm (EvCastExpr e co _) = return (Cast e co)
dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
dsEvTerm (EvFun { et_tvs = tvs, et_given = given
, et_binds = ev_binds, et_body = wanted_id })
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -30,6 +30,7 @@ import GHC.Types.Avail ( Avails )
import GHC.Data.Bag ( Bag, bagToList )
import GHC.Types.Basic
import GHC.Data.BooleanFormula
+import GHC.Core ( Expr(Cast) )
import GHC.Core.Class ( className, classSCSelIds )
import GHC.Core.ConLike ( conLikeName )
import GHC.Core.FVs
@@ -674,6 +675,7 @@ instance ToHie (Context (Located (WithUserRdr Name))) where
evVarsOfTermList :: EvTerm -> [EvId]
evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e
+evVarsOfTermList (EvCastExpr e co _ty) = exprSomeFreeVarsList isEvVar (Cast e co) -- TODO really
evVarsOfTermList (EvTypeable _ ev) =
case ev of
EvTypeableTyCon _ e -> concatMap evVarsOfTermList e
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -36,8 +36,8 @@ import GHC.Core.Predicate
import GHC.Core.Reduction
import GHC.Core.Coercion
import GHC.Core.Class( classHasSCs )
-import GHC.Core.TyCo.FVs
-import GHC.Core.TyCo.Rep (Coercion(..))
+-- import GHC.Core.TyCo.FVs
+-- import GHC.Core.TyCo.Rep (Coercion(..))
import GHC.Types.Id( idType )
import GHC.Types.Var( EvVar, tyVarKind )
@@ -52,7 +52,7 @@ import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Driver.Session
-import GHC.Driver.DynFlags ( hasZapCasts )
+-- import GHC.Driver.DynFlags ( hasZapCasts )
import Data.List( deleteFirstsBy )
@@ -1457,12 +1457,12 @@ finish_rewrite
(Reduction co new_pred)
rewriters
= assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted
- do { zap_casts <- hasZapCasts <$> getDynFlags
+ do { -- zap_casts <- hasZapCasts <$> getDynFlags
; let loc = ctEvLoc ev
-- mkEvCast optimises ReflCo
ev_rw_role = ctEvRewriteRole ev
new_tm = assert (coercionRole co == ev_rw_role)
- evCastCo (evId old_evar) (mkCastCoercion zap_casts new_pred (downgradeRole Representational ev_rw_role co))
+ evCastCo (evId old_evar) (downgradeRole Representational ev_rw_role co) new_pred
; new_ev <- newGivenEvVar loc (new_pred, new_tm)
; continueWith $ CtGiven new_ev }
@@ -1470,14 +1470,14 @@ finish_rewrite
ev@(CtWanted (WantedCt { ctev_pred = old_pred, ctev_rewriters = rewriters, ctev_dest = dest }))
(Reduction co new_pred)
new_rewriters
- = do { zap_casts <- hasZapCasts <$> getDynFlags
+ = do { -- zap_casts <- hasZapCasts <$> getDynFlags
; let loc = ctEvLoc ev
rewriters' = rewriters S.<> new_rewriters
ev_rw_role = ctEvRewriteRole ev
; mb_new_ev <- newWanted loc rewriters' new_pred
; massert (coercionRole co == ev_rw_role)
; setWantedEvTerm dest EvCanonical $
- evCastCo (getEvExpr mb_new_ev) (mkCastCoercion zap_casts old_pred (downgradeRole Representational ev_rw_role (mkSymCo co)))
+ evCastCo (getEvExpr mb_new_ev) (downgradeRole Representational ev_rw_role (mkSymCo co)) old_pred
; case mb_new_ev of
Fresh new_ev -> continueWith $ CtWanted new_ev
Cached _ -> stopWith ev "Cached wanted" }
@@ -1492,10 +1492,10 @@ finish_rewrite
--
-- See Note [Zapped casts] in GHC.Core.TyCo.Rep.
--
-mkCastCoercion :: Bool -> Type -> Coercion -> CastCoercion
-mkCastCoercion zap_casts lhs_ty co
- | isSmallCo co || not zap_casts = CCoercion co
- | otherwise = ZCoercion lhs_ty (shallowCoVarsOfCo co)
+-- mkCastCoercion :: Bool -> Type -> Coercion -> CastCoercion
+-- mkCastCoercion zap_casts lhs_ty co
+-- | isSmallCo co || not zap_casts = CCoercion co
+-- | otherwise = ZCoercion lhs_ty (shallowCoVarsOfCo co)
-- | Is this coercion probably smaller than its type? This is a rough heuristic,
-- but crucially we treat axioms (perhaps wrapped in Sym/Sub/etc.) as small
@@ -1505,24 +1505,24 @@ mkCastCoercion zap_casts lhs_ty co
--
-- so we want to cast by `CCoercion (axF <Int>)` rather than `ZCoercion SomeVeryBigType []`.
--
-isSmallCo :: Coercion -> Bool
-isSmallCo Refl{} = True
-isSmallCo GRefl{} = True
-isSmallCo AxiomCo{} = True
-isSmallCo CoVarCo{} = True
-isSmallCo (SymCo co) = isSmallCo co
-isSmallCo (KindCo co) = isSmallCo co
-isSmallCo (SubCo co) = isSmallCo co
-isSmallCo TyConAppCo{} = False
-isSmallCo AppCo{} = False
-isSmallCo ForAllCo{} = False
-isSmallCo FunCo{} = False
-isSmallCo UnivCo{} = False
-isSmallCo TransCo{} = False
-isSmallCo SelCo{} = False
-isSmallCo LRCo{} = False
-isSmallCo InstCo{} = False
-isSmallCo HoleCo{} = False
+-- isSmallCo :: Coercion -> Bool
+-- isSmallCo Refl{} = True
+-- isSmallCo GRefl{} = True
+-- isSmallCo AxiomCo{} = True
+-- isSmallCo CoVarCo{} = True
+-- isSmallCo (SymCo co) = isSmallCo co
+-- isSmallCo (KindCo co) = isSmallCo co
+-- isSmallCo (SubCo co) = isSmallCo co
+-- isSmallCo TyConAppCo{} = False
+-- isSmallCo AppCo{} = False
+-- isSmallCo ForAllCo{} = False
+-- isSmallCo FunCo{} = False
+-- isSmallCo UnivCo{} = False
+-- isSmallCo TransCo{} = False
+-- isSmallCo SelCo{} = False
+-- isSmallCo LRCo{} = False
+-- isSmallCo InstCo{} = False
+-- isSmallCo HoleCo{} = False
{- *******************************************************************
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -502,6 +502,8 @@ mkGivenEvBind ev tm = EvBind { eb_info = EvBindGiven, eb_lhs = ev, eb_rhs = tm }
data EvTerm
= EvExpr EvExpr
+ | EvCastExpr EvExpr TcCastCoercion TcType
+
| EvTypeable Type EvTypeable -- Dictionary for (Typeable ty)
| EvFun -- /\as \ds. let binds in v
@@ -530,10 +532,10 @@ evCoercion co = EvExpr (Coercion co)
-- | d |> co
evCast :: EvExpr -> TcCoercion -> EvTerm
evCast et tc | isReflCo tc = EvExpr et
- | otherwise = evCastCo et (CCoercion tc)
+ | otherwise = EvExpr (Cast et (CCoercion tc))
-evCastCo :: EvExpr -> TcCastCoercion -> EvTerm
-evCastCo et tc = EvExpr (Cast et tc)
+evCastCo :: EvExpr -> TcCoercion -> TcType -> EvTerm
+evCastCo et co co_res_ty = EvCastExpr et (CCoercion co) co_res_ty
-- Dictionary instance application
evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm
@@ -889,6 +891,7 @@ findNeededEvVars ev_binds seeds
evVarsOfTerm :: EvTerm -> VarSet
evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e
+evVarsOfTerm (EvCastExpr e co _ty) = exprSomeFreeVars isEvVar (Cast e co) -- TODO safe to ignore ty here?
evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev
evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun]
@@ -985,6 +988,7 @@ instance Outputable EvBind where
instance Outputable EvTerm where
ppr (EvExpr e) = ppr e
+ ppr (EvCastExpr e co ty) = text "EvCastExpr" <+> ppr e <+> ppr co <+> ppr ty
ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty
ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w })
= hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow)
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -59,6 +59,7 @@ import GHC.Tc.Zonk.TcType
( tcInitTidyEnv, tcInitOpenTidyEnv
, writeMetaTyVarRef
, checkCoercionHole
+ , unpackCoercionHole_maybe
, zonkCoVar )
import GHC.Core.Type
@@ -97,6 +98,9 @@ import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Data.List.NonEmpty ( NonEmpty )
import Data.Foldable ( toList )
+import Data.Semigroup
+
+import GHC.Driver.DynFlags ( getDynFlags, hasZapCasts )
{- Note [What is zonking?]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1762,9 +1766,49 @@ Wrinkles:
************************************************************************
-}
+zonkShallowCoVarsOfCo :: TcCoercion -> ZonkTcM CoVarSet
+zonkShallowCoVarsOfCo co
+ = unZCVSM $ go_co co
+ where
+ go_hole :: CoercionHole -> ZonkTcM CoVarSet
+ go_hole hole
+ = do { m_co <- lift $ liftZonkM $ unpackCoercionHole_maybe hole
+ ; case m_co of
+ Nothing -> return emptyVarSet -- Not filled (TODO emit log message?)
+ Just co -> unZCVSM (go_co co) } -- Filled: look inside
+
+ go_co :: Coercion -> ZonkCoVarSetMonoid
+ (_, _, go_co, _) = foldTyCo folder ()
+
+ folder :: TyCoFolder () ZonkCoVarSetMonoid
+ folder = TyCoFolder { tcf_view = noView
+ , tcf_tyvar = \ _ _ -> mempty
+ , tcf_covar = \ _ cv -> ZCVSM (pure (unitVarSet cv))
+ , tcf_hole = \ _ -> ZCVSM . go_hole
+ , tcf_tycobinder = \ _ _ _ -> () }
+
+newtype ZonkCoVarSetMonoid = ZCVSM { unZCVSM :: ZonkTcM CoVarSet }
+
+instance Semigroup ZonkCoVarSetMonoid where
+ ZCVSM l <> ZCVSM r = ZCVSM (unionVarSet <$> l <*> r)
+
+instance Monoid ZonkCoVarSetMonoid where
+ mempty = ZCVSM (return emptyVarSet)
+
+
+
zonkEvTerm :: EvTerm -> ZonkTcM EvTerm
zonkEvTerm (EvExpr e)
= EvExpr <$> zonkCoreExpr e
+zonkEvTerm (EvCastExpr e (CCoercion co) co_res_ty)
+ = do { zap_casts <- hasZapCasts <$> lift getDynFlags
+ ; co_res_ty' <- zonkTcTypeToTypeX co_res_ty
+ ; if zap_casts
+ then EvCastExpr <$> zonkCoreExpr e <*> (ZCoercion co_res_ty' <$> zonkShallowCoVarsOfCo co) <*> pure co_res_ty'
+ else EvExpr <$> zonkCoreExpr (Cast e (CCoercion co))
+ }
+zonkEvTerm ev@(EvCastExpr _ (ZCoercion{}) _)
+ = pprPanic "zonkEvTerm: ZCoercion" (ppr ev)
zonkEvTerm (EvTypeable ty ev)
= EvTypeable <$> zonkTcTypeToTypeX ty <*> zonkEvTypeable ev
zonkEvTerm (EvFun { et_tvs = tvs, et_given = evs
=====================================
testsuite/tests/ghci/scripts/ghci024.stdout
=====================================
@@ -15,6 +15,7 @@ other dynamic, non-language, flag settings:
-fshow-warning-groups
-fprefer-byte-code
-fbreak-points
+ -fno-zap-casts
warning settings:
-Wpattern-namespace-specifier
~~~~~~~~~~ Testing :set -a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32459579d089bd4a389a3c1b56ef6f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32459579d089bd4a389a3c1b56ef6f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/step-out-11] Add InternalBreakLocs for code-generation time Brk locations
by Rodrigo Mesquita (＠alt-romes) 23 Jul '25
by Rodrigo Mesquita (＠alt-romes) 23 Jul '25
23 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-11 at Glasgow Haskell Compiler / GHC
Commits:
b4387c89 by Rodrigo Mesquita at 2025-07-23T18:41:27+01:00
Add InternalBreakLocs for code-generation time Brk locations
T26042d2 is a simple example displaying how this approach is not good
enough e.g. for do blocks because the cases continuations currently end
up not surrounded by a tick.
TODO: Figure out how to add BRK_FUNs to all case continuations where it
is relevant that we can step out to
TODO: Test step-out from a continuation which receives an unboxed tuple as an argument
- - - - -
11 changed files:
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- ghc/GHCi/UI.hs
- + testsuite/tests/ghci.debugger/scripts/T26042d2.hs
- + testsuite/tests/ghci.debugger/scripts/T26042d2.script
- + testsuite/tests/ghci.debugger/scripts/T26042d2.stdout
- testsuite/tests/ghci.debugger/scripts/T26042g.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
Changes:
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DerivingStrategies #-}
-- | Breakpoint information constructed during ByteCode generation.
--
@@ -15,6 +16,7 @@ module GHC.ByteCode.Breakpoints
-- ** Internal breakpoint identifier
, InternalBreakpointId(..), BreakInfoIndex
+ , InternalBreakLoc(..)
-- * Operations
@@ -23,7 +25,7 @@ module GHC.ByteCode.Breakpoints
-- ** Source-level information operations
, getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS
- , getBreakSourceId
+ , getBreakSourceId, getBreakSourceMod
-- * Utils
, seqInternalModBreaks
@@ -165,7 +167,7 @@ data CgBreakInfo
{ cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
, cgb_vars :: ![Maybe (IfaceIdBndr, Word)]
, cgb_resty :: !IfaceType
- , cgb_tick_id :: !BreakpointId
+ , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId)
-- ^ This field records the original breakpoint tick identifier for this
-- internal breakpoint info. It is used to convert a breakpoint
-- *occurrence* index ('InternalBreakpointId') into a *definition* index
@@ -173,9 +175,19 @@ data CgBreakInfo
--
-- The modules of breakpoint occurrence and breakpoint definition are not
-- necessarily the same: See Note [Breakpoint identifiers].
+ --
+ -- If there is no original tick identifier (that is, the breakpoint was
+ -- created during code generation), instead refer directly to the SrcSpan
+ -- we want to use for it. See Note [Internal Breakpoint Locations]
}
-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
+-- | Breakpoints created during code generation don't have a source-level tick
+-- location. Instead, we come up with one ourselves.
+-- See Note [Internal Breakpoint Locations]
+newtype InternalBreakLoc = InternalBreakLoc SrcSpan
+ deriving newtype (Eq, Show, NFData, Outputable)
+
-- | Get an internal breakpoint info by 'InternalBreakpointId'
getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo
getInternalBreak (InternalBreakpointId mod ix) imbs =
@@ -196,27 +208,36 @@ assert_modules_match ibi_mod imbs_mod =
-- | Get the source module and tick index for this breakpoint
-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId')
-getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId
+getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> Either InternalBreakLoc BreakpointId
getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs =
assert_modules_match ibi_mod (imodBreaks_module imbs) $
let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
in cgb_tick_id cgb
+-- | Get the source module for this breakpoint (where the breakpoint is defined)
+getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module
+getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs =
+ assert_modules_match ibi_mod (imodBreaks_module imbs) $
+ let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
+ in case cgb_tick_id cgb of
+ Left InternalBreakLoc{} -> imodBreaks_module imbs
+ Right BreakpointId{bi_tick_mod} -> bi_tick_mod
+
-- | Get the source span for this breakpoint
getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan
-getBreakLoc = getBreakXXX modBreaks_locs
+getBreakLoc = getBreakXXX modBreaks_locs (\(InternalBreakLoc x) -> x)
-- | Get the vars for this breakpoint
getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName]
-getBreakVars = getBreakXXX modBreaks_vars
+getBreakVars = getBreakXXX modBreaks_vars (const [])
-- | Get the decls for this breakpoint
getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
-getBreakDecls = getBreakXXX modBreaks_decls
+getBreakDecls = getBreakXXX modBreaks_decls (const [])
-- | Get the decls for this breakpoint
-getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (String, String)
-getBreakCCS = getBreakXXX modBreaks_ccs
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (Maybe (String, String))
+getBreakCCS = getBreakXXX (fmap Just . modBreaks_ccs) (const Nothing)
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
--
@@ -228,14 +249,17 @@ getBreakCCS = getBreakXXX modBreaks_ccs
-- 'ModBreaks'. When the tick module is different, we need to look up the
-- 'ModBreaks' in the HUG for that other module.
--
+-- When there is no tick module (the breakpoint was generated at codegen), use
+-- the function on internal mod breaks.
+--
-- To avoid cyclic dependencies, we instead receive a function that looks up
-- the 'ModBreaks' given a 'Module'
-getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
-getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (InternalBreakLoc -> a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
+getBreakXXX view viewInternal lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
assert_modules_match ibi_mod (imodBreaks_module imbs) $ do
let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
case cgb_tick_id cgb of
- BreakpointId{bi_tick_mod, bi_tick_index}
+ Right BreakpointId{bi_tick_mod, bi_tick_index}
| bi_tick_mod == ibi_mod
-> do
let these_mbs = imodBreaks_modBreaks imbs
@@ -244,6 +268,8 @@ getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
-> do
other_mbs <- lookupModule bi_tick_mod
return $ view other_mbs ! bi_tick_index
+ Left l ->
+ return $ viewInternal l
--------------------------------------------------------------------------------
-- Instances
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -58,6 +58,7 @@ import GHCi.RemoteTypes
import GHC.Iface.Load
import GHCi.Message (ConInfoTable(..), LoadedDLL)
+import GHC.ByteCode.Breakpoints
import GHC.ByteCode.Linker
import GHC.ByteCode.Asm
import GHC.ByteCode.Types
@@ -1711,8 +1712,10 @@ allocateCCS interp ce mbss
let count = 1 + (maybe 0 fst $ IM.lookupMax imodBreaks_breakInfo)
let ccs = IM.map
(\info ->
- fromMaybe (toRemotePtr nullPtr)
- (M.lookup (cgb_tick_id info) ccss)
+ case cgb_tick_id info of
+ Right bi -> fromMaybe (toRemotePtr nullPtr)
+ (M.lookup bi ccss)
+ Left InternalBreakLoc{} -> toRemotePtr nullPtr
)
imodBreaks_breakInfo
assertPpr (count == length ccs)
=====================================
compiler/GHC/Runtime/Debugger/Breakpoints.hs
=====================================
@@ -253,8 +253,11 @@ mkBreakpointOccurrences = do
let imod = modBreaks_module $ imodBreaks_modBreaks ibrks
IntMap.foldrWithKey (\info_ix cgi bmp -> do
let ibi = InternalBreakpointId imod info_ix
- let BreakpointId tick_mod tick_ix = cgb_tick_id cgi
- extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
+ case cgb_tick_id cgi of
+ Right (BreakpointId tick_mod tick_ix)
+ -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
+ Left _
+ -> bmp
) bmp0 (imodBreaks_breakInfo ibrks)
--------------------------------------------------------------------------------
@@ -287,7 +290,7 @@ getCurrentBreakModule = do
Nothing -> pure Nothing
Just ibi -> do
brks <- readIModBreaks hug ibi
- return $ Just $ bi_tick_mod $ getBreakSourceId ibi brks
+ return $ Just $ getBreakSourceMod ibi brks
ix ->
Just <$> getHistoryModule hug (resumeHistory r !! (ix-1))
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -151,7 +151,7 @@ getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module
getHistoryModule hug hist = do
let ibi = historyBreakpointId hist
brks <- readIModBreaks hug ibi
- return $ bi_tick_mod $ getBreakSourceId ibi brks
+ return $ getBreakSourceMod ibi brks
getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan
getHistorySpan hug hist = do
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -63,7 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
assertNonVoidIds, assertNonVoidStgArgs )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
-import GHC.Runtime.Interpreter ( interpreterProfiled )
+import GHC.Runtime.Interpreter ( interpreterProfiled, readIModModBreaks )
import GHC.Data.Bitmap
import GHC.Data.FlatBag as FlatBag
import GHC.Data.OrdList
@@ -99,6 +99,7 @@ import GHC.CoreToIface
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State (StateT(..))
+import Data.Array ((!))
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -393,26 +394,30 @@ schemeR_wrk fvs nm original_body (args, body)
-- | Introduce break instructions for ticked expressions.
-- If no breakpoint information is available, the instruction is omitted.
schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
-schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do
- code <- schemeE d 0 p rhs
- mb_current_mod_breaks <- getCurrentModBreaks
- case mb_current_mod_breaks of
- -- if we're not generating ModBreaks for this module for some reason, we
- -- can't store breakpoint occurrence information.
- Nothing -> pure code
- Just current_mod_breaks -> do
- platform <- profilePlatform <$> getProfile
- let idOffSets = getVarOffSets platform d p fvs
- ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
- toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
- toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
- breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id
-
- let info_mod = modBreaks_module current_mod_breaks
- infox <- newBreakInfo breakInfo
+schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do
+ platform <- profilePlatform <$> getProfile
+
+ code <- case rhs of
+ -- When we find a tick surrounding a case expression we introduce a new BRK_FUN
+ -- instruction at the start of the case *continuation*, in addition to the
+ -- usual BRK_FUN surrounding the StgCase)
+ -- See Note [TODO]
+ StgCase scrut bndr _ alts
+ -> doCase d 0 p (Just bp) scrut bndr alts
+ _ -> schemeE d 0 p rhs
+
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Right tick_id)
+
+ mibi <- newBreakInfo breakInfo
+
+ return $ case mibi of
+ Nothing -> code
+ Just ibi -> BRK_FUN ibi `consOL` code
- let breakInstr = BRK_FUN (InternalBreakpointId info_mod infox)
- return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
@@ -614,7 +619,7 @@ schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
schemeE d s p (StgCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts
+ = doCase d s p Nothing scrut bndr alts
{-
@@ -1106,11 +1111,15 @@ doCase
:: StackDepth
-> Sequel
-> BCEnv
+ -> Maybe StgTickish
+ -- ^ The breakpoint surrounding the full case expression, if any (only
+ -- source-level cases get breakpoint ticks, and those are the only we care
+ -- about). See Note [TODO]
-> CgStgExpr
-> Id
-> [CgStgAlt]
-> BcM BCInstrList
-doCase d s p scrut bndr alts
+doCase d s p m_bid scrut bndr alts
= do
profile <- getProfile
hsc_env <- getHscEnv
@@ -1325,19 +1334,35 @@ doCase d s p scrut bndr alts
| ubx_tuple_frame = SLIDE 0 3 `consOL` alt_final1
| otherwise = SLIDE 0 1 `consOL` alt_final1
- -- when `BRK_FUN` in a case continuation BCO executes,
- -- the stack will already have a full continuation that just
- -- re-executes the BCO being stopped at (including the stg_ret and
- -- stg_ctoi frames)
- --
- -- right after the `BRK_FUN`, all case continuations will drop the
- -- stg_ret and stg_ctoi headers (see alt_final1, alt_final2), leaving
- -- the stack with the bound return values followed by the free variables
- alt_final
- | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)
- -- See Note [Debugger: BRK_ALTS]
- = BRK_ALTS False `consOL` alt_final2
- | otherwise = alt_final2
+ -- when `BRK_FUN` in a case continuation BCO executes,
+ -- the stack will already have a full continuation that just
+ -- re-executes the BCO being stopped at (including the stg_ret and
+ -- stg_ctoi frames)
+ --
+ -- right after the `BRK_FUN`, all case continuations will drop the
+ -- stg_ret and stg_ctoi headers (see alt_final1, alt_final2), leaving
+ -- the stack with the bound return values followed by the free variables
+ alt_final <- case m_bid of
+ Just (Breakpoint tick_ty tick_id fvs)
+ | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)
+ -- Construct an internal breakpoint to put at the start of this case
+ -- continuation BCO.
+ -- See Note [TODO]
+ -> do
+ internal_tick_loc <- makeCaseInternalBreakLoc tick_id
+
+ -- same fvs available in the case expression are available in the case continuation
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Left internal_tick_loc)
+
+ mibi <- newBreakInfo breakInfo
+ return $ case mibi of
+ Nothing -> alt_final2
+ Just ibi -> BRK_FUN ibi `consOL` alt_final2
+ _ -> pure alt_final2
add_bco_name <- shouldAddBcoName
let
@@ -1357,6 +1382,24 @@ doCase d s p scrut bndr alts
_ -> panic "schemeE(StgCase).push_alts"
in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code)
+makeCaseInternalBreakLoc :: BreakpointId -> BcM InternalBreakLoc
+makeCaseInternalBreakLoc bid = do
+ hug <- hsc_HUG <$> getHscEnv
+ curr_mod <- getCurrentModule
+ mb_mod_brks <- getCurrentModBreaks
+
+ -- TODO: Subtract the scrutinee loc from the case loc to get continuation loc
+ InternalBreakLoc <$> case bid of
+ BreakpointId{bi_tick_mod, bi_tick_index}
+ | bi_tick_mod == curr_mod
+ , Just these_mbs <- mb_mod_brks
+ -> do
+ return $ modBreaks_locs these_mbs ! bi_tick_index
+ | otherwise
+ -> do
+ other_mbs <- liftIO $ readIModModBreaks hug bi_tick_mod
+ return $ modBreaks_locs other_mbs ! bi_tick_index
+
{-
Note [Debugger: BRK_ALTS]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2677,14 +2720,19 @@ getLabelsBc n = BcM $ \_ st ->
let ctr = nextlabel st
in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n})
-newBreakInfo :: CgBreakInfo -> BcM Int
-newBreakInfo info = BcM $ \_ st ->
- let ix = breakInfoIdx st
- st' = st
- { breakInfo = IntMap.insert ix info (breakInfo st)
- , breakInfoIdx = ix + 1
- }
- in return (ix, st')
+newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId)
+newBreakInfo info = BcM $ \env st -> do
+ -- if we're not generating ModBreaks for this module for some reason, we
+ -- can't store breakpoint occurrence information.
+ case modBreaks env of
+ Nothing -> pure (Nothing, st)
+ Just modBreaks -> do
+ let ix = breakInfoIdx st
+ st' = st
+ { breakInfo = IntMap.insert ix info (breakInfo st)
+ , breakInfoIdx = ix + 1
+ }
+ return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st')
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \env st -> return (bcm_module env, st)
@@ -2697,7 +2745,7 @@ tickFS = fsLit "ticked"
-- Dehydrating CgBreakInfo
-dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> BreakpointId -> CgBreakInfo
+dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo
dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid =
CgBreakInfo
{ cgb_tyvars = map toIfaceTvBndr ty_vars
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -45,7 +45,7 @@ import GHC.Runtime.Eval (mkTopLevEnv)
import GHC.Runtime.Eval.Utils
-- The GHC interface
-import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId)
+import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId, getBreakSourceMod)
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
import GHCi.BreakArray( breakOn, breakOff )
@@ -1621,7 +1621,7 @@ toBreakIdAndLocation (Just inf) = do
brks <- liftIO $ readIModBreaks hug inf
let bi = getBreakSourceId inf brks
return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
- breakId loc == bi ]
+ Right (breakId loc) == bi ]
printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo res names = do
@@ -3825,7 +3825,7 @@ pprStopped res = do
hug <- hsc_HUG <$> GHC.getSession
brks <- liftIO $ readIModBreaks hug ibi
return $ Just $ moduleName $
- bi_tick_mod $ getBreakSourceId ibi brks
+ getBreakSourceMod ibi brks
return $
text "Stopped in"
<+> ((case mb_mod_name of
=====================================
testsuite/tests/ghci.debugger/scripts/T26042d2.hs
=====================================
@@ -0,0 +1,13 @@
+
+module Main where
+
+main = do
+ putStrLn "hello1"
+ f
+ putStrLn "hello3"
+ putStrLn "hello4"
+
+f = do
+ putStrLn "hello2.1"
+ putStrLn "hello2.2"
+{-# NOINLINE f #-}
=====================================
testsuite/tests/ghci.debugger/scripts/T26042d2.script
=====================================
@@ -0,0 +1,12 @@
+:load T26042d2.hs
+
+:break 11
+main
+:list
+:stepout
+:list
+:stepout
+
+-- should exit! we compile this test case with -O1 to make sure the monad >> are inlined
+-- and thus the test relies on the filtering behavior based on SrcSpans for stepout
+
=====================================
testsuite/tests/ghci.debugger/scripts/T26042d2.stdout
=====================================
@@ -0,0 +1,16 @@
+Breakpoint 0 activated at T26042d2.hs:11:3-21
+hello1
+Stopped in Main.f, T26042d2.hs:11:3-21
+_result ::
+ GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
+ -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
+ () #) = _
+10 f = do
+11 putStrLn "hello2.1"
+ ^^^^^^^^^^^^^^^^^^^
+12 putStrLn "hello2.2"
+hello2.1
+hello2.2
+<--- should break here too
+hello3
+hello4
=====================================
testsuite/tests/ghci.debugger/scripts/T26042g.stdout
=====================================
@@ -6,10 +6,13 @@ x :: Int = 14
11 succ x = (-) (x - 2) (x + 1)
^^^^^^^^^^^^^^^^^^^
12
-Stopped in T9.top, T26042g.hs:8:10-21
+Stopped in T9., T26042g.hs:(6,3)-(8,21)
_result :: Int = _
+5 top = do
+ vv
+6 case succ 14 of
7 5 -> 5
8 _ -> 6 + other 55
- ^^^^^^^^^^^^
+ ^^
9
171
=====================================
testsuite/tests/ghci.debugger/scripts/all.T
=====================================
@@ -147,8 +147,9 @@ test('T25932', extra_files(['T25932.hs']), ghci_script, ['T25932.script'])
# Step out tests
test('T26042b', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042b.hs'])], ghci_script, ['T26042b.script'])
-test('T26042c', [expect_broken(26042),extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042c.hs'])], ghci_script, ['T26042c.script'])
+test('T26042c', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042c.hs'])], ghci_script, ['T26042c.script'])
test('T26042d', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042d.hs'])], ghci_script, ['T26042d.script'])
+test('T26042d2', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042d2.hs'])], ghci_script, ['T26042d2.script'])
test('T26042e', extra_files(['T26042e.hs']), ghci_script, ['T26042e.script'])
test('T26042f1', extra_files(['T26042f.hs', 'T26042f.script']), ghci_script, ['T26042f.script']) # >> is not inlined, so stepout has nowhere to stop
test('T26042f2', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042f.hs', 'T26042f.script'])], ghci_script, ['T26042f.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4387c89b6042a9ce2f52483c6a984f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4387c89b6042a9ce2f52483c6a984f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/step-out-11] 3 commits: Makes sure run_BCO has variables directly on top of the stack
by Rodrigo Mesquita (＠alt-romes) 23 Jul '25
by Rodrigo Mesquita (＠alt-romes) 23 Jul '25
23 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-11 at Glasgow Haskell Compiler / GHC
Commits:
1362987b by Rodrigo Mesquita at 2025-07-23T18:39:34+01:00
Makes sure run_BCO has variables directly on top of the stack
Instead we kept ctoi_ret frames when entering run_BCO, and the ByteCode
generator accounted for the frame header and then slided it off.
Now, when run_BCO is called for a case continuation, the return value
and free variables are directly on top.
Making stg_ret_*_ stay at the start of the BCO
Actually, do add the ctoi frame header but remove it with static slides always in case conts
- - - - -
3ada6aa5 by Rodrigo Mesquita at 2025-07-23T18:40:19+01:00
Allow BRK_FUNs to head case continuation BCOs
- - - - -
cd1393d0 by Rodrigo Mesquita at 2025-07-23T18:40:20+01:00
Add InternalBreakLocs for code-generation time Brk locations
TODO: Test step-out from a continuation which receives an unboxed tuple as an argument
- - - - -
13 changed files:
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- ghc/GHCi/UI.hs
- libraries/ghci/GHCi/Run.hs
- rts/Interpreter.c
- + testsuite/tests/ghci.debugger/scripts/T26042d2.hs
- + testsuite/tests/ghci.debugger/scripts/T26042d2.script
- + testsuite/tests/ghci.debugger/scripts/T26042d2.stdout
- testsuite/tests/ghci.debugger/scripts/T26042g.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
Changes:
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DerivingStrategies #-}
-- | Breakpoint information constructed during ByteCode generation.
--
@@ -15,6 +16,7 @@ module GHC.ByteCode.Breakpoints
-- ** Internal breakpoint identifier
, InternalBreakpointId(..), BreakInfoIndex
+ , InternalBreakLoc(..)
-- * Operations
@@ -23,7 +25,7 @@ module GHC.ByteCode.Breakpoints
-- ** Source-level information operations
, getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS
- , getBreakSourceId
+ , getBreakSourceId, getBreakSourceMod
-- * Utils
, seqInternalModBreaks
@@ -165,7 +167,7 @@ data CgBreakInfo
{ cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
, cgb_vars :: ![Maybe (IfaceIdBndr, Word)]
, cgb_resty :: !IfaceType
- , cgb_tick_id :: !BreakpointId
+ , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId)
-- ^ This field records the original breakpoint tick identifier for this
-- internal breakpoint info. It is used to convert a breakpoint
-- *occurrence* index ('InternalBreakpointId') into a *definition* index
@@ -173,9 +175,19 @@ data CgBreakInfo
--
-- The modules of breakpoint occurrence and breakpoint definition are not
-- necessarily the same: See Note [Breakpoint identifiers].
+ --
+ -- If there is no original tick identifier (that is, the breakpoint was
+ -- created during code generation), instead refer directly to the SrcSpan
+ -- we want to use for it. See Note [Internal Breakpoint Locations]
}
-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
+-- | Breakpoints created during code generation don't have a source-level tick
+-- location. Instead, we come up with one ourselves.
+-- See Note [Internal Breakpoint Locations]
+newtype InternalBreakLoc = InternalBreakLoc SrcSpan
+ deriving newtype (Eq, Show, NFData, Outputable)
+
-- | Get an internal breakpoint info by 'InternalBreakpointId'
getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo
getInternalBreak (InternalBreakpointId mod ix) imbs =
@@ -196,27 +208,36 @@ assert_modules_match ibi_mod imbs_mod =
-- | Get the source module and tick index for this breakpoint
-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId')
-getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId
+getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> Either InternalBreakLoc BreakpointId
getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs =
assert_modules_match ibi_mod (imodBreaks_module imbs) $
let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
in cgb_tick_id cgb
+-- | Get the source module for this breakpoint (where the breakpoint is defined)
+getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module
+getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs =
+ assert_modules_match ibi_mod (imodBreaks_module imbs) $
+ let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
+ in case cgb_tick_id cgb of
+ Left InternalBreakLoc{} -> imodBreaks_module imbs
+ Right BreakpointId{bi_tick_mod} -> bi_tick_mod
+
-- | Get the source span for this breakpoint
getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan
-getBreakLoc = getBreakXXX modBreaks_locs
+getBreakLoc = getBreakXXX modBreaks_locs (\(InternalBreakLoc x) -> x)
-- | Get the vars for this breakpoint
getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName]
-getBreakVars = getBreakXXX modBreaks_vars
+getBreakVars = getBreakXXX modBreaks_vars (const [])
-- | Get the decls for this breakpoint
getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
-getBreakDecls = getBreakXXX modBreaks_decls
+getBreakDecls = getBreakXXX modBreaks_decls (const [])
-- | Get the decls for this breakpoint
-getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (String, String)
-getBreakCCS = getBreakXXX modBreaks_ccs
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (Maybe (String, String))
+getBreakCCS = getBreakXXX (fmap Just . modBreaks_ccs) (const Nothing)
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
--
@@ -228,14 +249,17 @@ getBreakCCS = getBreakXXX modBreaks_ccs
-- 'ModBreaks'. When the tick module is different, we need to look up the
-- 'ModBreaks' in the HUG for that other module.
--
+-- When there is no tick module (the breakpoint was generated at codegen), use
+-- the function on internal mod breaks.
+--
-- To avoid cyclic dependencies, we instead receive a function that looks up
-- the 'ModBreaks' given a 'Module'
-getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
-getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (InternalBreakLoc -> a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
+getBreakXXX view viewInternal lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
assert_modules_match ibi_mod (imodBreaks_module imbs) $ do
let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
case cgb_tick_id cgb of
- BreakpointId{bi_tick_mod, bi_tick_index}
+ Right BreakpointId{bi_tick_mod, bi_tick_index}
| bi_tick_mod == ibi_mod
-> do
let these_mbs = imodBreaks_modBreaks imbs
@@ -244,6 +268,8 @@ getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
-> do
other_mbs <- lookupModule bi_tick_mod
return $ view other_mbs ! bi_tick_index
+ Left l ->
+ return $ viewInternal l
--------------------------------------------------------------------------------
-- Instances
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -58,6 +58,7 @@ import GHCi.RemoteTypes
import GHC.Iface.Load
import GHCi.Message (ConInfoTable(..), LoadedDLL)
+import GHC.ByteCode.Breakpoints
import GHC.ByteCode.Linker
import GHC.ByteCode.Asm
import GHC.ByteCode.Types
@@ -1711,8 +1712,10 @@ allocateCCS interp ce mbss
let count = 1 + (maybe 0 fst $ IM.lookupMax imodBreaks_breakInfo)
let ccs = IM.map
(\info ->
- fromMaybe (toRemotePtr nullPtr)
- (M.lookup (cgb_tick_id info) ccss)
+ case cgb_tick_id info of
+ Right bi -> fromMaybe (toRemotePtr nullPtr)
+ (M.lookup bi ccss)
+ Left InternalBreakLoc{} -> toRemotePtr nullPtr
)
imodBreaks_breakInfo
assertPpr (count == length ccs)
=====================================
compiler/GHC/Runtime/Debugger/Breakpoints.hs
=====================================
@@ -253,8 +253,11 @@ mkBreakpointOccurrences = do
let imod = modBreaks_module $ imodBreaks_modBreaks ibrks
IntMap.foldrWithKey (\info_ix cgi bmp -> do
let ibi = InternalBreakpointId imod info_ix
- let BreakpointId tick_mod tick_ix = cgb_tick_id cgi
- extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
+ case cgb_tick_id cgi of
+ Right (BreakpointId tick_mod tick_ix)
+ -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
+ Left _
+ -> bmp
) bmp0 (imodBreaks_breakInfo ibrks)
--------------------------------------------------------------------------------
@@ -287,7 +290,7 @@ getCurrentBreakModule = do
Nothing -> pure Nothing
Just ibi -> do
brks <- readIModBreaks hug ibi
- return $ Just $ bi_tick_mod $ getBreakSourceId ibi brks
+ return $ Just $ getBreakSourceMod ibi brks
ix ->
Just <$> getHistoryModule hug (resumeHistory r !! (ix-1))
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -151,7 +151,7 @@ getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module
getHistoryModule hug hist = do
let ibi = historyBreakpointId hist
brks <- readIModBreaks hug ibi
- return $ bi_tick_mod $ getBreakSourceId ibi brks
+ return $ getBreakSourceMod ibi brks
getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan
getHistorySpan hug hist = do
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -63,7 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
assertNonVoidIds, assertNonVoidStgArgs )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
-import GHC.Runtime.Interpreter ( interpreterProfiled )
+import GHC.Runtime.Interpreter ( interpreterProfiled, readIModModBreaks )
import GHC.Data.Bitmap
import GHC.Data.FlatBag as FlatBag
import GHC.Data.OrdList
@@ -99,6 +99,7 @@ import GHC.CoreToIface
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State (StateT(..))
+import Data.Array ((!))
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -393,26 +394,30 @@ schemeR_wrk fvs nm original_body (args, body)
-- | Introduce break instructions for ticked expressions.
-- If no breakpoint information is available, the instruction is omitted.
schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
-schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do
- code <- schemeE d 0 p rhs
- mb_current_mod_breaks <- getCurrentModBreaks
- case mb_current_mod_breaks of
- -- if we're not generating ModBreaks for this module for some reason, we
- -- can't store breakpoint occurrence information.
- Nothing -> pure code
- Just current_mod_breaks -> do
- platform <- profilePlatform <$> getProfile
- let idOffSets = getVarOffSets platform d p fvs
- ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
- toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
- toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
- breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id
-
- let info_mod = modBreaks_module current_mod_breaks
- infox <- newBreakInfo breakInfo
+schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do
+ platform <- profilePlatform <$> getProfile
+
+ code <- case rhs of
+ -- When we find a tick surrounding a case expression we introduce a new BRK_FUN
+ -- instruction at the start of the case *continuation*, in addition to the
+ -- usual BRK_FUN surrounding the StgCase)
+ -- See Note [TODO]
+ StgCase scrut bndr _ alts
+ -> doCase d 0 p (Just bp) scrut bndr alts
+ _ -> schemeE d 0 p rhs
+
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Right tick_id)
+
+ mibi <- newBreakInfo breakInfo
+
+ return $ case mibi of
+ Nothing -> code
+ Just ibi -> BRK_FUN ibi `consOL` code
- let breakInstr = BRK_FUN (InternalBreakpointId info_mod infox)
- return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
@@ -614,7 +619,7 @@ schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
schemeE d s p (StgCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts
+ = doCase d s p Nothing scrut bndr alts
{-
@@ -1106,11 +1111,15 @@ doCase
:: StackDepth
-> Sequel
-> BCEnv
+ -> Maybe StgTickish
+ -- ^ The breakpoint surrounding the full case expression, if any (only
+ -- source-level cases get breakpoint ticks, and those are the only we care
+ -- about). See Note [TODO]
-> CgStgExpr
-> Id
-> [CgStgAlt]
-> BcM BCInstrList
-doCase d s p scrut bndr alts
+doCase d s p m_bid scrut bndr alts
= do
profile <- getProfile
hsc_env <- getHscEnv
@@ -1140,43 +1149,34 @@ doCase d s p scrut bndr alts
-- When an alt is entered, it assumes the returned value is
-- on top of the itbl; see Note [Return convention for non-tuple values]
-- for details.
- ret_frame_size_b :: StackDepth
- ret_frame_size_b | ubx_tuple_frame =
- (if profiling then 5 else 4) * wordSize platform
- | otherwise = 2 * wordSize platform
+ ret_frame_size_w :: WordOff
+ ret_frame_size_w | ubx_tuple_frame =
+ if profiling then 5 else 4
+ | otherwise = 2
-- The stack space used to save/restore the CCCS when profiling
save_ccs_size_b | profiling &&
not ubx_tuple_frame = 2 * wordSize platform
| otherwise = 0
- -- The size of the return frame info table pointer if one exists
- unlifted_itbl_size_b :: StackDepth
- unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform
- | otherwise = 0
-
(bndr_size, call_info, args_offsets)
| ubx_tuple_frame =
let bndr_reps = typePrimRep (idType bndr)
(call_info, args_offsets) =
layoutNativeCall profile NativeTupleReturn 0 id bndr_reps
- in ( wordsToBytes platform (nativeCallSize call_info)
+ in ( nativeCallSize call_info
, call_info
, args_offsets
)
- | otherwise = ( wordsToBytes platform (idSizeW platform bndr)
+ | otherwise = ( idSizeW platform bndr
, voidTupleReturnInfo
, []
)
- -- depth of stack after the return value has been pushed
+ -- Depth of stack after the return value has been pushed
+ -- This is the stack depth at the continuation.
d_bndr =
- d + ret_frame_size_b + bndr_size
-
- -- depth of stack after the extra info table for an unlifted return
- -- has been pushed, if any. This is the stack depth at the
- -- continuation.
- d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b
+ d + wordsToBytes platform bndr_size
-- Env in which to compile the alts, not including
-- any vars bound by the alts themselves
@@ -1188,13 +1188,13 @@ doCase d s p scrut bndr alts
-- given an alt, return a discr and code for it.
codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)
codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs}
- = do rhs_code <- schemeE d_alts s p_alts rhs
+ = do rhs_code <- schemeE d_bndr s p_alts rhs
return (NoDiscr, rhs_code)
codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}
-- primitive or nullary constructor alt: no need to UNPACK
| null real_bndrs = do
- rhs_code <- schemeE d_alts s p_alts rhs
+ rhs_code <- schemeE d_bndr s p_alts rhs
return (my_discr alt, rhs_code)
| isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =
let bndr_ty = idPrimRepU . fromNonVoid
@@ -1206,7 +1206,7 @@ doCase d s p scrut bndr alts
bndr_ty
(assertNonVoidIds bndrs)
- stack_bot = d_alts
+ stack_bot = d_bndr
p' = Map.insertList
[ (arg, tuple_start -
@@ -1224,7 +1224,7 @@ doCase d s p scrut bndr alts
(addIdReps (assertNonVoidIds real_bndrs))
size = WordOff tot_wds
- stack_bot = d_alts + wordsToBytes platform size
+ stack_bot = d_bndr + wordsToBytes platform size
-- convert offsets from Sp into offsets into the virtual stack
p' = Map.insertList
@@ -1324,22 +1324,53 @@ doCase d s p scrut bndr alts
alt_stuff <- mapM codeAlt alts
alt_final0 <- mkMultiBranch maybe_ncons alt_stuff
- let alt_final1
- | ubx_tuple_frame = SLIDE 0 2 `consOL` alt_final0
- | otherwise = alt_final0
- alt_final
- | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)
- -- See Note [Debugger: BRK_ALTS]
- = BRK_ALTS False `consOL` alt_final1
- | otherwise = alt_final1
+ let
+
+ -- drop the stg_ctoi_*_info header...
+ alt_final1 = SLIDE bndr_size ret_frame_size_w `consOL` alt_final0
+
+ -- after dropping the stg_ret_*_info header
+ alt_final2
+ | ubx_tuple_frame = SLIDE 0 3 `consOL` alt_final1
+ | otherwise = SLIDE 0 1 `consOL` alt_final1
+
+ -- when `BRK_FUN` in a case continuation BCO executes,
+ -- the stack will already have a full continuation that just
+ -- re-executes the BCO being stopped at (including the stg_ret and
+ -- stg_ctoi frames)
+ --
+ -- right after the `BRK_FUN`, all case continuations will drop the
+ -- stg_ret and stg_ctoi headers (see alt_final1, alt_final2), leaving
+ -- the stack with the bound return values followed by the free variables
+ alt_final <- case m_bid of
+ Just (Breakpoint tick_ty tick_id fvs)
+ | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)
+ -- Construct an internal breakpoint to put at the start of this case
+ -- continuation BCO.
+ -- See Note [TODO]
+ -> do
+ internal_tick_loc <- makeCaseInternalBreakLoc tick_id
+
+ -- same fvs available in the case expression are available in the case continuation
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Left internal_tick_loc)
+
+ mibi <- newBreakInfo breakInfo
+ return $ case mibi of
+ Nothing -> alt_final2
+ Just ibi -> BRK_FUN ibi `consOL` alt_final2
+ _ -> pure alt_final2
add_bco_name <- shouldAddBcoName
let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO platform add_bco_name alt_bco_name alt_final (Left alts)
0{-no arity-} bitmap_size bitmap True{-is alts-}
- scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
- (d + ret_frame_size_b + save_ccs_size_b)
+ scrut_code <- schemeE (d + wordsToBytes platform ret_frame_size_w + save_ccs_size_b)
+ (d + wordsToBytes platform ret_frame_size_w + save_ccs_size_b)
p scrut
if ubx_tuple_frame
then do let tuple_bco = tupleBCO platform call_info args_offsets
@@ -1351,6 +1382,24 @@ doCase d s p scrut bndr alts
_ -> panic "schemeE(StgCase).push_alts"
in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code)
+makeCaseInternalBreakLoc :: BreakpointId -> BcM InternalBreakLoc
+makeCaseInternalBreakLoc bid = do
+ hug <- hsc_HUG <$> getHscEnv
+ curr_mod <- getCurrentModule
+ mb_mod_brks <- getCurrentModBreaks
+
+ -- TODO: Subtract the scrutinee loc from the case loc to get continuation loc
+ InternalBreakLoc <$> case bid of
+ BreakpointId{bi_tick_mod, bi_tick_index}
+ | bi_tick_mod == curr_mod
+ , Just these_mbs <- mb_mod_brks
+ -> do
+ return $ modBreaks_locs these_mbs ! bi_tick_index
+ | otherwise
+ -> do
+ other_mbs <- liftIO $ readIModModBreaks hug bi_tick_mod
+ return $ modBreaks_locs other_mbs ! bi_tick_index
+
{-
Note [Debugger: BRK_ALTS]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1718,6 +1767,10 @@ tupleBCO platform args_info args =
with using a fake name here. We will need to change this if we want
to save some memory by sharing the BCO between places that have
the same tuple shape
+
+ ROMES:TODO: This seems like it would have a pretty good impact.
+ Looking at examples like UnboxedTuple.hs shows many occurrences of the
+ same tuple_BCO
-}
invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple")
@@ -2667,14 +2720,19 @@ getLabelsBc n = BcM $ \_ st ->
let ctr = nextlabel st
in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n})
-newBreakInfo :: CgBreakInfo -> BcM Int
-newBreakInfo info = BcM $ \_ st ->
- let ix = breakInfoIdx st
- st' = st
- { breakInfo = IntMap.insert ix info (breakInfo st)
- , breakInfoIdx = ix + 1
- }
- in return (ix, st')
+newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId)
+newBreakInfo info = BcM $ \env st -> do
+ -- if we're not generating ModBreaks for this module for some reason, we
+ -- can't store breakpoint occurrence information.
+ case modBreaks env of
+ Nothing -> pure (Nothing, st)
+ Just modBreaks -> do
+ let ix = breakInfoIdx st
+ st' = st
+ { breakInfo = IntMap.insert ix info (breakInfo st)
+ , breakInfoIdx = ix + 1
+ }
+ return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st')
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \env st -> return (bcm_module env, st)
@@ -2687,7 +2745,7 @@ tickFS = fsLit "ticked"
-- Dehydrating CgBreakInfo
-dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> BreakpointId -> CgBreakInfo
+dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo
dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid =
CgBreakInfo
{ cgb_tyvars = map toIfaceTvBndr ty_vars
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -45,7 +45,7 @@ import GHC.Runtime.Eval (mkTopLevEnv)
import GHC.Runtime.Eval.Utils
-- The GHC interface
-import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId)
+import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId, getBreakSourceMod)
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
import GHCi.BreakArray( breakOn, breakOff )
@@ -1621,7 +1621,7 @@ toBreakIdAndLocation (Just inf) = do
brks <- liftIO $ readIModBreaks hug inf
let bi = getBreakSourceId inf brks
return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
- breakId loc == bi ]
+ Right (breakId loc) == bi ]
printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo res names = do
@@ -3825,7 +3825,7 @@ pprStopped res = do
hug <- hsc_HUG <$> GHC.getSession
brks <- liftIO $ readIModBreaks hug ibi
return $ Just $ moduleName $
- bi_tick_mod $ getBreakSourceId ibi brks
+ getBreakSourceMod ibi brks
return $
text "Stopped in"
<+> ((case mb_mod_name of
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -362,6 +362,14 @@ withBreakAction opts breakMVar statusMVar mtid act
info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
+
+ -- Block until this thread is resumed (by the thread which took the
+ -- `ResumeContext` from the `statusMVar`).
+ --
+ -- The `onBreak` function must have been called from `rts/Interpreter.c`
+ -- when interpreting a `BRK_FUN`. After taking from the MVar, the function
+ -- returns to the continuation on the stack which is where the interpreter
+ -- was stopped.
takeMVar breakMVar
resetBreakAction stablePtr = do
=====================================
rts/Interpreter.c
=====================================
@@ -207,6 +207,19 @@ See also Note [Width of parameters] for some more motivation.
// Perhaps confusingly this still reads a full word, merely the offset is in bytes.
#define ReadSpB(n) (*((StgWord*) SafeSpBP(n)))
+/*
+ * SLIDE "n" words "by" words
+ * a_1 ... a_n, b_1 ... b_by, k
+ * =>
+ * a_1 ... a_n, k
+ */
+#define SpSlide(n, by) \
+ while(n-- > 0) { \
+ SpW(n+by) = ReadSpW(n); \
+ } \
+ Sp_addW(by); \
+
+
/* Note [PUSH_L underflow]
~~~~~~~~~~~~~~~~~~~~~~~
BCOs can be nested, resulting in nested BCO stack frames where the inner most
@@ -284,6 +297,18 @@ allocate_NONUPD (Capability *cap, int n_words)
return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
}
+STATIC_INLINE int
+is_ctoi_nontuple_frame(const StgPtr frame_head) {
+ return (
+ (W_)frame_head == (W_)&stg_ctoi_R1p_info ||
+ (W_)frame_head == (W_)&stg_ctoi_R1n_info ||
+ (W_)frame_head == (W_)&stg_ctoi_F1_info ||
+ (W_)frame_head == (W_)&stg_ctoi_D1_info ||
+ (W_)frame_head == (W_)&stg_ctoi_L1_info ||
+ (W_)frame_head == (W_)&stg_ctoi_V_info
+ );
+}
+
int rts_stop_on_exception = 0;
/* ---------------------------------------------------------------------------
@@ -844,7 +869,6 @@ eval_obj:
debugBelch("\n\n");
);
-// IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
IF_DEBUG(sanity,checkStackFrame(Sp));
switch ( get_itbl(obj)->type ) {
@@ -1086,11 +1110,31 @@ do_return_pointer:
// Returning to an interpreted continuation: put the object on
// the stack, and start executing the BCO.
INTERP_TICK(it_retto_BCO);
- Sp_subW(1);
- SpW(0) = (W_)tagged_obj;
- obj = (StgClosure*)ReadSpW(2);
+ obj = (StgClosure*)ReadSpW(1);
ASSERT(get_itbl(obj)->type == BCO);
- goto run_BCO_return_pointer;
+
+ // Heap check
+ if (doYouWantToGC(cap)) {
+ Sp_subW(2);
+ SpW(1) = (W_)tagged_obj;
+ SpW(0) = (W_)&stg_ret_p_info;
+ RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
+ }
+ else {
+
+ // Stack checks aren't necessary at return points, the stack use
+ // is aggregated into the enclosing function entry point.
+
+ // Make sure stack is headed by a ctoi R1p frame when returning a pointer
+ ASSERT(ReadSpW(0) == (W_)&stg_ctoi_R1p_info);
+
+ // Add the return frame on top of the args
+ Sp_subW(2);
+ SpW(1) = (W_)tagged_obj;
+ SpW(0) = (W_)&stg_ret_p_info;
+ }
+
+ goto run_BCO;
default:
do_return_unrecognised:
@@ -1159,8 +1203,9 @@ do_return_nonpointer:
// get the offset of the header of the next stack frame
offset = stack_frame_sizeW((StgClosure *)Sp);
+ StgClosure* next_frame = (StgClosure*)(SafeSpWP(offset));
- switch (get_itbl((StgClosure*)(SafeSpWP(offset)))->type) {
+ switch (get_itbl(next_frame)->type) {
case RET_BCO:
// Returning to an interpreted continuation: pop the return frame
@@ -1168,8 +1213,59 @@ do_return_nonpointer:
// executing the BCO.
INTERP_TICK(it_retto_BCO);
obj = (StgClosure*)ReadSpW(offset+1);
+
ASSERT(get_itbl(obj)->type == BCO);
- goto run_BCO_return_nonpointer;
+
+ // Heap check
+ if (doYouWantToGC(cap)) {
+ RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
+ }
+ else {
+ // Stack checks aren't necessary at return points, the stack use
+ // is aggregated into the enclosing function entry point.
+
+#if defined(PROFILING)
+ /*
+ Restore the current cost centre stack if a tuple is being returned.
+
+ When a "simple" unlifted value is returned, the cccs is restored with
+ an stg_restore_cccs frame on the stack, for example:
+
+ ...
+ stg_ctoi_D1
+ <CCCS>
+ stg_restore_cccs
+
+ But stg_restore_cccs cannot deal with tuples, which may have more
+ things on the stack. Therefore we store the CCCS inside the
+ stg_ctoi_t frame.
+
+ If we have a tuple being returned, the stack looks like this:
+
+ ...
+ <CCCS> <- to restore, Sp offset <next frame + 4 words>
+ tuple_BCO
+ tuple_info
+ cont_BCO
+ stg_ctoi_t <- next frame
+ tuple_data_1
+ ...
+ tuple_data_n
+ tuple_info
+ tuple_BCO
+ stg_ret_t <- Sp
+ */
+
+ if(SpW(0) == (W_)&stg_ret_t_info) {
+ cap->r.rCCCS = (CostCentreStack*)ReadSpW(offset + 4);
+ }
+#endif
+
+ /* Keep the stg_ret_*_info header (i.e. don't drop it)
+ * See Note [The Stack when running a Case Continuation BCO]
+ */
+ goto run_BCO;
+ }
default:
{
@@ -1336,8 +1432,8 @@ do_apply:
// Ok, we now have a bco (obj), and its arguments are all on the
// stack. We can start executing the byte codes.
//
- // The stack is in one of two states. First, if this BCO is a
- // function:
+ // The stack is in one of two states. First, if this BCO is a
+ // function
//
// | .... |
// +---------------+
@@ -1375,68 +1471,6 @@ do_apply:
// Sadly we have three different kinds of stack/heap/cswitch check
// to do:
-
-run_BCO_return_pointer:
- // Heap check
- if (doYouWantToGC(cap)) {
- Sp_subW(1); SpW(0) = (W_)&stg_ret_p_info;
- RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
- }
- // Stack checks aren't necessary at return points, the stack use
- // is aggregated into the enclosing function entry point.
-
- goto run_BCO;
-
-run_BCO_return_nonpointer:
- // Heap check
- if (doYouWantToGC(cap)) {
- RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
- }
- // Stack checks aren't necessary at return points, the stack use
- // is aggregated into the enclosing function entry point.
-
-#if defined(PROFILING)
- /*
- Restore the current cost centre stack if a tuple is being returned.
-
- When a "simple" unlifted value is returned, the cccs is restored with
- an stg_restore_cccs frame on the stack, for example:
-
- ...
- stg_ctoi_D1
- <CCCS>
- stg_restore_cccs
-
- But stg_restore_cccs cannot deal with tuples, which may have more
- things on the stack. Therefore we store the CCCS inside the
- stg_ctoi_t frame.
-
- If we have a tuple being returned, the stack looks like this:
-
- ...
- <CCCS> <- to restore, Sp offset <next frame + 4 words>
- tuple_BCO
- tuple_info
- cont_BCO
- stg_ctoi_t <- next frame
- tuple_data_1
- ...
- tuple_data_n
- tuple_info
- tuple_BCO
- stg_ret_t <- Sp
- */
-
- if(SpW(0) == (W_)&stg_ret_t_info) {
- cap->r.rCCCS = (CostCentreStack*)ReadSpW(stack_frame_sizeW((StgClosure *)Sp) + 4);
- }
-#endif
-
- if (SpW(0) != (W_)&stg_ret_t_info) {
- Sp_addW(1);
- }
- goto run_BCO;
-
run_BCO_fun:
IF_DEBUG(sanity,
Sp_subW(2);
@@ -1519,7 +1553,7 @@ run_BCO:
switch (bci & 0xFF) {
- /* check for a breakpoint on the beginning of a let binding */
+ /* check for a breakpoint on the beginning of a BCO */
case bci_BRK_FUN:
{
W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index;
@@ -1572,6 +1606,20 @@ run_BCO:
{
breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array);
+ W_ stack_head = ReadSpW(0);
+
+ // See Note [Stack layout when entering run_BCO blah]
+ // When the BRK_FUN is at the start of a case continuation BCO,
+ // the stack contains the frame returning the value at the start.
+ int is_case_cont_BCO =
+ stack_head == (W_)&stg_ret_t_info
+ || stack_head == (W_)&stg_ret_v_info
+ || stack_head == (W_)&stg_ret_p_info
+ || stack_head == (W_)&stg_ret_n_info
+ || stack_head == (W_)&stg_ret_f_info
+ || stack_head == (W_)&stg_ret_d_info
+ || stack_head == (W_)&stg_ret_l_info;
+
// 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)[arg4_info_index];
@@ -1580,36 +1628,84 @@ run_BCO:
// decrement and write back ignore count
((StgInt*)breakPoints->payload)[arg4_info_index] = --ignore_count;
}
- else if (stop_next_breakpoint == true || ignore_count == 0)
+ else if (
+ /* Doing step-in (but don't stop at case continuation BCOs,
+ * those are only useful when stepping out) */
+ (stop_next_breakpoint == true && !is_case_cont_BCO)
+ /* Or breakpoint is explicitly enabled */
+ || ignore_count == 0)
{
// make sure we don't automatically stop at the
// next breakpoint
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
- // stg_apply_interp_info pointer and a pointer to
- // the BCO
- size_words = BCO_BITMAP_SIZE(obj) + 2;
- new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
- new_aps->size = size_words;
- new_aps->fun = &stg_dummy_ret_closure;
-
- // fill in the payload of the AP_STACK
- new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
- new_aps->payload[1] = (StgClosure *)obj;
-
- // copy the contents of the top stack frame into the AP_STACK
- for (i = 2; i < size_words; i++)
- {
- new_aps->payload[i] = (StgClosure *)ReadSpW(i-2);
+ // TODO: WRITE NOTE
+ if (is_case_cont_BCO) {
+
+ // TODO: WRITE NOTE
+ // A case cont. BCO is headed by a ret_frame with the returned value
+ // We need the frame here if we are going to yield to construct a well formed stack
+ // Then, just afterwards, we SLIDE the header off. This is generated code (see StgToByteCode)
+ int size_returned_frame =
+ (stack_head == (W_)&stg_ret_t_info)
+ ? 2 /* ret_t + tuple_BCO */
+ + /* Sp(2) is call_info which records the offset to the next frame
+ * See also Note [unboxed tuple bytecodes and tuple_BCO] */
+ ((ReadSpW(2) & 0xFF))
+ : 2; /* ret_* + return value */
+
+ StgPtr cont_frame_head
+ = (StgPtr)(SpW(size_returned_frame));
+ ASSERT(obj == UNTAG_CLOSURE((StgClosure*)ReadSpW(size_returned_frame+1)));
+
+ // stg_ctoi_*
+ int size_cont_frame_head =
+ is_ctoi_nontuple_frame(cont_frame_head)
+ ? 2 // info+bco
+#if defined(PROFILING)
+ : 5; // or info+bco+tuple_info+tuple_BCO+CCS
+#else
+ : 4; // or info+bco+tuple_info+tuple_BCO
+#endif
+
+ // Continuation stack is already well formed,
+ // so just copy it whole to the AP_STACK
+ size_words = size_returned_frame
+ + size_cont_frame_head
+ + BCO_BITMAP_SIZE(obj) /* payload of cont_frame */;
+ new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
+ new_aps->size = size_words;
+ new_aps->fun = &stg_dummy_ret_closure;
+
+ // (1) Fill in the payload of the AP_STACK:
+ for (i = 0; i < size_words; i++) {
+ new_aps->payload[i] = (StgClosure *)ReadSpW(i);
+ }
+ }
+ else {
+ // (1) Allocate memory for a new AP_STACK, enough to store
+ // the top stack frame plus an stg_apply_interp_info pointer
+ // and a pointer to the BCO
+ size_words = BCO_BITMAP_SIZE(obj) + 2;
+ new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
+ new_aps->size = size_words;
+ new_aps->fun = &stg_dummy_ret_closure;
+
+ // (1.1) the continuation frame
+ new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
+ new_aps->payload[1] = (StgClosure *)obj;
+
+ // (1.2.1) copy the args/free vars of the top stack frame into the AP_STACK
+ for (i = 2; i < size_words; i++) {
+ new_aps->payload[i] = (StgClosure *)ReadSpW(i-2);
+ }
}
// No write barrier is needed here as this is a new allocation
SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS);
- // Arrange the stack to call the breakpoint IO action, and
+ // (2) Arrange the stack to call the breakpoint IO action, and
// continue execution of this BCO when the IO action returns.
//
// ioAction :: Addr# -- the breakpoint info module
@@ -1622,12 +1718,27 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(13);
- SpW(12) = (W_)obj;
- SpW(11) = (W_)&stg_apply_interp_info;
+ // (2.1) Construct the continuation to which we'll return in
+ // this thread after the `rts_breakpoint_io_action` returns.
+ //
+ // For case continuation BCOs, the continuation that re-runs
+ // it is always ready at the start of the BCO. It gets
+ // dropped soon after if we don't stop there by SLIDEing.
+ // See Note [TODO]
+ if (!is_case_cont_BCO) {
+ Sp_subW(2); // stg_apply_interp_info + StgBCO*
+
+ // (2.1.2) Write the continuation frame (above the stg_ret
+ // frame if one exists)
+ SpW(1) = (W_)obj;
+ SpW(0) = (W_)&stg_apply_interp_info;
+ }
+
+ // (2.2) The `rts_breakpoint_io_action` call
+ Sp_subW(11);
SpW(10) = (W_)new_aps;
- SpW(9) = (W_)False_closure; // True <=> an exception
- SpW(8) = (W_)&stg_ap_ppv_info;
+ SpW(9) = (W_)False_closure; // True <=> an exception
+ SpW(8) = (W_)&stg_ap_ppv_info;
SpW(7) = (W_)arg4_info_index;
SpW(6) = (W_)&stg_ap_n_info;
SpW(5) = (W_)BCO_LIT(arg3_info_mod_id);
@@ -1981,15 +2092,7 @@ run_BCO:
case bci_SLIDE: {
W_ n = BCO_GET_LARGE_ARG;
W_ by = BCO_GET_LARGE_ARG;
- /*
- * a_1 ... a_n, b_1 ... b_by, k
- * =>
- * a_1 ... a_n, k
- */
- while(n-- > 0) {
- SpW(n+by) = ReadSpW(n);
- }
- Sp_addW(by);
+ SpSlide(n, by);
INTERP_TICK(it_slides);
goto nextInsn;
}
=====================================
testsuite/tests/ghci.debugger/scripts/T26042d2.hs
=====================================
@@ -0,0 +1,13 @@
+
+module Main where
+
+main = do
+ putStrLn "hello1"
+ f
+ putStrLn "hello3"
+ putStrLn "hello4"
+
+f = do
+ putStrLn "hello2.1"
+ putStrLn "hello2.2"
+{-# NOINLINE f #-}
=====================================
testsuite/tests/ghci.debugger/scripts/T26042d2.script
=====================================
@@ -0,0 +1,12 @@
+:load T26042d2.hs
+
+:break 11
+main
+:list
+:stepout
+:list
+:stepout
+
+-- should exit! we compile this test case with -O1 to make sure the monad >> are inlined
+-- and thus the test relies on the filtering behavior based on SrcSpans for stepout
+
=====================================
testsuite/tests/ghci.debugger/scripts/T26042d2.stdout
=====================================
@@ -0,0 +1,16 @@
+Breakpoint 0 activated at T26042d2.hs:11:3-21
+hello1
+Stopped in Main.f, T26042d2.hs:11:3-21
+_result ::
+ GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
+ -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
+ () #) = _
+10 f = do
+11 putStrLn "hello2.1"
+ ^^^^^^^^^^^^^^^^^^^
+12 putStrLn "hello2.2"
+hello2.1
+hello2.2
+<--- should break here too
+hello3
+hello4
=====================================
testsuite/tests/ghci.debugger/scripts/T26042g.stdout
=====================================
@@ -6,10 +6,13 @@ x :: Int = 14
11 succ x = (-) (x - 2) (x + 1)
^^^^^^^^^^^^^^^^^^^
12
-Stopped in T9.top, T26042g.hs:8:10-21
+Stopped in T9., T26042g.hs:(6,3)-(8,21)
_result :: Int = _
+5 top = do
+ vv
+6 case succ 14 of
7 5 -> 5
8 _ -> 6 + other 55
- ^^^^^^^^^^^^
+ ^^
9
171
=====================================
testsuite/tests/ghci.debugger/scripts/all.T
=====================================
@@ -147,8 +147,9 @@ test('T25932', extra_files(['T25932.hs']), ghci_script, ['T25932.script'])
# Step out tests
test('T26042b', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042b.hs'])], ghci_script, ['T26042b.script'])
-test('T26042c', [expect_broken(26042),extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042c.hs'])], ghci_script, ['T26042c.script'])
+test('T26042c', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042c.hs'])], ghci_script, ['T26042c.script'])
test('T26042d', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042d.hs'])], ghci_script, ['T26042d.script'])
+test('T26042d2', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042d2.hs'])], ghci_script, ['T26042d2.script'])
test('T26042e', extra_files(['T26042e.hs']), ghci_script, ['T26042e.script'])
test('T26042f1', extra_files(['T26042f.hs', 'T26042f.script']), ghci_script, ['T26042f.script']) # >> is not inlined, so stepout has nowhere to stop
test('T26042f2', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042f.hs', 'T26042f.script'])], ghci_script, ['T26042f.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/67e50cb9f350969d0c769d76ee6765…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/67e50cb9f350969d0c769d76ee6765…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/remove-deprecated-unstable-heap-representation-details] 2 commits: Remove deprecated functions from the ghci package
by Hannes Siebenhandl (＠fendor) 23 Jul '25
by Hannes Siebenhandl (＠fendor) 23 Jul '25
23 Jul '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-deprecated-unstable-heap-representation-details at Glasgow Haskell Compiler / GHC
Commits:
46f9b063 by fendor at 2025-07-23T18:59:26+02:00
Remove deprecated functions from the ghci package
- - - - -
070008a4 by fendor at 2025-07-23T18:59:26+02:00
base: Remove unstable heap representation details from GHC.Exts
- - - - -
8 changed files:
- libraries/base/src/GHC/Exts.hs
- libraries/ghci/GHCi/CreateBCO.hs
- libraries/ghci/GHCi/TH.hs
- libraries/ghci/ghci.cabal.in
- 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/src/GHC/Exts.hs
=====================================
@@ -26,12 +26,6 @@ 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."] #-}
- 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#,
module GHC.Prim,
module GHC.Prim.Ext,
-- ** Running 'RealWorld' state thread
@@ -131,9 +125,6 @@ import GHC.Prim hiding
, whereFrom#
, isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned#
- -- deprecated
- , BCO, mkApUpd0#, newBCO#
-
-- Don't re-export vector FMA instructions
, fmaddFloatX4#
, fmsubFloatX4#
@@ -256,8 +247,6 @@ import GHC.Prim hiding
, minWord8X32#
, minWord8X64#
)
-import qualified GHC.Prim as Prim
- ( BCO, mkApUpd0#, newBCO# )
import GHC.Prim.Ext
=====================================
libraries/ghci/GHCi/CreateBCO.hs
=====================================
@@ -6,10 +6,6 @@
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
--- TODO We want to import GHC.Internal.Base (BCO, mkApUpd0#, newBCO#) instead
--- of from GHC.Exts when we can require of the bootstrap compiler to have
--- ghc-internal.
--
-- (c) The University of Glasgow 2002-2006
@@ -30,7 +26,8 @@ import Data.Array.Base
import Foreign hiding (newArray)
import Unsafe.Coerce (unsafeCoerce)
import GHC.Arr ( Array(..) )
-import GHC.Exts
+import GHC.Exts hiding ( BCO, mkApUpd0#, newBCO# )
+import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO# )
import GHC.IO
import Control.Exception ( ErrorCall(..) )
=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -1,9 +1,6 @@
{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
TupleSections, RecordWildCards, InstanceSigs, CPP #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
--- TODO We want to import GHC.Internal.Desugar instead of GHC.Desugar when we
--- can require of the bootstrap compiler to have ghc-internal.
-- |
-- Running TH splices
@@ -112,7 +109,7 @@ import Data.IORef
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
-import GHC.Desugar (AnnotationWrapper(..))
+import GHC.Internal.Desugar (AnnotationWrapper(..))
import qualified GHC.Boot.TH.Syntax as TH
import Unsafe.Coerce
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -86,11 +86,7 @@ library
rts,
array == 0.5.*,
base >= 4.8 && < 4.23,
- -- ghc-internal == @ProjectVersionForLib@.*
- -- TODO: Use GHC.Internal.Desugar and GHC.Internal.Base from
- -- ghc-internal instead of ignoring the deprecation warning in GHCi.TH
- -- and GHCi.CreateBCO when we require ghc-internal of the bootstrap
- -- compiler
+ ghc-internal >= 9.1001.0 && <=@ProjectVersionForLib@.0,
ghc-prim >= 0.5.0 && < 0.14,
binary == 0.8.*,
bytestring >= 0.10 && < 0.13,
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -3221,8 +3221,6 @@ module GHC.Base where
{-# MINIMAL pure, ((<*>) | liftA2) #-}
type Array# :: forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType
data Array# a
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -4115,7 +4113,6 @@ module GHC.Base where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
modInt :: Int -> Int -> Int
@@ -4174,7 +4171,6 @@ module GHC.Base where
negateInt8X64# :: Int8X64# -> Int8X64#
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
@@ -5398,8 +5394,6 @@ module GHC.Exts where
data Array# a
type ArrayArray# :: UnliftedType
newtype ArrayArray# = ArrayArray# (Array# ByteArray#)
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -6210,7 +6204,6 @@ module GHC.Exts where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mulIntMayOflo# :: Int# -> Int# -> Int#
@@ -6262,7 +6255,6 @@ module GHC.Exts where
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArrayArray# :: forall s. Int# -> State# s -> (# State# s, MutableArrayArray# s #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -3221,8 +3221,6 @@ module GHC.Base where
{-# MINIMAL pure, ((<*>) | liftA2) #-}
type Array# :: forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType
data Array# a
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -4115,7 +4113,6 @@ module GHC.Base where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
modInt :: Int -> Int -> Int
@@ -4174,7 +4171,6 @@ module GHC.Base where
negateInt8X64# :: Int8X64# -> Int8X64#
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
@@ -5370,8 +5366,6 @@ module GHC.Exts where
data Array# a
type ArrayArray# :: UnliftedType
newtype ArrayArray# = ArrayArray# (Array# ByteArray#)
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -6182,7 +6176,6 @@ module GHC.Exts where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mulIntMayOflo# :: Int# -> Int# -> Int#
@@ -6234,7 +6227,6 @@ module GHC.Exts where
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArrayArray# :: forall s. Int# -> State# s -> (# State# s, MutableArrayArray# s #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -3221,8 +3221,6 @@ module GHC.Base where
{-# MINIMAL pure, ((<*>) | liftA2) #-}
type Array# :: forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType
data Array# a
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -4118,7 +4116,6 @@ module GHC.Base where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
modInt :: Int -> Int -> Int
@@ -4177,7 +4174,6 @@ module GHC.Base where
negateInt8X64# :: Int8X64# -> Int8X64#
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
@@ -5538,8 +5534,6 @@ module GHC.Exts where
data Array# a
type ArrayArray# :: UnliftedType
newtype ArrayArray# = ArrayArray# (Array# ByteArray#)
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -6353,7 +6347,6 @@ module GHC.Exts where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mulIntMayOflo# :: Int# -> Int# -> Int#
@@ -6405,7 +6398,6 @@ module GHC.Exts where
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArrayArray# :: forall s. Int# -> State# s -> (# State# s, MutableArrayArray# s #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -3221,8 +3221,6 @@ module GHC.Base where
{-# MINIMAL pure, ((<*>) | liftA2) #-}
type Array# :: forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType
data Array# a
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -4115,7 +4113,6 @@ module GHC.Base where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
modInt :: Int -> Int -> Int
@@ -4174,7 +4171,6 @@ module GHC.Base where
negateInt8X64# :: Int8X64# -> Int8X64#
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
@@ -5398,8 +5394,6 @@ module GHC.Exts where
data Array# a
type ArrayArray# :: UnliftedType
newtype ArrayArray# = ArrayArray# (Array# ByteArray#)
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -6210,7 +6204,6 @@ module GHC.Exts where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mulIntMayOflo# :: Int# -> Int# -> Int#
@@ -6262,7 +6255,6 @@ module GHC.Exts where
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArrayArray# :: forall s. Int# -> State# s -> (# State# s, MutableArrayArray# s #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b4788c6dcb8801126f0ad4b2ce864…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b4788c6dcb8801126f0ad4b2ce864…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 4 commits: Move stack decoding logic from ghc-heap to ghc-internal
by Hannes Siebenhandl (＠fendor) 23 Jul '25
by Hannes Siebenhandl (＠fendor) 23 Jul '25
23 Jul '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC
Commits:
a678e230 by fendor at 2025-07-23T18:45:43+02:00
Move stack decoding logic from ghc-heap to ghc-internal
The stack decoding logic in `ghc-heap` is more sophisticated than the one
currently employed in `CloneStack`. We want to use the stack decoding
implementation from `ghc-heap` in `base`.
We cannot simply depend on `ghc-heap` in `base` due do bootstrapping
issues.
Thus, we move the code that is necessary to implement stack decoding to
`ghc-internal`. This is the right location, as we don't want to add a
new API to `base`.
Moving the stack decoding logic and re-exposing it in ghc-heap is
insufficient, though, as we have a dependency cycle between.
* ghc-heap depends on stage1:ghc-internal
* stage0:ghc depends on stage0:ghc-heap
To fix this, we remove ghc-heap from the set of `stage0` dependencies.
This is not entirely straight-forward, as a couple of boot dependencies,
such as `ghci` depend on `ghc-heap`.
Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci`
to use `ghc-internal` instead of `ghc-heap`, which already exports the
relevant modules.
However, we cannot 100% remove ghc's dependency on `ghc-heap`, since
when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet
available.
Thus, when we compile with the boot-compiler, we still depend on an
older version of `ghc-heap`, and only use the modules from `ghc-internal`,
if the `ghc-internal` version is recent enough.
- - - - -
b9d5f2ae by fendor at 2025-07-23T18:45:43+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
e15f7ba1 by fendor at 2025-07-23T18:45:43+02:00
Remove stg_decodeStackzh
- - - - -
ea120a65 by fendor at 2025-07-23T18:45:43+02:00
Remove deprecated functions from the ghci package
- - - - -
40 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/ghc.cabal.in
- hadrian/src/Settings/Default.hs
- libraries/base/src/GHC/Stack/CloneStack.hs
- + libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/cbits/HeapPrim.cmm → libraries/ghc-internal/cbits/HeapPrim.cmm
- libraries/ghc-heap/cbits/Stack.cmm → libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/cbits/Stack_c.c → libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- + libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghci/GHCi/CreateBCO.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/ghci/ghci.cabal.in
- rts/CloneStack.c
- rts/CloneStack.h
- rts/RtsSymbols.c
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e1e3965451b55b1cd1f046818eb3f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e1e3965451b55b1cd1f046818eb3f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/step-out-11] Allow BRK_FUNs at the start of case continuation BCOs
by Rodrigo Mesquita (＠alt-romes) 23 Jul '25
by Rodrigo Mesquita (＠alt-romes) 23 Jul '25
23 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-11 at Glasgow Haskell Compiler / GHC
Commits:
67e50cb9 by Rodrigo Mesquita at 2025-07-23T17:42:40+01:00
Allow BRK_FUNs at the start of case continuation BCOs
...and insert BRK_FUNS for case continuations: TODO: SPLIT THE TICK
PARTS OUT
Working on making BRK_FUNs for case cont. BCO
Remove bad
Beautiful
Fix...
More right-trackking
TODO: Test step-out from a continuation which receives an unboxed tuple as an argument
Fix again
Beautiful again
Almost there
- - - - -
10 changed files:
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- ghc/GHCi/UI.hs
- libraries/ghci/GHCi/Run.hs
- rts/Interpreter.c
- testsuite/tests/ghci.debugger/scripts/T26042g.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
Changes:
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DerivingStrategies #-}
-- | Breakpoint information constructed during ByteCode generation.
--
@@ -15,6 +16,7 @@ module GHC.ByteCode.Breakpoints
-- ** Internal breakpoint identifier
, InternalBreakpointId(..), BreakInfoIndex
+ , InternalBreakLoc(..)
-- * Operations
@@ -23,7 +25,7 @@ module GHC.ByteCode.Breakpoints
-- ** Source-level information operations
, getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS
- , getBreakSourceId
+ , getBreakSourceId, getBreakSourceMod
-- * Utils
, seqInternalModBreaks
@@ -165,7 +167,7 @@ data CgBreakInfo
{ cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
, cgb_vars :: ![Maybe (IfaceIdBndr, Word)]
, cgb_resty :: !IfaceType
- , cgb_tick_id :: !BreakpointId
+ , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId)
-- ^ This field records the original breakpoint tick identifier for this
-- internal breakpoint info. It is used to convert a breakpoint
-- *occurrence* index ('InternalBreakpointId') into a *definition* index
@@ -173,9 +175,19 @@ data CgBreakInfo
--
-- The modules of breakpoint occurrence and breakpoint definition are not
-- necessarily the same: See Note [Breakpoint identifiers].
+ --
+ -- If there is no original tick identifier (that is, the breakpoint was
+ -- created during code generation), instead refer directly to the SrcSpan
+ -- we want to use for it. See Note [Internal Breakpoint Locations]
}
-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
+-- | Breakpoints created during code generation don't have a source-level tick
+-- location. Instead, we come up with one ourselves.
+-- See Note [Internal Breakpoint Locations]
+newtype InternalBreakLoc = InternalBreakLoc SrcSpan
+ deriving newtype (Eq, Show, NFData, Outputable)
+
-- | Get an internal breakpoint info by 'InternalBreakpointId'
getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo
getInternalBreak (InternalBreakpointId mod ix) imbs =
@@ -196,27 +208,36 @@ assert_modules_match ibi_mod imbs_mod =
-- | Get the source module and tick index for this breakpoint
-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId')
-getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId
+getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> Either InternalBreakLoc BreakpointId
getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs =
assert_modules_match ibi_mod (imodBreaks_module imbs) $
let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
in cgb_tick_id cgb
+-- | Get the source module for this breakpoint (where the breakpoint is defined)
+getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module
+getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs =
+ assert_modules_match ibi_mod (imodBreaks_module imbs) $
+ let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
+ in case cgb_tick_id cgb of
+ Left InternalBreakLoc{} -> imodBreaks_module imbs
+ Right BreakpointId{bi_tick_mod} -> bi_tick_mod
+
-- | Get the source span for this breakpoint
getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan
-getBreakLoc = getBreakXXX modBreaks_locs
+getBreakLoc = getBreakXXX modBreaks_locs (\(InternalBreakLoc x) -> x)
-- | Get the vars for this breakpoint
getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName]
-getBreakVars = getBreakXXX modBreaks_vars
+getBreakVars = getBreakXXX modBreaks_vars (const [])
-- | Get the decls for this breakpoint
getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
-getBreakDecls = getBreakXXX modBreaks_decls
+getBreakDecls = getBreakXXX modBreaks_decls (const [])
-- | Get the decls for this breakpoint
-getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (String, String)
-getBreakCCS = getBreakXXX modBreaks_ccs
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (Maybe (String, String))
+getBreakCCS = getBreakXXX (fmap Just . modBreaks_ccs) (const Nothing)
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
--
@@ -228,14 +249,17 @@ getBreakCCS = getBreakXXX modBreaks_ccs
-- 'ModBreaks'. When the tick module is different, we need to look up the
-- 'ModBreaks' in the HUG for that other module.
--
+-- When there is no tick module (the breakpoint was generated at codegen), use
+-- the function on internal mod breaks.
+--
-- To avoid cyclic dependencies, we instead receive a function that looks up
-- the 'ModBreaks' given a 'Module'
-getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
-getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (InternalBreakLoc -> a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a
+getBreakXXX view viewInternal lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
assert_modules_match ibi_mod (imodBreaks_module imbs) $ do
let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix
case cgb_tick_id cgb of
- BreakpointId{bi_tick_mod, bi_tick_index}
+ Right BreakpointId{bi_tick_mod, bi_tick_index}
| bi_tick_mod == ibi_mod
-> do
let these_mbs = imodBreaks_modBreaks imbs
@@ -244,6 +268,8 @@ getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =
-> do
other_mbs <- lookupModule bi_tick_mod
return $ view other_mbs ! bi_tick_index
+ Left l ->
+ return $ viewInternal l
--------------------------------------------------------------------------------
-- Instances
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -58,6 +58,7 @@ import GHCi.RemoteTypes
import GHC.Iface.Load
import GHCi.Message (ConInfoTable(..), LoadedDLL)
+import GHC.ByteCode.Breakpoints
import GHC.ByteCode.Linker
import GHC.ByteCode.Asm
import GHC.ByteCode.Types
@@ -1711,8 +1712,10 @@ allocateCCS interp ce mbss
let count = 1 + (maybe 0 fst $ IM.lookupMax imodBreaks_breakInfo)
let ccs = IM.map
(\info ->
- fromMaybe (toRemotePtr nullPtr)
- (M.lookup (cgb_tick_id info) ccss)
+ case cgb_tick_id info of
+ Right bi -> fromMaybe (toRemotePtr nullPtr)
+ (M.lookup bi ccss)
+ Left InternalBreakLoc{} -> toRemotePtr nullPtr
)
imodBreaks_breakInfo
assertPpr (count == length ccs)
=====================================
compiler/GHC/Runtime/Debugger/Breakpoints.hs
=====================================
@@ -253,8 +253,11 @@ mkBreakpointOccurrences = do
let imod = modBreaks_module $ imodBreaks_modBreaks ibrks
IntMap.foldrWithKey (\info_ix cgi bmp -> do
let ibi = InternalBreakpointId imod info_ix
- let BreakpointId tick_mod tick_ix = cgb_tick_id cgi
- extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
+ case cgb_tick_id cgi of
+ Right (BreakpointId tick_mod tick_ix)
+ -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])
+ Left _
+ -> bmp
) bmp0 (imodBreaks_breakInfo ibrks)
--------------------------------------------------------------------------------
@@ -287,7 +290,7 @@ getCurrentBreakModule = do
Nothing -> pure Nothing
Just ibi -> do
brks <- readIModBreaks hug ibi
- return $ Just $ bi_tick_mod $ getBreakSourceId ibi brks
+ return $ Just $ getBreakSourceMod ibi brks
ix ->
Just <$> getHistoryModule hug (resumeHistory r !! (ix-1))
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -151,7 +151,7 @@ getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module
getHistoryModule hug hist = do
let ibi = historyBreakpointId hist
brks <- readIModBreaks hug ibi
- return $ bi_tick_mod $ getBreakSourceId ibi brks
+ return $ getBreakSourceMod ibi brks
getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan
getHistorySpan hug hist = do
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -63,7 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
assertNonVoidIds, assertNonVoidStgArgs )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
-import GHC.Runtime.Interpreter ( interpreterProfiled )
+import GHC.Runtime.Interpreter ( interpreterProfiled, readIModModBreaks )
import GHC.Data.Bitmap
import GHC.Data.FlatBag as FlatBag
import GHC.Data.OrdList
@@ -99,6 +99,7 @@ import GHC.CoreToIface
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State (StateT(..))
+import Data.Array ((!))
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -393,26 +394,30 @@ schemeR_wrk fvs nm original_body (args, body)
-- | Introduce break instructions for ticked expressions.
-- If no breakpoint information is available, the instruction is omitted.
schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
-schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_id fvs) rhs) = do
- code <- schemeE d 0 p rhs
- mb_current_mod_breaks <- getCurrentModBreaks
- case mb_current_mod_breaks of
- -- if we're not generating ModBreaks for this module for some reason, we
- -- can't store breakpoint occurrence information.
- Nothing -> pure code
- Just current_mod_breaks -> do
- platform <- profilePlatform <$> getProfile
- let idOffSets = getVarOffSets platform d p fvs
- ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
- toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
- toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
- breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty tick_id
-
- let info_mod = modBreaks_module current_mod_breaks
- infox <- newBreakInfo breakInfo
+schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do
+ platform <- profilePlatform <$> getProfile
+
+ code <- case rhs of
+ -- When we find a tick surrounding a case expression we introduce a new BRK_FUN
+ -- instruction at the start of the case *continuation*, in addition to the
+ -- usual BRK_FUN surrounding the StgCase)
+ -- See Note [TODO]
+ StgCase scrut bndr _ alts
+ -> doCase d 0 p (Just bp) scrut bndr alts
+ _ -> schemeE d 0 p rhs
+
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Right tick_id)
+
+ mibi <- newBreakInfo breakInfo
+
+ return $ case mibi of
+ Nothing -> code
+ Just ibi -> BRK_FUN ibi `consOL` code
- let breakInstr = BRK_FUN (InternalBreakpointId info_mod infox)
- return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
@@ -614,7 +619,7 @@ schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
schemeE d s p (StgCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts
+ = doCase d s p Nothing scrut bndr alts
{-
@@ -1106,11 +1111,15 @@ doCase
:: StackDepth
-> Sequel
-> BCEnv
+ -> Maybe StgTickish
+ -- ^ The breakpoint surrounding the full case expression, if any (only
+ -- source-level cases get breakpoint ticks, and those are the only we care
+ -- about). See Note [TODO]
-> CgStgExpr
-> Id
-> [CgStgAlt]
-> BcM BCInstrList
-doCase d s p scrut bndr alts
+doCase d s p m_bid scrut bndr alts
= do
profile <- getProfile
hsc_env <- getHscEnv
@@ -1325,19 +1334,35 @@ doCase d s p scrut bndr alts
| ubx_tuple_frame = SLIDE 0 3 `consOL` alt_final1
| otherwise = SLIDE 0 1 `consOL` alt_final1
- -- when `BRK_FUN` in a case continuation BCO executes,
- -- the stack will already have a full continuation that just
- -- re-executes the BCO being stopped at (including the stg_ret and
- -- stg_ctoi frames)
- --
- -- right after the `BRK_FUN`, all case continuations will drop the
- -- stg_ret and stg_ctoi headers (see alt_final1, alt_final2), leaving
- -- the stack with the bound return values followed by the free variables
- alt_final
- | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)
- -- See Note [Debugger: BRK_ALTS]
- = BRK_ALTS False `consOL` alt_final2
- | otherwise = alt_final2
+ -- when `BRK_FUN` in a case continuation BCO executes,
+ -- the stack will already have a full continuation that just
+ -- re-executes the BCO being stopped at (including the stg_ret and
+ -- stg_ctoi frames)
+ --
+ -- right after the `BRK_FUN`, all case continuations will drop the
+ -- stg_ret and stg_ctoi headers (see alt_final1, alt_final2), leaving
+ -- the stack with the bound return values followed by the free variables
+ alt_final <- case m_bid of
+ Just (Breakpoint tick_ty tick_id fvs)
+ | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)
+ -- Construct an internal breakpoint to put at the start of this case
+ -- continuation BCO.
+ -- See Note [TODO]
+ -> do
+ internal_tick_loc <- makeCaseInternalBreakLoc tick_id
+
+ -- same fvs available in the case expression are available in the case continuation
+ let idOffSets = getVarOffSets platform d p fvs
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
+ toWord = fmap (\(i, wo) -> (i, fromIntegral wo))
+ breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Left internal_tick_loc)
+
+ mibi <- newBreakInfo breakInfo
+ return $ case mibi of
+ Nothing -> alt_final2
+ Just ibi -> BRK_FUN ibi `consOL` alt_final2
+ _ -> pure alt_final2
add_bco_name <- shouldAddBcoName
let
@@ -1357,6 +1382,24 @@ doCase d s p scrut bndr alts
_ -> panic "schemeE(StgCase).push_alts"
in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code)
+makeCaseInternalBreakLoc :: BreakpointId -> BcM InternalBreakLoc
+makeCaseInternalBreakLoc bid = do
+ hug <- hsc_HUG <$> getHscEnv
+ curr_mod <- getCurrentModule
+ mb_mod_brks <- getCurrentModBreaks
+
+ -- TODO: Subtract the scrutinee loc from the case loc to get continuation loc
+ InternalBreakLoc <$> case bid of
+ BreakpointId{bi_tick_mod, bi_tick_index}
+ | bi_tick_mod == curr_mod
+ , Just these_mbs <- mb_mod_brks
+ -> do
+ return $ modBreaks_locs these_mbs ! bi_tick_index
+ | otherwise
+ -> do
+ other_mbs <- liftIO $ readIModModBreaks hug bi_tick_mod
+ return $ modBreaks_locs other_mbs ! bi_tick_index
+
{-
Note [Debugger: BRK_ALTS]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2677,14 +2720,19 @@ getLabelsBc n = BcM $ \_ st ->
let ctr = nextlabel st
in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n})
-newBreakInfo :: CgBreakInfo -> BcM Int
-newBreakInfo info = BcM $ \_ st ->
- let ix = breakInfoIdx st
- st' = st
- { breakInfo = IntMap.insert ix info (breakInfo st)
- , breakInfoIdx = ix + 1
- }
- in return (ix, st')
+newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId)
+newBreakInfo info = BcM $ \env st -> do
+ -- if we're not generating ModBreaks for this module for some reason, we
+ -- can't store breakpoint occurrence information.
+ case modBreaks env of
+ Nothing -> pure (Nothing, st)
+ Just modBreaks -> do
+ let ix = breakInfoIdx st
+ st' = st
+ { breakInfo = IntMap.insert ix info (breakInfo st)
+ , breakInfoIdx = ix + 1
+ }
+ return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st')
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \env st -> return (bcm_module env, st)
@@ -2697,7 +2745,7 @@ tickFS = fsLit "ticked"
-- Dehydrating CgBreakInfo
-dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> BreakpointId -> CgBreakInfo
+dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo
dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid =
CgBreakInfo
{ cgb_tyvars = map toIfaceTvBndr ty_vars
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -45,7 +45,7 @@ import GHC.Runtime.Eval (mkTopLevEnv)
import GHC.Runtime.Eval.Utils
-- The GHC interface
-import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId)
+import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId, getBreakSourceMod)
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
import GHCi.BreakArray( breakOn, breakOff )
@@ -1621,7 +1621,7 @@ toBreakIdAndLocation (Just inf) = do
brks <- liftIO $ readIModBreaks hug inf
let bi = getBreakSourceId inf brks
return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
- breakId loc == bi ]
+ Right (breakId loc) == bi ]
printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo res names = do
@@ -3825,7 +3825,7 @@ pprStopped res = do
hug <- hsc_HUG <$> GHC.getSession
brks <- liftIO $ readIModBreaks hug ibi
return $ Just $ moduleName $
- bi_tick_mod $ getBreakSourceId ibi brks
+ getBreakSourceMod ibi brks
return $
text "Stopped in"
<+> ((case mb_mod_name of
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -362,6 +362,14 @@ withBreakAction opts breakMVar statusMVar mtid act
info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
+
+ -- Block until this thread is resumed (by the thread which took the
+ -- `ResumeContext` from the `statusMVar`).
+ --
+ -- The `onBreak` function must have been called from `rts/Interpreter.c`
+ -- when interpreting a `BRK_FUN`. After taking from the MVar, the function
+ -- returns to the continuation on the stack which is where the interpreter
+ -- was stopped.
takeMVar breakMVar
resetBreakAction stablePtr = do
=====================================
rts/Interpreter.c
=====================================
@@ -297,18 +297,17 @@ allocate_NONUPD (Capability *cap, int n_words)
return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
}
-// STATIC_INLINE int
-// is_ctoi_nontuple_frame(const StgClosure* frame) {
-// const StgInfoTable* info = frame->header.info;
-// return (
-// (W_)info == (W_)&stg_ctoi_R1p_info ||
-// (W_)info == (W_)&stg_ctoi_R1n_info ||
-// (W_)info == (W_)&stg_ctoi_F1_info ||
-// (W_)info == (W_)&stg_ctoi_D1_info ||
-// (W_)info == (W_)&stg_ctoi_L1_info ||
-// (W_)info == (W_)&stg_ctoi_V_info
-// );
-// }
+STATIC_INLINE int
+is_ctoi_nontuple_frame(const StgPtr frame_head) {
+ return (
+ (W_)frame_head == (W_)&stg_ctoi_R1p_info ||
+ (W_)frame_head == (W_)&stg_ctoi_R1n_info ||
+ (W_)frame_head == (W_)&stg_ctoi_F1_info ||
+ (W_)frame_head == (W_)&stg_ctoi_D1_info ||
+ (W_)frame_head == (W_)&stg_ctoi_L1_info ||
+ (W_)frame_head == (W_)&stg_ctoi_V_info
+ );
+}
int rts_stop_on_exception = 0;
@@ -1264,7 +1263,7 @@ do_return_nonpointer:
*/
if(SpW(0) == (W_)&stg_ret_t_info) {
- cap->r.rCCCS = (CostCentreStack*)ReadSpW(stack_frame_sizeW((StgClosure *)Sp) + 4);
+ cap->r.rCCCS = (CostCentreStack*)ReadSpW(offset + 4);
}
#endif
/* Drop the RET_BCO header (next_frame),
@@ -1571,7 +1570,7 @@ run_BCO:
switch (bci & 0xFF) {
- /* check for a breakpoint on the beginning of a let binding */
+ /* check for a breakpoint on the beginning of a BCO */
case bci_BRK_FUN:
{
W_ arg1_brk_array, arg2_info_mod_name, arg3_info_mod_id, arg4_info_index;
@@ -1624,6 +1623,20 @@ run_BCO:
{
breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array);
+ W_ stack_head = ReadSpW(0);
+
+ // See Note [Stack layout when entering run_BCO blah]
+ // When the BRK_FUN is at the start of a case continuation BCO,
+ // the stack contains the frame returning the value at the start.
+ int is_case_cont_BCO =
+ stack_head == (W_)&stg_ret_t_info
+ || stack_head == (W_)&stg_ret_v_info
+ || stack_head == (W_)&stg_ret_p_info
+ || stack_head == (W_)&stg_ret_n_info
+ || stack_head == (W_)&stg_ret_f_info
+ || stack_head == (W_)&stg_ret_d_info
+ || stack_head == (W_)&stg_ret_l_info;
+
// 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)[arg4_info_index];
@@ -1632,36 +1645,83 @@ run_BCO:
// decrement and write back ignore count
((StgInt*)breakPoints->payload)[arg4_info_index] = --ignore_count;
}
- else if (stop_next_breakpoint == true || ignore_count == 0)
+ else if (
+ /* Doing :step (but don't stop at case continuation BCOs) */
+ (stop_next_breakpoint == true && !is_case_cont_BCO)
+ /* Or breakpoint is explicitly enabled */
+ || ignore_count == 0)
{
// make sure we don't automatically stop at the
// next breakpoint
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
- // stg_apply_interp_info pointer and a pointer to
- // the BCO
- size_words = BCO_BITMAP_SIZE(obj) + 2;
- new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
- new_aps->size = size_words;
- new_aps->fun = &stg_dummy_ret_closure;
-
- // fill in the payload of the AP_STACK
- new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
- new_aps->payload[1] = (StgClosure *)obj;
-
- // copy the contents of the top stack frame into the AP_STACK
- for (i = 2; i < size_words; i++)
- {
- new_aps->payload[i] = (StgClosure *)ReadSpW(i-2);
+ // TODO: WRITE NOTE
+ if (is_case_cont_BCO) {
+
+ // TODO: WRITE NOTE
+ // A case cont. BCO is headed by a ret_frame with the returned value
+ // We need the frame here if we are going to yield to construct a well formed stack
+ // Then, just afterwards, we SLIDE the header off. This is generated code (see StgToByteCode)
+ int size_returned_frame =
+ (stack_head == (W_)&stg_ret_t_info)
+ ? 2 /* ret_t + tuple_BCO */
+ + /* Sp(2) is call_info which records the offset to the next frame
+ * See also Note [unboxed tuple bytecodes and tuple_BCO] */
+ ((ReadSpW(2) & 0xFF))
+ : 2; /* ret_* + return value */
+
+ StgPtr cont_frame_head
+ = (StgPtr)(SpW(size_returned_frame));
+ ASSERT(obj == UNTAG_CLOSURE((StgClosure*)ReadSpW(size_returned_frame+1)));
+
+ // stg_ctoi_*
+ int size_cont_frame_head =
+ is_ctoi_nontuple_frame(cont_frame_head)
+ ? 2 // info+bco
+#if defined(PROFILING)
+ : 5; // or info+bco+tuple_info+tuple_BCO+CCS
+#else
+ : 4; // or info+bco+tuple_info+tuple_BCO
+#endif
+
+ // Continuation stack is already well formed,
+ // so just copy it whole to the AP_STACK
+ size_words = size_returned_frame
+ + size_cont_frame_head
+ + BCO_BITMAP_SIZE(obj) /* payload of cont_frame */;
+ new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
+ new_aps->size = size_words;
+ new_aps->fun = &stg_dummy_ret_closure;
+
+ // (1) Fill in the payload of the AP_STACK:
+ for (i = 0; i < size_words; i++) {
+ new_aps->payload[i] = (StgClosure *)ReadSpW(i);
+ }
+ }
+ else {
+ // (1) Allocate memory for a new AP_STACK, enough to store
+ // the top stack frame plus an stg_apply_interp_info pointer
+ // and a pointer to the BCO
+ size_words = BCO_BITMAP_SIZE(obj) + 2;
+ new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
+ new_aps->size = size_words;
+ new_aps->fun = &stg_dummy_ret_closure;
+
+ // (1.1) the continuation frame
+ new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
+ new_aps->payload[1] = (StgClosure *)obj;
+
+ // (1.2.1) copy the args/free vars of the top stack frame into the AP_STACK
+ for (i = 2; i < size_words; i++) {
+ new_aps->payload[i] = (StgClosure *)ReadSpW(i-2);
+ }
}
// No write barrier is needed here as this is a new allocation
SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS);
- // Arrange the stack to call the breakpoint IO action, and
+ // (2) Arrange the stack to call the breakpoint IO action, and
// continue execution of this BCO when the IO action returns.
//
// ioAction :: Addr# -- the breakpoint info module
@@ -1674,12 +1734,27 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(13);
- SpW(12) = (W_)obj;
- SpW(11) = (W_)&stg_apply_interp_info;
+ // (2.1) Construct the continuation to which we'll return in
+ // this thread after the `rts_breakpoint_io_action` returns.
+ //
+ // For case continuation BCOs, the continuation that re-runs
+ // it is always ready at the start of the BCO. It gets
+ // dropped soon after if we don't stop there by SLIDEing.
+ // See Note [TODO]
+ if (!is_case_cont_BCO) {
+ Sp_subW(2); // stg_apply_interp_info + StgBCO*
+
+ // (2.1.2) Write the continuation frame (above the stg_ret
+ // frame if one exists)
+ SpW(1) = (W_)obj;
+ SpW(0) = (W_)&stg_apply_interp_info;
+ }
+
+ // (2.2) The `rts_breakpoint_io_action` call
+ Sp_subW(11);
SpW(10) = (W_)new_aps;
- SpW(9) = (W_)False_closure; // True <=> an exception
- SpW(8) = (W_)&stg_ap_ppv_info;
+ SpW(9) = (W_)False_closure; // True <=> an exception
+ SpW(8) = (W_)&stg_ap_ppv_info;
SpW(7) = (W_)arg4_info_index;
SpW(6) = (W_)&stg_ap_n_info;
SpW(5) = (W_)BCO_LIT(arg3_info_mod_id);
=====================================
testsuite/tests/ghci.debugger/scripts/T26042g.stdout
=====================================
@@ -6,10 +6,13 @@ x :: Int = 14
11 succ x = (-) (x - 2) (x + 1)
^^^^^^^^^^^^^^^^^^^
12
-Stopped in T9.top, T26042g.hs:8:10-21
+Stopped in T9., T26042g.hs:(6,3)-(8,21)
_result :: Int = _
+5 top = do
+ vv
+6 case succ 14 of
7 5 -> 5
8 _ -> 6 + other 55
- ^^^^^^^^^^^^
+ ^^
9
171
=====================================
testsuite/tests/ghci.debugger/scripts/all.T
=====================================
@@ -147,7 +147,7 @@ test('T25932', extra_files(['T25932.hs']), ghci_script, ['T25932.script'])
# Step out tests
test('T26042b', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042b.hs'])], ghci_script, ['T26042b.script'])
-test('T26042c', [expect_broken(26042),extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042c.hs'])], ghci_script, ['T26042c.script'])
+test('T26042c', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042c.hs'])], ghci_script, ['T26042c.script'])
test('T26042d', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042d.hs'])], ghci_script, ['T26042d.script'])
test('T26042e', extra_files(['T26042e.hs']), ghci_script, ['T26042e.script'])
test('T26042f1', extra_files(['T26042f.hs', 'T26042f.script']), ghci_script, ['T26042f.script']) # >> is not inlined, so stepout has nowhere to stop
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67e50cb9f350969d0c769d76ee6765f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67e50cb9f350969d0c769d76ee6765f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ann-frame] Add primop to annotate the call stack with arbitrary data
by Hannes Siebenhandl (＠fendor) 23 Jul '25
by Hannes Siebenhandl (＠fendor) 23 Jul '25
23 Jul '25
Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC
Commits:
fa64fa3e by Ben Gamari at 2025-07-23T18:40:42+02:00
Add primop to annotate the call stack with arbitrary data
We introduce a new primop `annotateStack#` which allows us to push
arbitrary data onto the call-stack.
This allows us to extract the data later when decoding the stack, for
example when an exception is thrown, showing more information to the
user without having to annotate the full call-stack with `HasCallStack`
constraints.
A new stack frame value is introduced `AnnFrame`, which consists of
nothing but a generic payload.
The primop has a small wrapper API that allows users to annotate their
call-stack in programs.
There is a pure API and an IO-based one. The former is a little bit
dubious, as it affects the evaluation of a program, so use with care.
The latter is "safe", as it doesn't change the evaluation of the
program.
The stack annotation mechanism is similarly implemented to the
`ExceptionAnnotation` and `Exception`, there is a typeclass to indicate
something can be pushed onto the call-stack and all values are wrapped
in the existential `SomeStackAnnotation`, which recover the type of the
annotation payload.
There is currently no builtin way to show the stack annotations when
`Backtraces` are displayed (i.e., when showing stack traces to the user),
which we will address in a follow-up MR.
- - - - -
45 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Stack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- + libraries/ghc-heap/tests/stack-annotation/Makefile
- + libraries/ghc-heap/tests/stack-annotation/TestUtils.hs
- + libraries/ghc-heap/tests/stack-annotation/all.T
- + libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout
- + libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout
- + libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout
- + libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout
- libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs
- rts/ClosureFlags.c
- rts/LdvProfile.c
- rts/PrimOps.cmm
- rts/Printer.c
- rts/RetainerProfile.c
- rts/TraverseHeap.c
- rts/include/rts/storage/ClosureTypes.h
- rts/include/rts/storage/Closures.h
- rts/js/profiling.js
- rts/sm/Compact.c
- rts/sm/Evac.c
- rts/sm/NonMovingMark.c
- rts/sm/Sanity.c
- rts/sm/Scav.c
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- utils/deriveConstants/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa64fa3ebae3cea55798c29fded3ba1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa64fa3ebae3cea55798c29fded3ba1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/remove-deprecated-unstable-heap-representation-details] base: Remove unstable heap representation details from GHC.Exts
by Hannes Siebenhandl (＠fendor) 23 Jul '25
by Hannes Siebenhandl (＠fendor) 23 Jul '25
23 Jul '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-deprecated-unstable-heap-representation-details at Glasgow Haskell Compiler / GHC
Commits:
7b4788c6 by fendor at 2025-07-23T18:21:57+02:00
base: Remove unstable heap representation details from GHC.Exts
- - - - -
5 changed files:
- libraries/base/src/GHC/Exts.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/src/GHC/Exts.hs
=====================================
@@ -26,12 +26,6 @@ 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."] #-}
- 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#,
module GHC.Prim,
module GHC.Prim.Ext,
-- ** Running 'RealWorld' state thread
@@ -131,9 +125,6 @@ import GHC.Prim hiding
, whereFrom#
, isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned#
- -- deprecated
- , BCO, mkApUpd0#, newBCO#
-
-- Don't re-export vector FMA instructions
, fmaddFloatX4#
, fmsubFloatX4#
@@ -256,8 +247,6 @@ import GHC.Prim hiding
, minWord8X32#
, minWord8X64#
)
-import qualified GHC.Prim as Prim
- ( BCO, mkApUpd0#, newBCO# )
import GHC.Prim.Ext
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -3221,8 +3221,6 @@ module GHC.Base where
{-# MINIMAL pure, ((<*>) | liftA2) #-}
type Array# :: forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType
data Array# a
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -4115,7 +4113,6 @@ module GHC.Base where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
modInt :: Int -> Int -> Int
@@ -4174,7 +4171,6 @@ module GHC.Base where
negateInt8X64# :: Int8X64# -> Int8X64#
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
@@ -5398,8 +5394,6 @@ module GHC.Exts where
data Array# a
type ArrayArray# :: UnliftedType
newtype ArrayArray# = ArrayArray# (Array# ByteArray#)
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -6210,7 +6204,6 @@ module GHC.Exts where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mulIntMayOflo# :: Int# -> Int# -> Int#
@@ -6262,7 +6255,6 @@ module GHC.Exts where
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArrayArray# :: forall s. Int# -> State# s -> (# State# s, MutableArrayArray# s #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -3221,8 +3221,6 @@ module GHC.Base where
{-# MINIMAL pure, ((<*>) | liftA2) #-}
type Array# :: forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType
data Array# a
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -4115,7 +4113,6 @@ module GHC.Base where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
modInt :: Int -> Int -> Int
@@ -4174,7 +4171,6 @@ module GHC.Base where
negateInt8X64# :: Int8X64# -> Int8X64#
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
@@ -5370,8 +5366,6 @@ module GHC.Exts where
data Array# a
type ArrayArray# :: UnliftedType
newtype ArrayArray# = ArrayArray# (Array# ByteArray#)
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -6182,7 +6176,6 @@ module GHC.Exts where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mulIntMayOflo# :: Int# -> Int# -> Int#
@@ -6234,7 +6227,6 @@ module GHC.Exts where
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArrayArray# :: forall s. Int# -> State# s -> (# State# s, MutableArrayArray# s #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -3221,8 +3221,6 @@ module GHC.Base where
{-# MINIMAL pure, ((<*>) | liftA2) #-}
type Array# :: forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType
data Array# a
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -4118,7 +4116,6 @@ module GHC.Base where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
modInt :: Int -> Int -> Int
@@ -4177,7 +4174,6 @@ module GHC.Base where
negateInt8X64# :: Int8X64# -> Int8X64#
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
@@ -5538,8 +5534,6 @@ module GHC.Exts where
data Array# a
type ArrayArray# :: UnliftedType
newtype ArrayArray# = ArrayArray# (Array# ByteArray#)
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -6353,7 +6347,6 @@ module GHC.Exts where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mulIntMayOflo# :: Int# -> Int# -> Int#
@@ -6405,7 +6398,6 @@ module GHC.Exts where
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArrayArray# :: forall s. Int# -> State# s -> (# State# s, MutableArrayArray# s #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -3221,8 +3221,6 @@ module GHC.Base where
{-# MINIMAL pure, ((<*>) | liftA2) #-}
type Array# :: forall {l :: Levity}. TYPE (BoxedRep l) -> UnliftedType
data Array# a
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -4115,7 +4113,6 @@ module GHC.Base where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
modInt :: Int -> Int -> Int
@@ -4174,7 +4171,6 @@ module GHC.Base where
negateInt8X64# :: Int8X64# -> Int8X64#
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
@@ -5398,8 +5394,6 @@ module GHC.Exts where
data Array# a
type ArrayArray# :: UnliftedType
newtype ArrayArray# = ArrayArray# (Array# ByteArray#)
- type BCO :: *
- data BCO
type Bool :: *
data Bool = False | True
type ByteArray# :: UnliftedType
@@ -6210,7 +6204,6 @@ module GHC.Exts where
minusWord8X16# :: Word8X16# -> Word8X16# -> Word8X16#
minusWord8X32# :: Word8X32# -> Word8X32# -> Word8X32#
minusWord8X64# :: Word8X64# -> Word8X64# -> Word8X64#
- mkApUpd0# :: forall a. BCO -> (# a #)
mkWeak# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) c. a -> b -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# :: forall {l :: Levity} {k :: Levity} (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mulIntMayOflo# :: Int# -> Int# -> Int#
@@ -6262,7 +6255,6 @@ module GHC.Exts where
newAlignedPinnedByteArray# :: forall d. Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newArray# :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) d. Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArrayArray# :: forall s. Int# -> State# s -> (# State# s, MutableArrayArray# s #)
- newBCO# :: forall a d. ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# d -> (# State# d, BCO #)
newByteArray# :: forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newIOPort# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, IOPort# d a #)
newMVar# :: forall {l :: Levity} d (a :: TYPE (BoxedRep l)). State# d -> (# State# d, MVar# d a #)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b4788c6dcb8801126f0ad4b2ce864f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b4788c6dcb8801126f0ad4b2ce864f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0