- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/bco-docs] 2 commits: compiler: Use field selectors when creating BCOs
by Ben Gamari (＠bgamari) 15 May '25

15 May '25

Ben Gamari pushed to branch wip/bco-docs at Glasgow Haskell Compiler / GHC Commits: acd08fcd by Ben Gamari at 2025-05-15T13:05:59-04:00 compiler: Use field selectors when creating BCOs This makes it easier to grep for these fields. - - - - - 882ffdec by Ben Gamari at 2025-05-15T13:06:02-04:00 compiler: Clarify BCO size Previously the semantics and size of StgBCO was a bit unclear. Specifically, the `size` field was documented to contain the size of the bitmap whereas it was actually the size of the closure *and* bitmap. Additionally, it was not as clear as it could be that the bitmap was a full StgLargeBitmap with its own `size` field. - - - - - 4 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Linker.hs - rts/PrimOps.cmm - rts/include/rts/storage/Closures.h Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -266,7 +266,13 @@ assembleBCO platform let !insns_arr = mkBCOByteArray $ final_isn_array !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap - ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array) + ul_bco = UnlinkedBCO { unlinkedBCOName = nm + , unlinkedBCOArity = arity + , unlinkedBCOInstrs = insns_arr + , unlinkedBCOBitmap = bitmap_arr + , unlinkedBCOLits = fromSmallArray final_lit_array + , unlinkedBCOPtrs = fromSmallArray final_ptr_array + } -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until @@ -275,6 +281,7 @@ assembleBCO platform return ul_bco +-- | Construct a word-array containing an @StgLargeBitmap@. mkBitmapArray :: Word -> [StgWord] -> UArray Int Word -- Here the return type must be an array of Words, not StgWords, -- because the underlying ByteArray# will end up as a component ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -65,11 +65,13 @@ linkBCO interp pkgs_loaded le bco_ix (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0) ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0) let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits - return (ResolvedBCO isLittleEndian arity - insns - bitmap - (mkBCOByteArray lits') - (addListToSS emptySS ptrs)) + return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian + , resolvedBCOArity = arity + , resolvedBCOInstrs = insns + , resolvedBCOBitmap = bitmap + , resolvedBCOLits = mkBCOByteArray lits' + , resolvedBCOPtrs = addListToSS emptySS ptrs + } lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word lookupLiteral interp pkgs_loaded le ptr = case ptr of ===================================== rts/PrimOps.cmm ===================================== @@ -2440,6 +2440,7 @@ stg_newBCOzh ( P_ instrs, W_ arity, P_ bitmap_arr ) { + // N.B. bitmap_arr contains a full StgLargeBitmap object. W_ bco, bytes, words; words = BYTES_TO_WDS(SIZEOF_StgBCO) + BYTE_ARR_WDS(bitmap_arr); ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -427,7 +427,7 @@ typedef struct { StgArrBytes *literals; // literals used by the instructions StgMutArrPtrs *ptrs; // free variables StgHalfWord arity; // arity of this BCO - StgHalfWord size; // size of the bitmap + StgHalfWord size; // size of the closure and bitmap StgWord bitmap[]; // an StgLargeBitmap } StgBCO; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0bf1212af899941e6e11347a8b20ad… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0bf1212af899941e6e11347a8b20ad… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/bco-docs
by Ben Gamari (＠bgamari) 15 May '25

15 May '25

Ben Gamari pushed new branch wip/bco-docs at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/bco-docs You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25974] Add `.exe` to `WindresCmd` environment var and more debugging info around it
by Serge S. Gulin (＠gulin.serge) 15 May '25

15 May '25

