Rodrigo Mesquita pushed to branch wip/romes/per-thread-step-in at Glasgow Haskell Compiler / GHC

Commits:

11 changed files:

Changes:

  • libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
    ... ... @@ -624,6 +624,7 @@ data TsoFlags
    624 624 
       | TsoMarked
    625 625 
       | TsoSqueezed
    626 626 
       | TsoAllocLimit
    627 
    +  | TsoStopNextBreakpoint
    627 628 
       | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug
    628 629 
       deriving (Eq, Show, Generic, Ord)
    629 630

  • libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
    ... ... @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset
    87 87 
                     | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)
    88 88 
                     | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)
    89 89 
                     | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)
    90 
    +#if __GLASGOW_HASKELL__ >= 913
    91 
    +                | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w)
    92 
    +#endif
    90 93 
     parseTsoFlags 0 = []
    91 94 
     parseTsoFlags w = [TsoFlagsUnknownValue w]
    92 95

  • libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
    ... ... @@ -87,6 +87,9 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset
    87 87 
                     | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)
    88 88 
                     | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)
    89 89 
                     | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)
    90 
    +#if __GLASGOW_HASKELL__ >= 913
    91 
    +                | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w)
    92 
    +#endif
    90 93 
     parseTsoFlags 0 = []
    91 94 
     parseTsoFlags w = [TsoFlagsUnknownValue w]
    92 95

  • libraries/ghc-heap/tests/parse_tso_flags.hs
    ... ... @@ -13,5 +13,6 @@ main = do
    13 13 
         assertEqual (parseTsoFlags 64) [TsoMarked]
    14 14 
         assertEqual (parseTsoFlags 128) [TsoSqueezed]
    15 15 
         assertEqual (parseTsoFlags 256) [TsoAllocLimit]
    16 
    +    assertEqual (parseTsoFlags 512) [TsoStopNextBreakpoint]
    16 17
    17 18 
         assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx]

  • libraries/ghci/GHCi/Debugger.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +{-# LANGUAGE UnliftedFFITypes #-}
    3 
    +module GHCi.Debugger
    4 
    +  (
    5 
    +  -- * Single step mode
    6 
    +    rts_enableStopNextBreakpoint
    7 
    +  , rts_enableStopNextBreakpointAll
    8 
    +  , rts_disableStopNextBreakpoint
    9 
    +  , rts_disableStopNextBreakpointAll
    10 
    +
    11 
    +  -- * Stop on exception
    12 
    +  , exceptionFlag
    13 
    +
    14 
    +  -- * Breakpoint Callback
    15 
    +  , BreakpointCallback
    16 
    +  , breakPointIOAction
    17 
    +  ) where
    18 
    +
    19 
    +import Prelude -- See note [Why do we import Prelude here?]
    20 
    +
    21 
    +import GHC.Base (ThreadId#, Addr#, Int#)
    22 
    +import Foreign.C (CInt)
    23 
    +import Foreign (StablePtr, Ptr)
    24 
    +import GHCi.RemoteTypes (HValue)
    25 
    +
    26 
    +--------------------------------------------------------------------------------
    27 
    +-- Single step mode
    28 
    +
    29 
    +-- | Enables the single step mode for a specific thread, thus stopping only on
    30 
    +-- breakpoints in that thread.
    31 
    +foreign import ccall unsafe "rts_enableStopNextBreakpoint"
    32 
    +  rts_enableStopNextBreakpoint :: ThreadId# -> IO ()
    33 
    +
    34 
    +-- | Disables per-thread single-step mode. Note: if global single-step is
    35 
    +-- enabled we stop at all breakpoints regardless of the per-thread flag.
    36 
    +foreign import ccall unsafe "rts_disableStopNextBreakpoint"
    37 
    +  rts_disableStopNextBreakpoint :: ThreadId# -> IO ()
    38 
    +
    39 
    +-- | Enables the single step mode for all threads, thus stopping at any
    40 
    +-- existing breakpoint.
    41 
    +foreign import ccall unsafe "rts_enableStopNextBreakpointAll"
    42 
    +  rts_enableStopNextBreakpointAll :: IO ()
    43 
    +
    44 
    +-- | Disables the single step mode for all threads
    45 
    +foreign import ccall unsafe "rts_disableStopNextBreakpointAll"
    46 
    +  rts_disableStopNextBreakpointAll :: IO ()
    47 
    +
    48 
    +--------------------------------------------------------------------------------
    49 
    +
    50 
    +foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
    51 
    +
    52 
    +--------------------------------------------------------------------------------
    53 
    +
    54 
    +type BreakpointCallback
    55 
    +     = Addr#   -- pointer to the breakpoint tick module name
    56 
    +    -> Addr#   -- pointer to the breakpoint tick module unit id
    57 
    +    -> Int#    -- breakpoint tick index
    58 
    +    -> Addr#   -- pointer to the breakpoint info module name
    59 
    +    -> Addr#   -- pointer to the breakpoint info module unit id
    60 
    +    -> Int#    -- breakpoint info index
    61 
    +    -> Bool    -- exception?
    62 
    +    -> HValue  -- the AP_STACK, or exception
    63 
    +    -> IO ()
    64 
    +
    65 
    +foreign import ccall "&rts_breakpoint_io_action"
    66 
    +   breakPointIOAction :: Ptr (StablePtr BreakpointCallback)
    67 
    +

  • libraries/ghci/GHCi/Run.hs
    1 1 
     {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
    2 
    -    UnboxedTuples, LambdaCase #-}
    2 
    +    UnboxedTuples, LambdaCase, UnliftedFFITypes #-}
    3 3 
     {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
    4 4
    5 5 
     -- |
    ... ... @@ -20,6 +20,7 @@ import GHCi.InfoTable
    20 20 
     #endif
    21 21
    22 22 
     import qualified GHC.InfoProv as InfoProv
    23 
    +import GHCi.Debugger
    23 24 
     import GHCi.FFI
    24 25 
     import GHCi.Message
    25 26 
     import GHCi.ObjLink
    ... ... @@ -332,7 +333,7 @@ withBreakAction opts breakMVar statusMVar act
    332 333 
          stablePtr <- newStablePtr onBreak
    333 334 
          poke breakPointIOAction stablePtr
    334 335 
          when (breakOnException opts) $ poke exceptionFlag 1
    335 
    -     when (singleStep opts) $ setStepFlag
    336 
    +     when (singleStep opts) rts_enableStopNextBreakpointAll
    336 337 
          return stablePtr
    337 338 
             -- Breaking on exceptions is not enabled by default, since it
    338 339 
             -- might be a bit surprising.  The exception flag is turned off
    ... ... @@ -363,7 +364,7 @@ withBreakAction opts breakMVar statusMVar act
    363 364 
        resetBreakAction stablePtr = do
    364 365 
          poke breakPointIOAction noBreakStablePtr
    365 366 
          poke exceptionFlag 0
    366 
    -     resetStepFlag
    367 
    +     rts_disableStopNextBreakpointAll
    367 368 
          freeStablePtr stablePtr
    368 369
    369 370 
     resumeStmt
    ... ... @@ -396,28 +397,6 @@ abandonStmt hvref = do
    396 397 
       _ <- takeMVar resumeStatusMVar
    397 398 
       return ()
    398 399
    399 
    -foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
    400 
    -foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt
    401 
    -
    402 
    -setStepFlag :: IO ()
    403 
    -setStepFlag = poke stepFlag 1
    404 
    -resetStepFlag :: IO ()
    405 
    -resetStepFlag = poke stepFlag 0
    406 
    -
    407 
    -type BreakpointCallback
    408 
    -     = Addr#   -- pointer to the breakpoint tick module name
    409 
    -    -> Addr#   -- pointer to the breakpoint tick module unit id
    410 
    -    -> Int#    -- breakpoint tick index
    411 
    -    -> Addr#   -- pointer to the breakpoint info module name
    412 
    -    -> Addr#   -- pointer to the breakpoint info module unit id
    413 
    -    -> Int#    -- breakpoint info index
    414 
    -    -> Bool    -- exception?
    415 
    -    -> HValue  -- the AP_STACK, or exception
    416 
    -    -> IO ()
    417 
    -
    418 
    -foreign import ccall "&rts_breakpoint_io_action"
    419 
    -   breakPointIOAction :: Ptr (StablePtr BreakpointCallback)
    420 
    -
    421 400 
     noBreakStablePtr :: StablePtr BreakpointCallback
    422 401 
     noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
    423 402

  • libraries/ghci/ghci.cabal.in
    ... ... @@ -60,6 +60,7 @@ library
    60 60 
             CPP-Options: -DHAVE_INTERNAL_INTERPRETER
    61 61 
             exposed-modules:
    62 62 
                 GHCi.Run
    63 
    +            GHCi.Debugger
    63 64 
                 GHCi.CreateBCO
    64 65 
                 GHCi.ObjLink
    65 66 
                 GHCi.Signals

  • rts/Interpreter.c
    ... ... @@ -243,9 +243,44 @@ allocate_NONUPD (Capability *cap, int n_words)
    243 243 
         return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
    244 244 
     }
    245 245
    246 
    -int rts_stop_next_breakpoint = 0;
    247 246 
     int rts_stop_on_exception = 0;
    248 247
    248 
    +/* ---------------------------------------------------------------------------
    249 
    + * Enabling and disabling global single step mode
    250 
    + * ------------------------------------------------------------------------ */
    251 
    +
    252 
    +/* A global toggle for single-step mode.
    253 
    + * Unlike `TSO_STOP_NEXT_BREAKPOINT`, which sets single-step mode per-thread,
    254 
    + * `rts_stop_next_breakpoint` globally enables single-step mode. If enabled, we
    255 
    + * will stop at the immediate next breakpoint regardless of what thread it is in. */
    256 
    +int rts_stop_next_breakpoint = 0;
    257 
    +
    258 
    +void rts_enableStopNextBreakpointAll(void)
    259 
    +{
    260 
    +  rts_stop_next_breakpoint = 1;
    261 
    +}
    262 
    +
    263 
    +void rts_disableStopNextBreakpointAll(void)
    264 
    +{
    265 
    +  rts_stop_next_breakpoint = 0;
    266 
    +}
    267 
    +
    268 
    +/* ---------------------------------------------------------------------------
    269 
    + * Enabling and disabling per-thread single step mode
    270 
    + * ------------------------------------------------------------------------ */
    271 
    +
    272 
    +void rts_enableStopNextBreakpoint(StgPtr tso)
    273 
    +{
    274 
    +    ((StgTSO *)tso)->flags |= TSO_STOP_NEXT_BREAKPOINT;
    275 
    +}
    276 
    +
    277 
    +void rts_disableStopNextBreakpoint(StgPtr tso)
    278 
    +{
    279 
    +    ((StgTSO *)tso)->flags &= ~TSO_STOP_NEXT_BREAKPOINT;
    280 
    +}
    281 
    +
    282 
    +/* -------------------------------------------------------------------------- */
    283 
    +
    249 284 
     #if defined(INTERP_STATS)
    250 285
    251 286 
     #define N_CODES 128
    ... ... @@ -1250,7 +1285,7 @@ run_BCO:
    1250 1285 
                 int arg8_cc;
    1251 1286 
     #endif
    1252 1287 
                 StgArrBytes *breakPoints;
    1253 
    -            int returning_from_break;
    1288 
    +            int returning_from_break, stop_next_breakpoint;
    1254 1289
    1255 1290 
                 // the io action to run at a breakpoint
    1256 1291 
                 StgClosure *ioAction;
    ... ... @@ -1280,6 +1315,13 @@ run_BCO:
    1280 1315 
                 returning_from_break =
    1281 1316 
                     cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
    1282 1317
    1318 
    +            // check whether this thread is set to stop at the immediate next
    1319 
    +            // breakpoint -- either by the global `rts_stop_next_breakpoint`
    1320 
    +            // flag, or by the local `TSO_STOP_NEXT_BREAKPOINT`
    1321 
    +            stop_next_breakpoint =
    1322 
    +              rts_stop_next_breakpoint ||
    1323 
    +                cap->r.rCurrentTSO->flags & TSO_STOP_NEXT_BREAKPOINT;
    1324 
    +
    1283 1325 
     #if defined(PROFILING)
    1284 1326 
                 cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
    1285 1327 
                                               (CostCentre*)BCO_LIT(arg8_cc));
    ... ... @@ -1291,20 +1333,20 @@ run_BCO:
    1291 1333 
                 {
    1292 1334 
                    breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array);
    1293 1335
    1294 
    -               // stop the current thread if either the
    1295 
    -               // "rts_stop_next_breakpoint" flag is true OR if the
    1296 
    -               // ignore count for this particular breakpoint is zero
    1336 
    +               // stop the current thread if either `stop_next_breakpoint` is
    1337 
    +               // true OR if the ignore count for this particular breakpoint is zero
    1297 1338 
                    StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
    1298 
    -               if (rts_stop_next_breakpoint == false && ignore_count > 0)
    1339 
    +               if (stop_next_breakpoint == false && ignore_count > 0)
    1299 1340 
                    {
    1300 1341 
                       // decrement and write back ignore count
    1301 1342 
                       ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
    1302 1343 
                    }
    1303 
    -               else if (rts_stop_next_breakpoint == true || ignore_count == 0)
    1344 
    +               else if (stop_next_breakpoint == true || ignore_count == 0)
    1304 1345 
                    {
    1305 1346 
                       // make sure we don't automatically stop at the
    1306 1347 
                       // next breakpoint
    1307 
    -                  rts_stop_next_breakpoint = false;
    1348 
    +                  rts_stop_next_breakpoint = 0;
    1349 
    +                  cap->r.rCurrentTSO->flags &= ~TSO_STOP_NEXT_BREAKPOINT;
    1308 1350
    1309 1351 
                       // allocate memory for a new AP_STACK, enough to
    1310 1352 
                       // store the top stack frame plus an

  • rts/Interpreter.h
    ... ... @@ -11,3 +11,8 @@
    11 11 
     RTS_PRIVATE Capability *interpretBCO (Capability* cap);
    12 12 
     void interp_startup ( void );
    13 13 
     void interp_shutdown ( void );
    14 
    +
    15 
    +void rts_enableStopNextBreakpointAll  ( void );
    16 
    +void rts_disableStopNextBreakpointAll ( void );
    17 
    +void rts_enableStopNextBreakpoint     ( StgPtr );
    18 
    +void rts_disableStopNextBreakpoint    ( StgPtr );

  • rts/RtsSymbols.c
    ... ... @@ -906,7 +906,10 @@ extern char **environ;
    906 906 
           SymI_HasProto(revertCAFs)                                         \
    907 907 
           SymI_HasProto(RtsFlags)                                           \
    908 908 
           SymI_NeedsDataProto(rts_breakpoint_io_action)                     \
    909 
    -      SymI_NeedsDataProto(rts_stop_next_breakpoint)                     \
    909 
    +      SymI_NeedsDataProto(rts_enableStopNextBreakpointAll)              \
    910 
    +      SymI_NeedsDataProto(rts_disableStopNextBreakpointAll)             \
    911 
    +      SymI_NeedsDataProto(rts_enableStopNextBreakpoint)                 \
    912 
    +      SymI_NeedsDataProto(rts_disableStopNextBreakpoint)                \
    910 913 
           SymI_NeedsDataProto(rts_stop_on_exception)                        \
    911 914 
           SymI_HasProto(stopTimer)                                          \
    912 915 
           SymI_HasProto(n_capabilities)                                     \

  • rts/include/rts/Constants.h
    ... ... @@ -328,6 +328,12 @@
    328 328 
      */
    329 329 
     #define TSO_ALLOC_LIMIT 256
    330 330
    331 
    +/*
    332 
    + * Enables step-in mode for this thread -- it will stop at the immediate next
    333 
    + * breakpoint found in this thread.
    334 
    + */
    335 
    +#define TSO_STOP_NEXT_BREAKPOINT 512
    336 
    +
    331 337 
     /*
    332 338 
      * The number of times we spin in a spin lock before yielding (see
    333 339 
      * #3758).  To tune this value, use the benchmark in #3758: run the

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help