Rodrigo Mesquita pushed to branch wip/romes/step-out at Glasgow Haskell Compiler / GHC Commits: f7d2b30a by Rodrigo Mesquita at 2025-05-27T17:22:35+01:00 More fixes and improvements; it now works but behaviour is not finished - - - - - 8 changed files: - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval/Types.hs - ghc/GHCi/UI.hs - libraries/ghci/GHCi/Run.hs - rts/Debugger.cmm - rts/Interpreter.c - rts/StgMiscClosures.cmm - utils/deriveConstants/Main.hs Changes: ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -33,7 +33,7 @@ initSimpleOpts dflags = SimpleOpts data EvalStep -- | ... at every breakpoint tick = EvalStepSingle - -- | ... after every return stmt + -- | ... after any return stmt | EvalStepOut -- | ... only on explicit breakpoints | EvalStepNone ===================================== compiler/GHC/Runtime/Eval/Types.hs ===================================== @@ -47,7 +47,7 @@ data SingleStep -- | :step [expr] | SingleStep - -- | :stepout [expr] + -- | :stepout | StepOut -- | :steplocal [expr] ===================================== ghc/GHCi/UI.hs ===================================== @@ -247,7 +247,7 @@ ghciCommands = map mkCmd [ ("sprint", keepGoing sprintCmd, completeExpression), ("step", keepGoing stepCmd, completeIdentifier), ("steplocal", keepGoing stepLocalCmd, completeIdentifier), - ("stepout", keepGoing stepOutCmd, completeIdentifier), + ("stepout", keepGoing stepOutCmd, noCompletion), ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), ("type", keepGoingMulti' typeOfExpr, completeExpression), ("trace", keepGoing traceCmd, completeExpression), @@ -3796,10 +3796,7 @@ stepCmd arg = withSandboxOnly ":step" $ step arg 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 +stepOutCmd _ = withSandboxOnly ":stepout" $ doContinue GHC.StepOut stepLocalCmd :: GhciMonad m => String -> m () stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -202,7 +202,7 @@ doSeq ref = do resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ()) resumeSeq hvref = do ResumeContext{..} <- localRef hvref - withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $ + withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar (Just resumeThreadId) $ mask_ $ do putMVar resumeBreakMVar () -- this awakens the stopped thread... redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar @@ -231,7 +231,7 @@ sandboxIO opts io = do -- We are running in uninterruptibleMask breakMVar <- newEmptyMVar statusMVar <- newEmptyMVar - withBreakAction opts breakMVar statusMVar $ do + withBreakAction opts breakMVar statusMVar Nothing $ do let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io if useSandboxThread opts then do @@ -326,8 +326,8 @@ tryEval io = do -- resets everything when the computation has stopped running. This -- is a not-very-good way to ensure that only the interactive -- evaluation should generate breakpoints. -withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a -withBreakAction opts breakMVar statusMVar act +withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> Maybe ThreadId {-^ If resuming, the current threadId -} -> IO a -> IO a +withBreakAction opts breakMVar statusMVar mtid act = bracket setBreakAction resetBreakAction (\_ -> act) where setBreakAction = do @@ -336,8 +336,10 @@ withBreakAction opts breakMVar statusMVar act when (breakOnException opts) $ poke exceptionFlag 1 when (singleStep opts) rts_enableStopNextBreakpointAll when (stepOut opts) $ do - ThreadId tid <- myThreadId - rts_enableStopAfterReturn tid + case mtid of + Nothing -> rts_enableStopNextBreakpointAll -- just enable single-step when no thread is stopped + Just (ThreadId tid) -> do + rts_enableStopAfterReturn tid return stablePtr -- Breaking on exceptions is not enabled by default, since it -- might be a bit surprising. The exception flag is turned off @@ -369,10 +371,9 @@ withBreakAction opts breakMVar statusMVar act poke breakPointIOAction noBreakStablePtr poke exceptionFlag 0 rts_disableStopNextBreakpointAll - - ThreadId tid <- myThreadId - rts_disableStopAfterReturn tid - + case mtid of + Just (ThreadId tid) -> rts_disableStopAfterReturn tid + _ -> pure () freeStablePtr stablePtr resumeStmt @@ -380,7 +381,7 @@ resumeStmt -> IO (EvalStatus [HValueRef]) resumeStmt opts hvref = do ResumeContext{..} <- localRef hvref - withBreakAction opts resumeBreakMVar resumeStatusMVar $ + withBreakAction opts resumeBreakMVar resumeStatusMVar (Just resumeThreadId) $ mask_ $ do putMVar resumeBreakMVar () -- this awakens the stopped thread... redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar ===================================== rts/Debugger.cmm ===================================== @@ -29,8 +29,8 @@ import CLOSURE stg_stop_after_ret_frame_info; * * See Note [Debugger: Step-out] for details. */ -INFO_TABLE_RET (stg_stop_after_ret_frame, RET_SMALL) - return (/* no return values */) +INFO_TABLE_RET (stg_stop_after_ret_frame, RET_SMALL, W_ info_ptr) + /* no args => explicit stack */ { /* We've entered a stg_stop_after_ret_frame, thus we want to stop at the next @@ -40,7 +40,12 @@ INFO_TABLE_RET (stg_stop_after_ret_frame, RET_SMALL) StgTSO_flags(CurrentTSO) = %lobits32( TO_W_(StgTSO_flags(CurrentTSO)) | TSO_STOP_NEXT_BREAKPOINT ); - /* After enabling the single step mode, execution is resumed by returning - * to the frame this one intercepted. */ + * to the frame this one intercepted. + * + * Note: Arguments passed to the frame we intercepted must be propagated, + * and the floating point registers untouched! See Note [Frames intercepting frames]. + */ + Sp = Sp + SIZEOF_StgStopAfterRetFrame; + jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live! } ===================================== rts/Interpreter.c ===================================== @@ -562,7 +562,7 @@ interpretBCO (Capability* cap) if (cap->r.rCurrentTSO->flags & TSO_STOP_AFTER_RETURN) { StgPtr frame; - frame = cap->r.rCurrentTSO->stackobj->sp; + frame = Sp; // Insert the stg_stop_after_ret_frame after the first frame that is NOT a // case continuation BCO. @@ -573,18 +573,23 @@ interpretBCO (Capability* cap) while (*frame == (W_)&stg_CASE_CONT_BCO_info) { frame += stack_frame_sizeW((StgClosure *)frame); } - // New frame goes right after the first non-case-cont frame + // New frame goes /right after the first/ non-case-cont frame frame += stack_frame_sizeW((StgClosure *)frame); // TODO: Handle stack bottom edge case!? if frame == STACK BOTTOM... // Make space for the new frame + memmove((W_*)Sp - sizeofW(StgStopAfterRetFrame), Sp, (uint8_t*)frame - (uint8_t*)Sp); Sp_subW(sizeofW(StgStopAfterRetFrame)); - memmove(frame-sizeof(StgStopAfterRetFrame), frame, (uint8_t*)cap->r.rCurrentTSO->stackobj->sp - (uint8_t*)frame); + + // Point to newly opened space + frame -= sizeofW(StgStopAfterRetFrame); // Then write it. ((StgStopAfterRetFrame*)frame)->header.info = &stg_stop_after_ret_frame_info; + // TODO: Write profiling info if needed + // Frame was pushed, mark as done to not do it again cap->r.rCurrentTSO->flags &= ~TSO_STOP_AFTER_RETURN; } @@ -640,7 +645,6 @@ interpretBCO (Capability* cap) // // [1] An StgBCO's info table pointer may also be stg_CASE_CONT_BCO_info. // See Note [Case continuation BCOs]. - // else if (SpW(0) == (W_)&stg_apply_interp_info) { obj = UNTAG_CLOSURE((StgClosure *)ReadSpW(1)); Sp_addW(2); ===================================== rts/StgMiscClosures.cmm ===================================== @@ -53,21 +53,12 @@ INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, { /* - !!!!!!!!!!!!!!!!! !!! IMPORTANT !!! !!!!!!!!!!!!!!!!! The body of this function MUST NOT use any floating-point - or vector registers. DO NOT add any e.g. debug printing logic that - has any chance whatsoever of using floating-point or vector registers. - If you DO want to edit the function in such a way that it may use - vector registers, you will need to define multiple different copies - of this function, as we do e.g. for stg_stack_underflow_frame - (see Jumps.h). - - See Note [realArgRegsCover] in GHC.Cmm.CallConv for more details. - + or vector registers. See Note [Frames intercepting frames]. */ unwind Sp = W_[Sp + SIZEOF_StgOrigThunkInfoFrame]; @@ -75,6 +66,30 @@ INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live! } +/* +Note [Frames intercepting frames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A frame which "intercepts" the following frame (to do additional work or +manipulate the stack, such as `stg_orig_thunk_info_frame` or +`stg_stop_after_ret_frame`) must take care to passthrough all the registers and +arguments when it returns to the next frame. This is done by jumping with +GP_ARG_REGS as in: + + jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live! + +However, special care must be taken when these arguments are propagated: + +The body of such a function MUST NOT use any floating-point +or vector registers. DO NOT add any e.g. debug printing logic that +has any chance whatsoever of using floating-point or vector registers. +If you DO want to edit the function in such a way that it may use +vector registers, you will need to define multiple different copies +of the function, as we do e.g. for stg_stack_underflow_frame +(see Jumps.h). + +See Note [realArgRegsCover] in GHC.Cmm.CallConv for more details. +*/ + /* ---------------------------------------------------------------------------- Restore a saved cost centre ------------------------------------------------------------------------- */ ===================================== utils/deriveConstants/Main.hs ===================================== @@ -518,6 +518,8 @@ wanteds os = concat ,closureFieldGcptr C "StgInd" "indirectee" + ,closureSize C "StgStopAfterRetFrame" + ,closureSize C "StgMutVar" ,closureField C "StgMutVar" "var" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f7d2b30a12d81ff8948b13366a048e29... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f7d2b30a12d81ff8948b13366a048e29... You're receiving this email because of your account on gitlab.haskell.org.