Serge S. Gulin pushed to branch wip/T25974 at Glasgow Haskell Compiler / GHC Commits: caa9b692 by Serge S. Gulin at 2025-05-15T18:58:16+04:00 Add `.exe` to `WindresCmd` environment var and more debugging info around it - - - - - 3 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - m4/fp_settings.m4 Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -1338,7 +1338,7 @@ cross_jobs = [ . setVariable "SIZE" (llvm_prefix ++ "size") . setVariable "STRINGS" (llvm_prefix ++ "strings") . setVariable "STRIP" (llvm_prefix ++ "strip") - . setVariable "WindresCmd" (llvm_prefix ++ "windres") + . setVariable "WindresCmd" (llvm_prefix ++ "windres" ++ exe_suffix) . setVariable "LLVMAS" (llvm_prefix ++ "clang") . setVariable "LD" (llvm_prefix ++ "ld") -- See Note [Empty MergeObjsCmd] ===================================== .gitlab/jobs.yaml ===================================== @@ -560,7 +560,7 @@ "STRIP": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate-_wine_full_build", "TOOLCHAIN_SOURCE": "env", - "WindresCmd": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-windres" + "WindresCmd": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-windres.exe" } }, "i386-linux-alpine3_20-validate": { @@ -1317,7 +1317,7 @@ "STRIP": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate-_wine_full_build", "TOOLCHAIN_SOURCE": "env", - "WindresCmd": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-windres", + "WindresCmd": "C:/msys64/opt/ghc-bootstrap/mingw/bin/aarch64-w64-mingw32-windres.exe", "XZ_OPT": "-9" } }, ===================================== m4/fp_settings.m4 ===================================== @@ -79,10 +79,13 @@ AC_DEFUN([FP_SETTINGS], [AC_MSG_ERROR(Unknown CPPSupportsG0 value $CmmCPPSupportsG0)] ) + AC_MSG_CHECKING([whether $WindresCmd exists]) if test -z "$WindresCmd"; then SettingsWindresCommand="/bin/false" + AC_MSG_RESULT([no, use $SettingsWindresCommand]) else SettingsWindresCommand="$WindresCmd" + AC_MSG_RESULT([yes]) fi # LLVM backend tools @@ -92,6 +95,7 @@ AC_DEFUN([FP_SETTINGS], SettingsLlvmAsFlags="$LlvmAsFlags" if test "$EnableDistroToolchain" = "YES"; then + AC_MSG_NOTICE([--enable-distro-toolchain is specified, applying basename]) # If the user specified --enable-distro-toolchain then we just use the # executable names, not paths. SettingsCCompilerCommand="$(basename $SettingsCCompilerCommand)" @@ -108,6 +112,7 @@ AC_DEFUN([FP_SETTINGS], fi if test "$windows" = YES -a "$EnableDistroToolchain" = "NO"; then + AC_MSG_NOTICE([--enable-distro-toolchain is not specified at Windows]) # Handle the Windows toolchain installed in FP_SETUP_WINDOWS_TOOLCHAIN. # We need to issue a substitution to use $tooldir, # See Note [tooldir: How GHC finds mingw on Windows] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/caa9b692569eb03a2a4d1e4ae990cbc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/caa9b692569eb03a2a4d1e4ae990cbc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

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

15 May '25

Rodrigo Mesquita pushed to branch wip/romes/step-out at Glasgow Haskell Compiler / GHC Commits: ff887a62 by Rodrigo Mesquita at 2025-05-15T15:57:29+01:00 debugger: Implement step-out feature Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. On the other hand, it means the debugger follows the more realistic execution of the program. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key implementation bit is simple: When step-out is set and the interpreter hits a RETURN instruction, enable "stop at the immediate next breakpoint" (aka single-step). See also `Note [Debugger Step-out]` in `rts/Interpreter.c` Note [Debugger Step-out] ~~~~~~~~~~~~~~~~~~~~~~~~ When the global debugger step-out flag is set (`rts_stop_after_return`), the interpreter must yield execution right after the first RETURN. When stepping-out, we simply enable `rts_stop_next_breakpoint` when we hit a return instruction (in `do_return_pointer` and `do_return_nonpointer`). The step-out flag is cleared and must be re-enabled explicitly to step-out again. A limitation of this approach is that stepping-out of a function that was tail-called will skip its caller since no stack frame is pushed for a tail call (i.e. a tail call returns directly to its caller's first non-tail caller). Fixes #26042 - - - - - 17 changed files: - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Interpreter.c - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h - + testsuite/tests/ghci.debugger/scripts/T26042a.hs - + testsuite/tests/ghci.debugger/scripts/T26042a.script - + testsuite/tests/ghci.debugger/scripts/T26042b.hs - + testsuite/tests/ghci.debugger/scripts/T26042b.script - + testsuite/tests/ghci.debugger/scripts/T26042c.hs - + testsuite/tests/ghci.debugger/scripts/T26042c.script - testsuite/tests/ghci.debugger/scripts/all.T Changes: ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -3,6 +3,7 @@ module GHC.Driver.Config ( initOptCoercionOpts , initSimpleOpts , initEvalOpts + , EvalStep(..) ) where @@ -28,13 +29,28 @@ initSimpleOpts dflags = SimpleOpts , so_inline = True } +-- | Instruct the interpreter evaluation to break... +data EvalStep + -- | ... at every breakpoint tick + = EvalStepSingle + -- | ... after every return stmt + | EvalStepOut + -- | ... only on explicit breakpoints + | EvalStepNone + -- | Extract GHCi options from DynFlags and step -initEvalOpts :: DynFlags -> Bool -> EvalOpts +initEvalOpts :: DynFlags -> EvalStep -> EvalOpts initEvalOpts dflags step = EvalOpts { useSandboxThread = gopt Opt_GhciSandbox dflags - , singleStep = step + , singleStep = singleStep + , stepOut = stepOut , breakOnException = gopt Opt_BreakOnException dflags , breakOnError = gopt Opt_BreakOnError dflags } + where + (singleStep, stepOut) = case step of + EvalStepSingle -> (True, False) + EvalStepOut -> (False, True) + EvalStepNone -> (False, False) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -343,7 +343,12 @@ handleRunStatus step expr bindings final_ids status history0 = do setSession hsc_env2 return (ExecBreak names Nothing) - -- Just case: we stopped at a breakpoint + -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint + -- + -- The interpreter yields on a breakpoint if: + -- - the breakpoint was explicitly enabled (in @BreakArray@) + -- - or @singleStep = True@ in EvalOpts + -- - or @stepOut = True@ in EvalOpts EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do let ibi = evalBreakpointToId eval_break tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi) @@ -351,13 +356,14 @@ handleRunStatus step expr bindings final_ids status history0 = do span = modBreaks_locs tick_brks ! ibi_tick_index ibi decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi + -- Was the breakpoint explicitly enabled? b <- liftIO $ breakpointStatus interp (modBreaks_flags tick_brks) (ibi_tick_index ibi) apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt - -- This breakpoint is explicitly enabled; we want to stop - -- instead of just logging it. + -- This breakpoint is enabled or we mean to break here; + -- we want to stop instead of just logging it. if b || breakHere step span then do -- This function only returns control to ghci with 'ExecBreak' when it is really meant to break. -- Specifically, for :steplocal or :stepmodule, don't return control @@ -1247,7 +1253,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do _ -> panic "compileParsedExprRemote" updateFixityEnv fix_env - let eval_opts = initEvalOpts dflags False + let eval_opts = initEvalOpts dflags EvalStepNone status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) case status of EvalComplete _ (EvalSuccess [hval]) -> return hval ===================================== compiler/GHC/Runtime/Eval/Types.hs ===================================== @@ -17,6 +17,7 @@ import GHC.Prelude import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) +import GHC.Driver.Config (EvalStep(..)) import GHC.Types.Id import GHC.Types.Name import GHC.Types.TyThing @@ -46,6 +47,9 @@ data SingleStep -- | :step [expr] | SingleStep + -- | :stepout [expr] + | StepOut + -- | :steplocal [expr] | LocalStep { breakAt :: SrcSpan } @@ -55,10 +59,12 @@ data SingleStep { breakAt :: SrcSpan } -- | Whether this 'SingleStep' mode requires instructing the interpreter to --- step at every breakpoint. -enableGhcStepMode :: SingleStep -> Bool -enableGhcStepMode RunToCompletion = False -enableGhcStepMode _ = True +-- step at every breakpoint or after every return (see @'EvalStep'@). +enableGhcStepMode :: SingleStep -> EvalStep +enableGhcStepMode RunToCompletion = EvalStepNone +enableGhcStepMode StepOut = EvalStepOut +-- for the remaining step modes we need to stop at every single breakpoint. +enableGhcStepMode _ = EvalStepSingle -- | Given a 'SingleStep' mode and the SrcSpan of a breakpoint we hit, return -- @True@ if based on the step-mode alone we should stop at this breakpoint. @@ -70,6 +76,7 @@ breakHere :: SingleStep -> SrcSpan -> Bool breakHere step break_span = case step of RunToCompletion -> False RunAndLogSteps -> False + StepOut -> True -- hmm. this function may not be a good abstraction? SingleStep -> True LocalStep span -> break_span `isSubspanOf` span ModuleStep span -> srcSpanFileName_maybe span == srcSpanFileName_maybe break_span ===================================== docs/users_guide/ghci.rst ===================================== @@ -2980,6 +2980,35 @@ commonly used commands. hit by an error (:ghc-flag:`-fbreak-on-error`) or an exception (:ghc-flag:`-fbreak-on-exception`). +.. ghci-cmd:: :stepout + + Stop at the first breakpoint immediately after returning from the current + function scope. + + Known limitations: because a function tail-call does not push a stack + frame, if step-out is used inside of a function that was tail-called, + execution will not be returned to its caller, but rather its caller's + first non-tail caller. On the other hand, it means the debugger + follows the more realistic execution of the program. + In the following example: + + .. code-block:: none + + f = do + a + b <--- (1) set breakpoint then step in here + c + b = do + ... + d <--- (2) step-into this tail call + d = do + ... + something <--- (3) step-out here + ... + + Stepping-out will stop execution at the `c` invokation in `f`, rather than + stopping at `b`. + .. ghci-cmd:: :stepmodule Enable only breakpoints in the current module and resume evaluation ===================================== ghc/GHCi/UI.hs ===================================== @@ -247,6 +247,7 @@ ghciCommands = map mkCmd [ ("sprint", keepGoing sprintCmd, completeExpression), ("step", keepGoing stepCmd, completeIdentifier), ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepout", keepGoing stepOutCmd, completeIdentifier), ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), ("type", keepGoingMulti' typeOfExpr, completeExpression), ("trace", keepGoing traceCmd, completeExpression), @@ -407,6 +408,7 @@ defFullHelpText = " :step single-step after stopping at a breakpoint\n"++ " :step <expr> single-step into <expr>\n"++ " :steplocal single-step within the current top-level binding\n"++ + " :stepout stop at the first breakpoint after returning from the current scope\n"++ " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++ @@ -3793,6 +3795,12 @@ stepCmd arg = withSandboxOnly ":step" $ step arg step [] = doContinue GHC.SingleStep step expression = runStmt expression GHC.SingleStep >> return () +stepOutCmd :: GhciMonad m => String -> m () +stepOutCmd arg = withSandboxOnly ":stepout" $ step arg + where + step [] = doContinue GHC.StepOut + step expression = stepCmd expression + stepLocalCmd :: GhciMonad m => String -> m () stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg where ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -374,6 +374,7 @@ putTHMessage m = case m of data EvalOpts = EvalOpts { useSandboxThread :: Bool , singleStep :: Bool + , stepOut :: Bool , breakOnException :: Bool , breakOnError :: Bool } ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -210,6 +210,7 @@ evalOptsSeq :: EvalOpts evalOptsSeq = EvalOpts { useSandboxThread = True , singleStep = False + , stepOut = False , breakOnException = False , breakOnError = False } @@ -333,6 +334,7 @@ withBreakAction opts breakMVar statusMVar act poke breakPointIOAction stablePtr when (breakOnException opts) $ poke exceptionFlag 1 when (singleStep opts) $ setStepFlag + when (stepOut opts) $ poke stepOutFlag 1 return stablePtr -- Breaking on exceptions is not enabled by default, since it -- might be a bit surprising. The exception flag is turned off @@ -363,6 +365,7 @@ withBreakAction opts breakMVar statusMVar act resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr poke exceptionFlag 0 + poke stepOutFlag 0 resetStepFlag freeStablePtr stablePtr @@ -398,6 +401,7 @@ abandonStmt hvref = do foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt +foreign import ccall "&rts_stop_after_return" stepOutFlag :: Ptr CInt setStepFlag :: IO () setStepFlag = poke stepFlag 1 ===================================== rts/Interpreter.c ===================================== @@ -194,6 +194,24 @@ See also Note [Width of parameters] for some more motivation. #define WITHIN_CHUNK_BOUNDS(n, s) \ (RTS_LIKELY((StgWord*)(Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame)))) +// Note [Debugger Step-out] +// ~~~~~~~~~~~~~~~~~~~~~~~~ +// When the global debugger step-out flag is set (`rts_stop_after_return`), +// the interpreter must yield execution right after the first RETURN. +// +// When stepping-out, we simply enable `rts_stop_next_breakpoint` when we hit a +// return instruction (in `do_return_pointer` and `do_return_nonpointer`). +// The step-out flag is cleared and must be re-enabled explicitly to step-out again. +// +// A limitation of this approach is that stepping-out of a function that was +// tail-called will skip its caller since no stack frame is pushed for a tail +// call (i.e. a tail call returns directly to its caller's first non-tail caller). +#define CHECK_BRK_AFTER_RET() \ + if (rts_stop_after_return) \ + { \ + rts_stop_next_breakpoint = true; \ + rts_stop_after_return = false; \ + } \ /* Note [PUSH_L underflow] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -245,6 +263,7 @@ allocate_NONUPD (Capability *cap, int n_words) int rts_stop_next_breakpoint = 0; int rts_stop_on_exception = 0; +int rts_stop_after_return = 0; #if defined(INTERP_STATS) @@ -734,6 +753,8 @@ do_return_pointer: IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size)); + CHECK_BRK_AFTER_RET(); + switch (get_itbl((StgClosure *)Sp)->type) { case RET_SMALL: { @@ -883,6 +904,8 @@ do_return_nonpointer: // get the offset of the header of the next stack frame offset = stack_frame_sizeW((StgClosure *)Sp); + CHECK_BRK_AFTER_RET(); + switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) { case RET_BCO: ===================================== rts/RtsSymbols.c ===================================== @@ -908,6 +908,7 @@ extern char **environ; SymI_NeedsDataProto(rts_breakpoint_io_action) \ SymI_NeedsDataProto(rts_stop_next_breakpoint) \ SymI_NeedsDataProto(rts_stop_on_exception) \ + SymI_NeedsDataProto(rts_stop_after_return) \ SymI_HasProto(stopTimer) \ SymI_HasProto(n_capabilities) \ SymI_HasProto(max_n_capabilities) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -619,6 +619,7 @@ RTS_FUN_DECL(stg_castFloatToWord32zh); // Interpreter.c extern StgWord rts_stop_next_breakpoint[]; extern StgWord rts_stop_on_exception[]; +extern StgWord rts_stop_after_return[]; extern StgWord rts_breakpoint_io_action[]; // Schedule.c ===================================== testsuite/tests/ghci.debugger/scripts/T26042a.hs ===================================== @@ -0,0 +1,17 @@ +module Main where + +main :: IO () +main = do + a <- foo + print a + +foo :: IO Int +foo = do + let x = 3 + y = 4 + b <- bar (x + y) + return b + +bar :: Int -> IO Int +bar z = return (z * 2) + ===================================== testsuite/tests/ghci.debugger/scripts/T26042a.script ===================================== @@ -0,0 +1,19 @@ +-- simple use of stepout +:break main +main +:list +:stepout +:list +:stepout +:list +-- from here on we're going to evaluate the thunks for `a` in `print a` +:stepout +:list +:stepout +:list +:stepout +:list +:stepout +:list +-- finish execution +:stepout ===================================== testsuite/tests/ghci.debugger/scripts/T26042b.hs ===================================== @@ -0,0 +1,22 @@ +module Main where + +main :: IO () +main = do + a <- foo False undefined + print a + +foo :: Bool -> Int -> IO Int +foo True i = return i +foo False _ = do + let x = 3 + y = 4 + n <- bar (x + y) + return n + +bar :: Int -> IO Int +bar z = do + let t = z * 2 + y <- foo True t + return y + + ===================================== testsuite/tests/ghci.debugger/scripts/T26042b.script ===================================== @@ -0,0 +1,15 @@ +-- break on the True branch of foo +:break 9 +main +:list +-- stepout of foo True to caller (ie bar) +:stepout +:list +-- stepout of bar (to branch of foo False, where bar was called) +:stepout +:list +-- stepout to right after the call to foo False in main +:stepout +:list +-- done +:continue ===================================== testsuite/tests/ghci.debugger/scripts/T26042c.hs ===================================== @@ -0,0 +1,19 @@ +module Main where + +main :: IO () +main = do + a <- foo False undefined + print a + +foo :: Bool -> Int -> IO Int +foo True i = return i +foo False _ = do + let x = 3 + y = 4 + bar (x + y) + +bar :: Int -> IO Int +bar z = do + let t = z * 2 + foo True t + ===================================== testsuite/tests/ghci.debugger/scripts/T26042c.script ===================================== @@ -0,0 +1,23 @@ +-- similar to T26042b, but uses tail calls +-- recall: for step-out, we skip the caller of tail calls +-- (because we don't push a stack frame for tail calls, so +-- there's no RET instruction to stop after) + +-- break on foo True branch +:break 9 +main +:list +-- step out of foo True and observe that we have skipped its call in bar, +-- and the call of bar in foo False. +-- we go straight to `main`. +:stepout +:list +-- stepping out from here will jump into the thunk because it's where we'll +-- go after returning. +:stepout +:list +-- and so on +:stepout +:list +-- finish +:continue ===================================== testsuite/tests/ghci.debugger/scripts/all.T ===================================== @@ -144,3 +144,6 @@ test('T24306', normal, ghci_script, ['T24306.script']) test('T24712', normal, ghci_script, ['T24712.script']) test('T25109', normal, ghci_script, ['T25109.script']) test('T25932', extra_files(['T25932.hs']), ghci_script, ['T25932.script']) +test('T26042a', extra_files(['T26042a.hs']), ghci_script, ['T26042a.script']) +test('T26042b', extra_files(['T26042b.hs']), ghci_script, ['T26042b.script']) +test('T26042c', extra_files(['T26042c.hs']), ghci_script, ['T26042c.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff887a6290fc3248934cbd9a54ed499… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff887a6290fc3248934cbd9a54ed499… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25974] Relax the requirements of `set_up_tarballs` Windows toolchain check
by Serge S. Gulin (＠gulin.serge) 15 May '25

