Rodrigo Mesquita pushed to branch wip/romes/step-out at Glasgow Haskell Compiler / GHC

Commits:

8 changed files:

Changes:

  • compiler/GHC/Driver/Config.hs
    ... ... @@ -33,7 +33,7 @@ initSimpleOpts dflags = SimpleOpts
    33 33
     data EvalStep
    
    34 34
       -- | ... at every breakpoint tick
    
    35 35
       = EvalStepSingle
    
    36
    -  -- | ... after every return stmt
    
    36
    +  -- | ... after any return stmt
    
    37 37
       | EvalStepOut
    
    38 38
       -- | ... only on explicit breakpoints
    
    39 39
       | EvalStepNone
    

  • compiler/GHC/Runtime/Eval/Types.hs
    ... ... @@ -47,7 +47,7 @@ data SingleStep
    47 47
        -- | :step [expr]
    
    48 48
        | SingleStep
    
    49 49
     
    
    50
    -   -- | :stepout [expr]
    
    50
    +   -- | :stepout
    
    51 51
        | StepOut
    
    52 52
     
    
    53 53
        -- | :steplocal [expr]
    

  • ghc/GHCi/UI.hs
    ... ... @@ -247,7 +247,7 @@ ghciCommands = map mkCmd [
    247 247
       ("sprint",    keepGoing sprintCmd,            completeExpression),
    
    248 248
       ("step",      keepGoing stepCmd,              completeIdentifier),
    
    249 249
       ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),
    
    250
    -  ("stepout",   keepGoing stepOutCmd,           completeIdentifier),
    
    250
    +  ("stepout",   keepGoing stepOutCmd,           noCompletion),
    
    251 251
       ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),
    
    252 252
       ("type",      keepGoingMulti' typeOfExpr,          completeExpression),
    
    253 253
       ("trace",     keepGoing traceCmd,             completeExpression),
    
    ... ... @@ -3796,10 +3796,7 @@ stepCmd arg = withSandboxOnly ":step" $ step arg
    3796 3796
       step expression = runStmt expression GHC.SingleStep >> return ()
    
    3797 3797
     
    
    3798 3798
     stepOutCmd :: GhciMonad m => String -> m ()
    
    3799
    -stepOutCmd arg = withSandboxOnly ":stepout" $ step arg
    
    3800
    -  where
    
    3801
    -  step []         = doContinue GHC.StepOut
    
    3802
    -  step expression = stepCmd expression
    
    3799
    +stepOutCmd _ = withSandboxOnly ":stepout" $ doContinue GHC.StepOut
    
    3803 3800
     
    
    3804 3801
     stepLocalCmd :: GhciMonad m => String -> m ()
    
    3805 3802
     stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
    

  • libraries/ghci/GHCi/Run.hs
    ... ... @@ -202,7 +202,7 @@ doSeq ref = do
    202 202
     resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())
    
    203 203
     resumeSeq hvref = do
    
    204 204
         ResumeContext{..} <- localRef hvref
    
    205
    -    withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $
    
    205
    +    withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar (Just resumeThreadId) $
    
    206 206
           mask_ $ do
    
    207 207
             putMVar resumeBreakMVar () -- this awakens the stopped thread...
    
    208 208
             redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar
    
    ... ... @@ -231,7 +231,7 @@ sandboxIO opts io = do
    231 231
       -- We are running in uninterruptibleMask
    
    232 232
       breakMVar <- newEmptyMVar
    
    233 233
       statusMVar <- newEmptyMVar
    
    234
    -  withBreakAction opts breakMVar statusMVar $ do
    
    234
    +  withBreakAction opts breakMVar statusMVar Nothing $ do
    
    235 235
         let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
    
    236 236
         if useSandboxThread opts
    
    237 237
            then do
    
    ... ... @@ -326,8 +326,8 @@ tryEval io = do
    326 326
     -- resets everything when the computation has stopped running.  This
    
    327 327
     -- is a not-very-good way to ensure that only the interactive
    
    328 328
     -- evaluation should generate breakpoints.
    
    329
    -withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
    
    330
    -withBreakAction opts breakMVar statusMVar act
    
    329
    +withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> Maybe ThreadId {-^ If resuming, the current threadId -} -> IO a -> IO a
    
    330
    +withBreakAction opts breakMVar statusMVar mtid act
    
    331 331
      = bracket setBreakAction resetBreakAction (\_ -> act)
    
    332 332
      where
    
    333 333
        setBreakAction = do
    
    ... ... @@ -336,8 +336,10 @@ withBreakAction opts breakMVar statusMVar act
    336 336
          when (breakOnException opts) $ poke exceptionFlag 1
    
    337 337
          when (singleStep opts) rts_enableStopNextBreakpointAll
    
    338 338
          when (stepOut opts) $ do
    
    339
    -      ThreadId tid <- myThreadId
    
    340
    -      rts_enableStopAfterReturn tid
    
    339
    +      case mtid of
    
    340
    +        Nothing -> rts_enableStopNextBreakpointAll -- just enable single-step when no thread is stopped
    
    341
    +        Just (ThreadId tid) -> do
    
    342
    +          rts_enableStopAfterReturn tid
    
    341 343
          return stablePtr
    
    342 344
             -- Breaking on exceptions is not enabled by default, since it
    
    343 345
             -- might be a bit surprising.  The exception flag is turned off
    
    ... ... @@ -369,10 +371,9 @@ withBreakAction opts breakMVar statusMVar act
    369 371
          poke breakPointIOAction noBreakStablePtr
    
    370 372
          poke exceptionFlag 0
    
    371 373
          rts_disableStopNextBreakpointAll
    
    372
    -
    
    373
    -     ThreadId tid <- myThreadId
    
    374
    -     rts_disableStopAfterReturn tid
    
    375
    -
    
    374
    +     case mtid of
    
    375
    +      Just (ThreadId tid) -> rts_disableStopAfterReturn tid
    
    376
    +      _                   -> pure ()
    
    376 377
          freeStablePtr stablePtr
    
    377 378
     
    
    378 379
     resumeStmt
    
    ... ... @@ -380,7 +381,7 @@ resumeStmt
    380 381
       -> IO (EvalStatus [HValueRef])
    
    381 382
     resumeStmt opts hvref = do
    
    382 383
       ResumeContext{..} <- localRef hvref
    
    383
    -  withBreakAction opts resumeBreakMVar resumeStatusMVar $
    
    384
    +  withBreakAction opts resumeBreakMVar resumeStatusMVar (Just resumeThreadId) $
    
    384 385
         mask_ $ do
    
    385 386
           putMVar resumeBreakMVar () -- this awakens the stopped thread...
    
    386 387
           redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar
    

  • rts/Debugger.cmm
    ... ... @@ -29,8 +29,8 @@ import CLOSURE stg_stop_after_ret_frame_info;
    29 29
      *
    
    30 30
      * See Note [Debugger: Step-out] for details.
    
    31 31
      */
    
    32
    -INFO_TABLE_RET (stg_stop_after_ret_frame, RET_SMALL)
    
    33
    -    return (/* no return values */)
    
    32
    +INFO_TABLE_RET (stg_stop_after_ret_frame, RET_SMALL, W_ info_ptr)
    
    33
    +    /* no args => explicit stack */
    
    34 34
     {
    
    35 35
     
    
    36 36
         /* 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)
    40 40
         StgTSO_flags(CurrentTSO) =
    
    41 41
            %lobits32( TO_W_(StgTSO_flags(CurrentTSO)) | TSO_STOP_NEXT_BREAKPOINT );
    
    42 42
     
    
    43
    -
    
    44 43
         /* After enabling the single step mode, execution is resumed by returning
    
    45
    -     * to the frame this one intercepted. */
    
    44
    +     * to the frame this one intercepted.
    
    45
    +     *
    
    46
    +     * Note: Arguments passed to the frame we intercepted must be propagated,
    
    47
    +     * and the floating point registers untouched! See Note [Frames intercepting frames].
    
    48
    +     */
    
    49
    +    Sp = Sp + SIZEOF_StgStopAfterRetFrame;
    
    50
    +    jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live!
    
    46 51
     }

  • rts/Interpreter.c
    ... ... @@ -562,7 +562,7 @@ interpretBCO (Capability* cap)
    562 562
         if (cap->r.rCurrentTSO->flags & TSO_STOP_AFTER_RETURN) {
    
    563 563
     
    
    564 564
           StgPtr frame;
    
    565
    -      frame = cap->r.rCurrentTSO->stackobj->sp;
    
    565
    +      frame = Sp;
    
    566 566
     
    
    567 567
           // Insert the stg_stop_after_ret_frame after the first frame that is NOT a
    
    568 568
           // case continuation BCO.
    
    ... ... @@ -573,18 +573,23 @@ interpretBCO (Capability* cap)
    573 573
           while (*frame == (W_)&stg_CASE_CONT_BCO_info) {
    
    574 574
             frame += stack_frame_sizeW((StgClosure *)frame);
    
    575 575
           }
    
    576
    -      // New frame goes right after the first non-case-cont frame
    
    576
    +      // New frame goes /right after the first/ non-case-cont frame
    
    577 577
           frame += stack_frame_sizeW((StgClosure *)frame);
    
    578 578
     
    
    579 579
           // TODO: Handle stack bottom edge case!? if frame == STACK BOTTOM...
    
    580 580
     
    
    581 581
           // Make space for the new frame
    
    582
    +      memmove((W_*)Sp - sizeofW(StgStopAfterRetFrame), Sp, (uint8_t*)frame - (uint8_t*)Sp);
    
    582 583
           Sp_subW(sizeofW(StgStopAfterRetFrame));
    
    583
    -      memmove(frame-sizeof(StgStopAfterRetFrame), frame, (uint8_t*)cap->r.rCurrentTSO->stackobj->sp - (uint8_t*)frame);
    
    584
    +
    
    585
    +      // Point to newly opened space
    
    586
    +      frame -= sizeofW(StgStopAfterRetFrame);
    
    584 587
     
    
    585 588
           // Then write it.
    
    586 589
           ((StgStopAfterRetFrame*)frame)->header.info = &stg_stop_after_ret_frame_info;
    
    587 590
     
    
    591
    +      // TODO: Write profiling info if needed
    
    592
    +
    
    588 593
           // Frame was pushed, mark as done to not do it again
    
    589 594
           cap->r.rCurrentTSO->flags &= ~TSO_STOP_AFTER_RETURN;
    
    590 595
         }
    
    ... ... @@ -640,7 +645,6 @@ interpretBCO (Capability* cap)
    640 645
         //
    
    641 646
         // [1] An StgBCO's info table pointer may also be stg_CASE_CONT_BCO_info.
    
    642 647
         //      See Note [Case continuation BCOs].
    
    643
    -    //
    
    644 648
         else if (SpW(0) == (W_)&stg_apply_interp_info) {
    
    645 649
             obj = UNTAG_CLOSURE((StgClosure *)ReadSpW(1));
    
    646 650
             Sp_addW(2);
    

  • rts/StgMiscClosures.cmm
    ... ... @@ -53,21 +53,12 @@ INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL,
    53 53
     {
    
    54 54
     
    
    55 55
         /*
    
    56
    -
    
    57 56
         !!!!!!!!!!!!!!!!!
    
    58 57
         !!! IMPORTANT !!!
    
    59 58
         !!!!!!!!!!!!!!!!!
    
    60 59
     
    
    61 60
         The body of this function MUST NOT use any floating-point
    
    62
    -    or vector registers. DO NOT add any e.g. debug printing logic that
    
    63
    -    has any chance whatsoever of using floating-point or vector registers.
    
    64
    -    If you DO want to edit the function in such a way that it may use
    
    65
    -    vector registers, you will need to define multiple different copies
    
    66
    -    of this function, as we do e.g. for stg_stack_underflow_frame
    
    67
    -    (see Jumps.h).
    
    68
    -
    
    69
    -    See Note [realArgRegsCover] in GHC.Cmm.CallConv for more details.
    
    70
    -
    
    61
    +    or vector registers. See Note [Frames intercepting frames].
    
    71 62
         */
    
    72 63
     
    
    73 64
         unwind Sp = W_[Sp + SIZEOF_StgOrigThunkInfoFrame];
    
    ... ... @@ -75,6 +66,30 @@ INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL,
    75 66
         jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live!
    
    76 67
     }
    
    77 68
     
    
    69
    +/*
    
    70
    +Note [Frames intercepting frames]
    
    71
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    72
    +A frame which "intercepts" the following frame (to do additional work or
    
    73
    +manipulate the stack, such as `stg_orig_thunk_info_frame` or
    
    74
    +`stg_stop_after_ret_frame`) must take care to passthrough all the registers and
    
    75
    +arguments when it returns to the next frame. This is done by jumping with
    
    76
    +GP_ARG_REGS as in:
    
    77
    +
    
    78
    +    jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live!
    
    79
    +
    
    80
    +However, special care must be taken when these arguments are propagated:
    
    81
    +
    
    82
    +The body of such a function MUST NOT use any floating-point
    
    83
    +or vector registers. DO NOT add any e.g. debug printing logic that
    
    84
    +has any chance whatsoever of using floating-point or vector registers.
    
    85
    +If you DO want to edit the function in such a way that it may use
    
    86
    +vector registers, you will need to define multiple different copies
    
    87
    +of the function, as we do e.g. for stg_stack_underflow_frame
    
    88
    +(see Jumps.h).
    
    89
    +
    
    90
    +See Note [realArgRegsCover] in GHC.Cmm.CallConv for more details.
    
    91
    +*/
    
    92
    +
    
    78 93
     /* ----------------------------------------------------------------------------
    
    79 94
        Restore a saved cost centre
    
    80 95
        ------------------------------------------------------------------------- */
    

  • utils/deriveConstants/Main.hs
    ... ... @@ -518,6 +518,8 @@ wanteds os = concat
    518 518
     
    
    519 519
               ,closureFieldGcptr C "StgInd" "indirectee"
    
    520 520
     
    
    521
    +          ,closureSize  C "StgStopAfterRetFrame"
    
    522
    +
    
    521 523
               ,closureSize  C "StgMutVar"
    
    522 524
               ,closureField C "StgMutVar" "var"
    
    523 525