15 May '25

Serge S. Gulin pushed to branch wip/T25974 at Glasgow Haskell Compiler / GHC Commits: 49d94b1d by Serge S. Gulin at 2025-05-15T15:26:22+04:00 Relax the requirements of `set_up_tarballs` Windows toolchain check - - - - - 5 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - hadrian/src/Builder.hs - hadrian/src/Rules/BinaryDist.hs - m4/fp_setup_windows_toolchain.m4 Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -873,10 +873,6 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} } , "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh configure" -- We have to trigger cabal build in an independent way to mitigate Wine hangs at MSYS2/Arm64EC , "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l -c './hadrian/build-cabal clean'" - -- We use "--enable-distro-toolchain" due of TOOLCHAIN_SOURCE="env", so we have to manually copy - -- bootstrap's compiler mingw into `_build` because binary-dist-dir requires it at Windows. - -- After './hadrian/build-cabal clean' we have to recreate the build root directory. - , "mkdir ./_build && cp -r ~/.wine/drive_c/msys64/opt/ghc-bootstrap/mingw ./_build/" , "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh build_hadrian" , "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh test_hadrian" ] ===================================== .gitlab/jobs.yaml ===================================== @@ -523,7 +523,6 @@ "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh setup", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh configure", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l -c './hadrian/build-cabal clean'", - "mkdir ./_build && cp -r ~/.wine/drive_c/msys64/opt/ghc-bootstrap/mingw ./_build/", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh build_hadrian", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh test_hadrian" ], @@ -1281,7 +1280,6 @@ "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh setup", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh configure", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l -c './hadrian/build-cabal clean'", - "mkdir ./_build && cp -r ~/.wine/drive_c/msys64/opt/ghc-bootstrap/mingw ./_build/", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh build_hadrian", "/opt/wine-arm64ec-msys2-deb12/bin/wine c:/msys64/usr/bin/bash.exe -l .gitlab/ci.sh test_hadrian" ], ===================================== hadrian/src/Builder.hs ===================================== @@ -26,7 +26,7 @@ import Hadrian.Builder.Tar import Hadrian.Oracles.Path import Hadrian.Oracles.TextFile import Hadrian.Utilities -import Oracles.Setting (bashPath, targetStage, isWinHost) +import Oracles.Setting (bashPath, targetStage, isWinHost, isWinTarget) import System.Exit import System.IO (stderr) @@ -240,12 +240,14 @@ instance H.Builder Builder where Ghc _ st -> do root <- buildRoot unlitPath <- builderPath Unlit + win_target <- isWinTarget + win_host <- isWinHost distro_mingw <- settingsFileSetting ToolchainSetting_DistroMinGW libffi_adjustors <- useLibffiForAdjustors use_system_ffi <- flag UseSystemFfi return $ [ unlitPath ] - ++ [ root -/- mingwStamp | windowsHost, distro_mingw == "NO" ] + ++ [ root -/- mingwStamp | win_target, win_host, distro_mingw == "NO" ] -- proxy for the entire mingw toolchain that -- we have in inplace/mingw initially, and then at -- root -/- mingw. ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -256,7 +256,10 @@ bindistRules = do copyFile ("libraries" -/- "prologue.txt") (bindistFilesDir -/- "docs-utils" -/- "prologue.txt") copyFile ("libraries" -/- "gen_contents_index") (bindistFilesDir -/- "docs-utils" -/- "gen_contents_index" ) - when windowsHost $ do + win_host <- isWinHost + win_target <- isWinTarget + distro_mingw <- settingsFileSetting ToolchainSetting_DistroMinGW + when (win_host && win_target && distro_mingw == "NO") $ do copyDirectory (root -/- "mingw") bindistFilesDir -- we use that opportunity to delete the .stamp file that we use -- as a proxy for the whole mingw toolchain, there's no point in ===================================== m4/fp_setup_windows_toolchain.m4 ===================================== @@ -9,7 +9,19 @@ AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[ fi set_up_tarballs() { - AC_MSG_NOTICE([Checking for Windows toolchain tarballs...]) + AC_MSG_CHECKING([for Windows toolchain tarballs...]) + + # We are leaving an option to substitute the toolchain with manually prepared one at the CI due of cross-compile targets. + # Builtin toolchain does not support cross-compile nor we have other reasons why it should. + # Probably we shouldn't ship GHC with a built-in toolchain for all cross-compile options. + # Cross-compile support is a relatively new and experimental option for Windows target but + # important to support AArch64. Same as Darwin. + if test -d inplace/mingw + then + AC_MSG_RESULT([skipping, inplace/mingw exists]) + return 0 + fi + local action if test "$TarballsAutodownload" = "NO" then @@ -17,6 +29,9 @@ AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[ else action="download" fi + readonly action + AC_MSG_RESULT([$action...]) + $PYTHON mk/get-win32-tarballs.py $action $mingw_arch case $? in 0) @@ -45,22 +60,19 @@ AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[ esac # Extract all the tarballs in one go - if ! test -d inplace/mingw - then - AC_MSG_NOTICE([Extracting Windows toolchain from archives (may take a while)...]) - rm -rf inplace/mingw - local base_dir="../ghc-tarballs/${tarball_dest_dir}" - ( cd inplace && - find "${base_dir}" -name "*.tar.xz" -exec tar --xz -xf {} \; && - find "${base_dir}" -name "*.tar.zst" -exec tar --zstd -xf {} \; && - rm ".MTREE" && - rm ".PKGINFO" && - cd .. ) || AC_MSG_ERROR([Could not extract Windows toolchains.]) - - mv "inplace/${tarball_mingw_dir}" inplace/mingw && - touch inplace/mingw - AC_MSG_NOTICE([In-tree MingW-w64 tree created]) - fi + AC_MSG_NOTICE([Extracting Windows toolchain from archives (may take a while)...]) + rm -rf inplace/mingw + local base_dir="../ghc-tarballs/${tarball_dest_dir}" + ( cd inplace && + find "${base_dir}" -name "*.tar.xz" -exec tar --xz -xf {} \; && + find "${base_dir}" -name "*.tar.zst" -exec tar --zstd -xf {} \; && + rm ".MTREE" && + rm ".PKGINFO" && + cd .. ) || AC_MSG_ERROR([Could not extract Windows toolchains.]) + + mv "inplace/${tarball_mingw_dir}" inplace/mingw && + touch inplace/mingw + AC_MSG_NOTICE([In-tree MingW-w64 tree created]) } # See Note [How we configure the bundled windows toolchain] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/49d94b1dcb8a161d3988f02d8ad4773… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/49d94b1dcb8a161d3988f02d8ad4773… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] Wibble
by Simon Peyton Jones (＠simonpj) 15 May '25

15 May '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: 76b01916 by Simon Peyton Jones at 2025-05-15T06:54:29-04:00 Wibble - - - - - 1 changed file: - compiler/GHC/Core/Opt/OccurAnal.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -1114,7 +1114,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl -- Precondition: Id is not a join point -mkNonRecRhsCtxt lvl bndr unf +mkNonRecRhsCtxt _lvl bndr unf | certainly_inline = OccVanilla -- See Note [Cascading inlines] | otherwise = OccRhs where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76b019160e730140ee0a51f0bf83896… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76b019160e730140ee0a51f0bf83896… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] Improvements
by Simon Peyton Jones (＠simonpj) 14 May '25

14 May '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: e1482394 by Simon Peyton Jones at 2025-05-14T23:21:36-04:00 Improvements esp inline top level things not-under-lambda only if it's a function. Beware extra iterations in T18698a - - - - - 2 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -1124,7 +1124,7 @@ mkNonRecRhsCtxt lvl bndr unf -- Distressing delicacy ... has to line up with preInlineUnconditionally case idOccInfo bndr of OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 } - -> active && not (isTopLevel lvl) && not stable_unf + -> active && not stable_unf _ -> False active = isAlwaysActive (idInlineActivation bndr) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1465,7 +1465,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env , occ_in_lam = NotInsideLam , occ_int_cxt = int_cxt } = isNotTopLevel top_lvl -- Get rid of allocation - || (int_cxt==IsInteresting) -- Function is applied + || (int_cxt==IsInteresting && idArity bndr > 0) -- Function is applied -- || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase one_occ OneOcc{ occ_n_br = 1 , occ_in_lam = IsInsideLam @@ -1632,6 +1632,7 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs unfolding = idUnfolding bndr -- arity = idArity bndr is_cheap = isCheapUnfolding unfolding + is_exp = isExpandableUnfolding unfolding uf_opts = seUnfoldingOpts env phase = sePhase env active = isActive phase (idInlineActivation bndr) @@ -1639,6 +1640,8 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs -- Check for code-size blow-up from inlining in multiple places code_dup_ok n_br + | is_top_lvl -- Don't inline top-level datacons, ever; no advantage, + , is_exp = False -- and float-out may have carefully created them | n_br == 1 = True -- No duplication | n_br >= 100 = False -- See #23627 | is_demanded = False -- Demanded => no allocation (it'll be a case expression View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e14823948401b7dad78cc4f2eddb03b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e14823948401b7dad78cc4f2eddb03b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

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

14 May '25

Rodrigo Mesquita pushed to branch wip/romes/step-out at Glasgow Haskell Compiler / GHC Commits: a043f051 by Rodrigo Mesquita at 2025-05-14T17:56:40+01:00 debugger: Implement step-out feature Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key implementation bit is simple: When step-out is set and the interpreter hits a RETURN instruction, enable "stop at the immediate next breakpoint" (aka single-step). See also `Note [Debugger Step-out]` in `rts/Interpreter.c` Note [Debugger Step-out] ~~~~~~~~~~~~~~~~~~~~~~~~ When the global debugger step-out flag is set (`rts_stop_after_return`), the interpreter must yield execution right after the first RETURN. When stepping-out, we simply enable `rts_stop_next_breakpoint` when we hit a return instruction (in `do_return_pointer` and `do_return_nonpointer`). The step-out flag is cleared and must be re-enabled explicitly to step-out again. A limitation of this approach is that stepping-out of a function that was tail-called will skip its caller since no stack frame is pushed for a tail call (i.e. a tail call returns directly to its caller's first non-tail caller). Fixes #26042 - - - - - 10 changed files: - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Interpreter.c - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -3,6 +3,7 @@ module GHC.Driver.Config ( initOptCoercionOpts , initSimpleOpts , initEvalOpts + , EvalStep(..) ) where @@ -28,13 +29,28 @@ initSimpleOpts dflags = SimpleOpts , so_inline = True } +-- | Instruct the interpreter evaluation to break... +data EvalStep + -- | ... at every breakpoint tick + = EvalStepSingle + -- | ... after every return stmt + | EvalStepOut + -- | ... only on explicit breakpoints + | EvalStepNone + -- | Extract GHCi options from DynFlags and step -initEvalOpts :: DynFlags -> Bool -> EvalOpts +initEvalOpts :: DynFlags -> EvalStep -> EvalOpts initEvalOpts dflags step = EvalOpts { useSandboxThread = gopt Opt_GhciSandbox dflags - , singleStep = step + , singleStep = singleStep + , stepOut = stepOut , breakOnException = gopt Opt_BreakOnException dflags , breakOnError = gopt Opt_BreakOnError dflags } + where + (singleStep, stepOut) = case step of + EvalStepSingle -> (True, False) + EvalStepOut -> (False, True) + EvalStepNone -> (False, False) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -343,7 +343,12 @@ handleRunStatus step expr bindings final_ids status history0 = do setSession hsc_env2 return (ExecBreak names Nothing) - -- Just case: we stopped at a breakpoint + -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint + -- + -- The interpreter yields on a breakpoint if: + -- - the breakpoint was explicitly enabled (in @BreakArray@) + -- - or @singleStep = True@ in EvalOpts + -- - or @stopAfterRet = True@ in EvalOpts EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do let ibi = evalBreakpointToId eval_break tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi) @@ -351,13 +356,14 @@ handleRunStatus step expr bindings final_ids status history0 = do span = modBreaks_locs tick_brks ! ibi_tick_index ibi decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi + -- Was the breakpoint explicitly enabled? b <- liftIO $ breakpointStatus interp (modBreaks_flags tick_brks) (ibi_tick_index ibi) apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt - -- This breakpoint is explicitly enabled; we want to stop - -- instead of just logging it. + -- This breakpoint is enabled or we mean to break here; + -- we want to stop instead of just logging it. if b || breakHere step span then do -- This function only returns control to ghci with 'ExecBreak' when it is really meant to break. -- Specifically, for :steplocal or :stepmodule, don't return control @@ -1247,7 +1253,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do _ -> panic "compileParsedExprRemote" updateFixityEnv fix_env - let eval_opts = initEvalOpts dflags False + let eval_opts = initEvalOpts dflags EvalStepNone status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) case status of EvalComplete _ (EvalSuccess [hval]) -> return hval ===================================== compiler/GHC/Runtime/Eval/Types.hs ===================================== @@ -17,6 +17,7 @@ import GHC.Prelude import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) +import GHC.Driver.Config (EvalStep(..)) import GHC.Types.Id import GHC.Types.Name import GHC.Types.TyThing @@ -46,6 +47,9 @@ data SingleStep -- | :step [expr] | SingleStep + -- | :stepout [expr] + | StepOut + -- | :steplocal [expr] | LocalStep { breakAt :: SrcSpan } @@ -55,10 +59,12 @@ data SingleStep { breakAt :: SrcSpan } -- | Whether this 'SingleStep' mode requires instructing the interpreter to --- step at every breakpoint. -enableGhcStepMode :: SingleStep -> Bool -enableGhcStepMode RunToCompletion = False -enableGhcStepMode _ = True +-- step at every breakpoint or after every return (see @'EvalStep'@). +enableGhcStepMode :: SingleStep -> EvalStep +enableGhcStepMode RunToCompletion = EvalStepNone +enableGhcStepMode StepOut = EvalStepOut +-- for the remaining step modes we need to stop at every single breakpoint. +enableGhcStepMode _ = EvalStepSingle -- | Given a 'SingleStep' mode and the SrcSpan of a breakpoint we hit, return -- @True@ if based on the step-mode alone we should stop at this breakpoint. @@ -70,6 +76,7 @@ breakHere :: SingleStep -> SrcSpan -> Bool breakHere step break_span = case step of RunToCompletion -> False RunAndLogSteps -> False + StepOut -> True -- hmm. this function may not be a good abstraction? SingleStep -> True LocalStep span -> break_span `isSubspanOf` span ModuleStep span -> srcSpanFileName_maybe span == srcSpanFileName_maybe break_span ===================================== docs/users_guide/ghci.rst ===================================== @@ -2980,6 +2980,33 @@ commonly used commands. hit by an error (:ghc-flag:`-fbreak-on-error`) or an exception (:ghc-flag:`-fbreak-on-exception`). +.. ghci-cmd:: :stepout + + Stop at the first breakpoint immediately after returning from the current + function scope. + + Known limitations: because a function tail-call does not push a stack + frame, if step-out is used inside of a function that was tail-called, + execution will not be returned to its caller, but rather its caller's + first non-tail caller. In the following example: + + .. code-block:: none + + f = do + a + b <--- (1) set breakpoint then step in here + c + b = do + ... + d <--- (2) step-into this tail call + d = do + ... + something <--- (3) step-out here + ... + + Stepping-out will stop execution at the `c` invokation in `f`, rather than + stopping at `b`. + .. ghci-cmd:: :stepmodule Enable only breakpoints in the current module and resume evaluation ===================================== ghc/GHCi/UI.hs ===================================== @@ -247,6 +247,7 @@ ghciCommands = map mkCmd [ ("sprint", keepGoing sprintCmd, completeExpression), ("step", keepGoing stepCmd, completeIdentifier), ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepout", keepGoing stepOutCmd, completeIdentifier), ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), ("type", keepGoingMulti' typeOfExpr, completeExpression), ("trace", keepGoing traceCmd, completeExpression), @@ -407,6 +408,7 @@ defFullHelpText = " :step single-step after stopping at a breakpoint\n"++ " :step <expr> single-step into <expr>\n"++ " :steplocal single-step within the current top-level binding\n"++ + " :stepout stop at the first breakpoint after returning from the current scope\n"++ " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++ @@ -3793,6 +3795,12 @@ stepCmd arg = withSandboxOnly ":step" $ step arg step [] = doContinue GHC.SingleStep step expression = runStmt expression GHC.SingleStep >> return () +stepOutCmd :: GhciMonad m => String -> m () +stepOutCmd arg = withSandboxOnly ":stepout" $ step arg + where + step [] = doContinue GHC.StepOut + step expression = stepCmd expression + stepLocalCmd :: GhciMonad m => String -> m () stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg where ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -374,6 +374,7 @@ putTHMessage m = case m of data EvalOpts = EvalOpts { useSandboxThread :: Bool , singleStep :: Bool + , stepOut :: Bool , breakOnException :: Bool , breakOnError :: Bool } ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -210,6 +210,7 @@ evalOptsSeq :: EvalOpts evalOptsSeq = EvalOpts { useSandboxThread = True , singleStep = False + , stepOut = False , breakOnException = False , breakOnError = False } @@ -333,6 +334,7 @@ withBreakAction opts breakMVar statusMVar act poke breakPointIOAction stablePtr when (breakOnException opts) $ poke exceptionFlag 1 when (singleStep opts) $ setStepFlag + when (breakOnException opts) $ poke stepOutFlag 1 return stablePtr -- Breaking on exceptions is not enabled by default, since it -- might be a bit surprising. The exception flag is turned off @@ -363,6 +365,7 @@ withBreakAction opts breakMVar statusMVar act resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr poke exceptionFlag 0 + poke stepOutFlag 0 resetStepFlag freeStablePtr stablePtr @@ -398,6 +401,7 @@ abandonStmt hvref = do foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt +foreign import ccall "&rts_stop_after_return" stepOutFlag :: Ptr CInt setStepFlag :: IO () setStepFlag = poke stepFlag 1 ===================================== rts/Interpreter.c ===================================== @@ -194,6 +194,24 @@ See also Note [Width of parameters] for some more motivation. #define WITHIN_CHUNK_BOUNDS(n, s) \ (RTS_LIKELY((StgWord*)(Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame)))) +// Note [Debugger Step-out] +// ~~~~~~~~~~~~~~~~~~~~~~~~ +// When the global debugger step-out flag is set (`rts_stop_after_return`), +// the interpreter must yield execution right after the first RETURN. +// +// When stepping-out, we simply enable `rts_stop_next_breakpoint` when we hit a +// return instruction (in `do_return_pointer` and `do_return_nonpointer`). +// The step-out flag is cleared and must be re-enabled explicitly to step-out again. +// +// A limitation of this approach is that stepping-out of a function that was +// tail-called will skip its caller since no stack frame is pushed for a tail +// call (i.e. a tail call returns directly to its caller's first non-tail caller). +#define CHECK_BRK_AFTER_RET() \ + if (rts_stop_after_return) \ + { \ + rts_stop_next_breakpoint = true; \ + rts_stop_after_return = false; \ + } \ /* Note [PUSH_L underflow] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -245,6 +263,7 @@ allocate_NONUPD (Capability *cap, int n_words) int rts_stop_next_breakpoint = 0; int rts_stop_on_exception = 0; +int rts_stop_after_return = 0; #if defined(INTERP_STATS) @@ -734,6 +753,8 @@ do_return_pointer: IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size)); + CHECK_BRK_AFTER_RET(); + switch (get_itbl((StgClosure *)Sp)->type) { case RET_SMALL: { @@ -883,6 +904,8 @@ do_return_nonpointer: // get the offset of the header of the next stack frame offset = stack_frame_sizeW((StgClosure *)Sp); + CHECK_BRK_AFTER_RET(); + switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) { case RET_BCO: ===================================== rts/RtsSymbols.c ===================================== @@ -908,6 +908,7 @@ extern char **environ; SymI_NeedsDataProto(rts_breakpoint_io_action) \ SymI_NeedsDataProto(rts_stop_next_breakpoint) \ SymI_NeedsDataProto(rts_stop_on_exception) \ + SymI_NeedsDataProto(rts_stop_after_return) \ SymI_HasProto(stopTimer) \ SymI_HasProto(n_capabilities) \ SymI_HasProto(max_n_capabilities) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -619,6 +619,7 @@ RTS_FUN_DECL(stg_castFloatToWord32zh); // Interpreter.c extern StgWord rts_stop_next_breakpoint[]; extern StgWord rts_stop_on_exception[]; +extern StgWord rts_stop_after_return[]; extern StgWord rts_breakpoint_io_action[]; // Schedule.c View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a043f05102cb9357e58c30cb1a2cbb9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a043f05102cb9357e58c30cb1a2cbb9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/romes/step-out
by Rodrigo Mesquita (＠alt-romes) 14 May '25

14 May '25

Rodrigo Mesquita pushed new branch wip/romes/step-out at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/romes/step-out You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ann-frame] Annotate frame
by Hannes Siebenhandl (＠fendor) 14 May '25

14 May '25

Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: 1dd1bff4 by Ben Gamari at 2025-05-14T17:19:40+02:00 Annotate frame - - - - - 25 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/StgToCmm/Prim.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/all.T - + libraries/ghc-heap/tests/ann_frame.hs - 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 - utils/deriveConstants/Main.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3927,6 +3927,16 @@ primop ClearCCSOp "clearCCS#" GenPrimOp with out_of_line = True +------------------------------------------------------------------------ +section "Annotating call stacks" +------------------------------------------------------------------------ + +primop AnnotateStackOp "annotateStack#" GenPrimOp + b -> a_reppoly -> a_reppoly + { Pushes an annotation frame to the stack which can be reported by backtraces. } + with + out_of_line = True + ------------------------------------------------------------------------ section "Info Table Origin" ------------------------------------------------------------------------ ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1771,6 +1771,7 @@ emitPrimOp cfg primop = WhereFromOp -> alwaysExternal GetApStackValOp -> alwaysExternal ClearCCSOp -> alwaysExternal + AnnotateStackOp -> alwaysExternal TraceEventOp -> alwaysExternal TraceEventBinaryOp -> alwaysExternal TraceMarkerOp -> alwaysExternal ===================================== libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs ===================================== @@ -84,6 +84,7 @@ data ClosureType | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN | COMPACT_NFDATA | CONTINUATION + | ANN_FRAME | N_CLOSURE_TYPES deriving (Enum, Eq, Ord, Show, Generic) #endif ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -574,11 +574,15 @@ data GenStackFrame b = , retFunPayload :: ![GenStackField b] } - | RetBCO + | RetBCO { info_tbl :: !StgInfoTable , bco :: !b -- ^ always a BCOClosure , bcoArgs :: ![GenStackField b] } + | AnnFrame + { info_tbl :: !StgInfoTable + , annotation :: !b + } deriving (Foldable, Functor, Generic, Show, Traversable) data PrimType ===================================== libraries/ghc-heap/GHC/Exts/Stack.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if MIN_TOOL_VERSION_ghc(9,9,0) +#if MIN_TOOL_VERSION_ghc(9,13,0) {-# LANGUAGE RecordWildCards #-} module GHC.Exts.Stack @@ -30,6 +30,7 @@ stackFrameSize (RetFun {..}) = sizeStgRetFunFrame + length retFunPayload stackFrameSize (RetBCO {..}) = sizeStgClosure + 1 + length bcoArgs -- The one additional word is a pointer to the next stack chunk stackFrameSize (UnderflowFrame {}) = sizeStgClosure + 1 +stackFrameSize (AnnFrame {}) = sizeStgAnnFrame stackFrameSize _ = error "Unexpected stack frame type" #else ===================================== libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc ===================================== @@ -3,7 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Exts.Stack.Constants where -#if MIN_TOOL_VERSION_ghc(9,9,0) +#if MIN_TOOL_VERSION_ghc(9,13,0) import Prelude @@ -88,6 +88,13 @@ offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_pa sizeStgRetFunFrame :: Int sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun) +sizeStgAnnFrame :: Int +sizeStgAnnFrame = bytesToWords (#const SIZEOF_StgAnnFrame) + +offsetStgAnnFrameAnn :: WordOffset +offsetStgAnnFrameAnn = byteOffsetToWordOffset $ + (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader) + offsetStgBCOFrameInstrs :: ByteOffset offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader) ===================================== libraries/ghc-heap/GHC/Exts/Stack/Decode.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if MIN_TOOL_VERSION_ghc(9,9,0) +#if MIN_TOOL_VERSION_ghc(9,13,0) {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} @@ -377,6 +377,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do catchFrameCode = catchFrameCode', handler = handler' } + ANN_FRAME -> + let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) + in + pure $ + AnnFrame + { info_tbl = info, + annotation = annotation + } x -> error $ "Unexpected closure type on stack: " ++ show x -- | Unbox 'Int#' from 'Int' ===================================== libraries/ghc-heap/tests/all.T ===================================== @@ -103,3 +103,5 @@ test('stack_misc_closures', ] , '-debug' # Debug RTS to use checkSTACK() (Sanity.c) ]) + +test('ann_frame', normal, compile_and_run, ['']) ===================================== libraries/ghc-heap/tests/ann_frame.hs ===================================== @@ -0,0 +1,36 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE GADTs #-} + +import Data.Typeable +import GHC.Exts +import GHC.Exts.Heap.Closures as Closures +import GHC.Exts.Stack.Decode +import GHC.Stack.CloneStack +import System.IO.Unsafe +import Unsafe.Coerce + +data StackAnnotation where + StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation + +annotateStack + :: forall a r b. + (Typeable a, Show a) + => a -> b -> b +annotateStack ann = + annotateStack# (StackAnnotation ann) + +hello :: Int -> Int -> Int +hello x y = annotateStack (x,y) $ unsafePerformIO $ do + stack <- GHC.Stack.CloneStack.cloneMyStack + decoded <- GHC.Exts.Stack.Decode.decodeStack stack + print [ show x + | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded + , StackAnnotation x <- pure $ unsafeCoerce ann + ] + return $ x + y + 42 +{-# OPAQUE hello #-} + +main :: IO () +main = + print $ hello 2 3 + ===================================== libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs ===================================== @@ -83,5 +83,6 @@ data ClosureType | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN | COMPACT_NFDATA | CONTINUATION + | ANN_FRAME | N_CLOSURE_TYPES deriving (Enum, Eq, Ord, Show, Generic) ===================================== rts/ClosureFlags.c ===================================== @@ -88,8 +88,9 @@ const StgWord16 closure_flags[] = { [SMALL_MUT_ARR_PTRS_FROZEN_CLEAN] = (_HNF| _NS| _UPT ), [COMPACT_NFDATA] = (_HNF| _NS ), [CONTINUATION] = (_HNF| _NS| _UPT ), + [ANN_FRAME] = ( _BTM| _FRM ), }; -#if N_CLOSURE_TYPES != 65 +#if N_CLOSURE_TYPES != 66 #error Closure types changed: update ClosureFlags.c! #endif ===================================== rts/LdvProfile.c ===================================== @@ -154,6 +154,7 @@ processHeapClosureForDead( const StgClosure *c ) case CATCH_STM_FRAME: case CATCH_RETRY_FRAME: case ATOMICALLY_FRAME: + case ANN_FRAME: // others case INVALID_OBJECT: case COMPACT_NFDATA: ===================================== rts/PrimOps.cmm ===================================== @@ -2800,6 +2800,28 @@ stg_clearCCSzh (P_ arg) jump stg_ap_v_fast(arg); } +#define ANN_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,ann) \ + w_ info_ptr, \ + PROF_HDR_FIELDS(w_,p1,p2) \ + p_ ann + +INFO_TABLE_RET (stg_ann_frame, ANN_FRAME, + ANN_FRAME_FIELDS(W_,P_, info_ptr, p1, p2, ann)) + /* no args => explicit stack */ +{ + unwind Sp = W_[Sp + SIZEOF_StgAnnFrame]; + Sp = Sp + SIZEOF_StgAnnFrame; + jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live! +} + +stg_annotateStackzh (P_ ann, P_ cont) +{ + STK_CHK_GEN(); + jump stg_ap_0_fast + (ANN_FRAME_FIELDS(,,stg_ann_frame_info, CCCS, 0, ann))(cont); + +} + stg_numSparkszh () { W_ n; ===================================== rts/Printer.c ===================================== @@ -270,6 +270,17 @@ printClosure( const StgClosure *obj ) case RET_FUN: */ + case ANN_FRAME: + { + StgAnnFrame* frame = (StgAnnFrame*)obj; + debugBelch("ANN_FRAME("); + printPtr((StgPtr)GET_INFO((StgClosure *)frame)); + debugBelch(","); + printPtr((StgPtr)frame->ann); + debugBelch(")\n"); + break; + } + case UPDATE_FRAME: { StgUpdateFrame* frame = (StgUpdateFrame*)obj; @@ -1123,6 +1134,7 @@ const char *closure_type_names[] = { [RET_FUN] = "RET_FUN", [UPDATE_FRAME] = "UPDATE_FRAME", [CATCH_FRAME] = "CATCH_FRAME", + [ANN_FRAME] = "ANN_FRAME", [UNDERFLOW_FRAME] = "UNDERFLOW_FRAME", [STOP_FRAME] = "STOP_FRAME", [BLOCKING_QUEUE] = "BLOCKING_QUEUE", @@ -1155,7 +1167,7 @@ const char *closure_type_names[] = { [CONTINUATION] = "CONTINUATION", }; -#if N_CLOSURE_TYPES != 65 +#if N_CLOSURE_TYPES != 66 #error Closure types changed: update Printer.c! #endif ===================================== rts/RetainerProfile.c ===================================== @@ -217,6 +217,7 @@ isRetainer( const StgClosure *c ) case RET_SMALL: case RET_BIG: case RET_FUN: + case ANN_FRAME: // other cases case IND: case INVALID_OBJECT: ===================================== rts/TraverseHeap.c ===================================== @@ -529,6 +529,7 @@ traverseGetChildren(StgClosure *c, StgClosure **first_child, bool *other_childre case RET_BCO: case RET_SMALL: case RET_BIG: + case ANN_FRAME: // invalid objects case IND: case INVALID_OBJECT: @@ -832,6 +833,7 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data, case RET_BCO: case RET_SMALL: case RET_BIG: + case ANN_FRAME: // invalid objects case IND: case INVALID_OBJECT: @@ -965,6 +967,7 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackElement *sep, case CATCH_RETRY_FRAME: case ATOMICALLY_FRAME: case RET_SMALL: + case ANN_FRAME: bitmap = BITMAP_BITS(info->i.layout.bitmap); size = BITMAP_SIZE(info->i.layout.bitmap); p++; ===================================== rts/include/rts/storage/ClosureTypes.h ===================================== @@ -89,4 +89,5 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA 63 #define CONTINUATION 64 -#define N_CLOSURE_TYPES 65 +#define ANN_FRAME 65 +#define N_CLOSURE_TYPES 66 ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -312,6 +312,15 @@ typedef struct { StgClosure *result; } StgDeadThreadFrame; +// Stack frame annotating an execution context with a Haskell value +// for backtrace purposes. +// +// Closure types: ANN_FRAME +typedef struct { + StgHeader header; + StgClosure *ann; +} StgAnnFrame; + // A function return stack frame: used when saving the state for a // garbage collection at a function entry point. The function // arguments are on the stack, and we also save the function (its ===================================== rts/js/profiling.js ===================================== @@ -333,3 +333,8 @@ function h$buildCCSPtr(o) { function h$clearCCS(a) { throw new Error("ClearCCSOp not implemented"); } + +// we throw away the annotation here. +function h$annotateStack(o) { + return o; +} ===================================== rts/sm/Compact.c ===================================== @@ -351,6 +351,7 @@ thread_stack(P_ p, P_ stack_end) case STOP_FRAME: case CATCH_FRAME: case RET_SMALL: + case ANN_FRAME: { W_ bitmap = BITMAP_BITS(info->i.layout.bitmap); W_ size = BITMAP_SIZE(info->i.layout.bitmap); ===================================== rts/sm/Evac.c ===================================== @@ -996,6 +996,7 @@ loop: case CATCH_STM_FRAME: case CATCH_RETRY_FRAME: case ATOMICALLY_FRAME: + case ANN_FRAME: // shouldn't see these barf("evacuate: stack frame at %p\n", q); ===================================== rts/sm/NonMovingMark.c ===================================== @@ -1180,6 +1180,7 @@ trace_stack_ (MarkQueue *queue, StgPtr sp, StgPtr spBottom) case STOP_FRAME: case CATCH_FRAME: case RET_SMALL: + case ANN_FRAME: { StgWord bitmap = BITMAP_BITS(info->i.layout.bitmap); StgWord size = BITMAP_SIZE(info->i.layout.bitmap); ===================================== rts/sm/Sanity.c ===================================== @@ -128,6 +128,7 @@ checkStackFrame( StgPtr c ) case UNDERFLOW_FRAME: case STOP_FRAME: case RET_SMALL: + case ANN_FRAME: size = BITMAP_SIZE(info->i.layout.bitmap); checkSmallBitmap((StgPtr)c + 1, BITMAP_BITS(info->i.layout.bitmap), size); ===================================== rts/sm/Scav.c ===================================== @@ -1983,6 +1983,7 @@ scavenge_stack(StgPtr p, StgPtr stack_end) case STOP_FRAME: case CATCH_FRAME: case RET_SMALL: + case ANN_FRAME: bitmap = BITMAP_BITS(info->i.layout.bitmap); size = BITMAP_SIZE(info->i.layout.bitmap); // NOTE: the payload starts immediately after the info-ptr, we ===================================== utils/deriveConstants/Main.hs ===================================== @@ -443,6 +443,8 @@ wanteds os = concat ,closureSize C "StgStopFrame" ,closureSize C "StgDeadThreadFrame" ,closureField C "StgDeadThreadFrame" "result" + ,structSize C "StgAnnFrame" + ,closureField C "StgAnnFrame" "ann" ,closureSize Both "StgMutArrPtrs" ,closureField Both "StgMutArrPtrs" "ptrs" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd1bff4867f2ca3c7863d4d5aa7bda… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd1bff4867f2ca3c7863d4d5aa7bda… You're receiving this email because of your account on gitlab.haskell.org.

1 0