Ben Gamari pushed to branch wip/loop-backtrace at Glasgow Haskell Compiler / GHC

Commits:

14 changed files:

Changes:

  • libraries/base/src/Control/Exception/Base.hs
    ... ... @@ -85,7 +85,6 @@ module Control.Exception.Base
    85 85 
          patError,
    86 86 
          noMethodBindingError,
    87 87 
          typeError,
    88 
    -     nonTermination,
    89 88 
          nestedAtomically,
    90 89 
          noMatchingContinuationPrompt
    91 90 
          ) where

  • libraries/ghc-internal/cbits/Stack.cmm
    ... ... @@ -3,6 +3,10 @@
    3 3
    4 4 
     #include "Cmm.h"
    5 5
    6 
    +#if !defined(UnregisterisedCompiler)
    7 
    +import CLOSURE stg_orig_thunk_info_frame_info;
    8 
    +#endif
    9 
    +
    6 10 
     // StgStack_marking was not available in the Stage0 compiler at the time of
    7 11 
     // writing. Because, it has been added to derivedConstants when Stack.cmm was
    8 12 
     // developed.
    ... ... @@ -168,6 +172,18 @@ getStackInfoTableAddrzh(P_ stack) {
    168 172 
       return (info);
    169 173 
     }
    170 174
    175 
    +// (StgInfoTable*) getOrigThunkInfoPtrzh(StgStack* stack, StgWord offsetWords)
    176 
    +getOrigThunkInfoPtrzh(P_ stack, W_ offsetWords) {
    177 
    +  P_ p;
    178 
    +  p = StgStack_sp(stack) + WDS(offsetWords);
    179 
    +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
    180 
    +  if (%INFO_PTR(UNTAG(p)) == stg_orig_thunk_info_frame_info) {
    181 
    +    return (StgOrigThunkInfoFrame_info_ptr(UNTAG(p)));
    182 
    +  } else {
    183 
    +    return (NULL);
    184 
    +  }
    185 
    +}
    186 
    +
    171 187 
     // (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords)
    172 188 
     getStackClosurezh(P_ stack, W_ offsetWords) {
    173 189 
       P_ ptr;

  • libraries/ghc-internal/include/RtsIfaceSymbols.h
    ... ... @@ -20,7 +20,7 @@ CLOSURE(GHCziInternalziIOziException, blockedIndefinitelyOnSTM_closure)
    20 20 
     CLOSURE(GHCziInternalziIOziException, cannotCompactFunction_closure)
    21 21 
     CLOSURE(GHCziInternalziIOziException, cannotCompactPinned_closure)
    22 22 
     CLOSURE(GHCziInternalziIOziException, cannotCompactMutable_closure)
    23 
    -CLOSURE(GHCziInternalziControlziExceptionziBase, nonTermination_closure)
    23 
    +CLOSURE(GHCziInternalziControlziExceptionziBase, nonTerminationError_closure)
    24 24 
     CLOSURE(GHCziInternalziControlziExceptionziBase, nestedAtomically_closure)
    25 25 
     CLOSURE(GHCziInternalziControlziExceptionziBase, noMatchingContinuationPrompt_closure)
    26 26 
     #if defined(mingw32_HOST_OS)

  • libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs
    ... ... @@ -108,7 +108,7 @@ module GHC.Internal.Control.Exception.Base (
    108 108 
             impossibleError, impossibleConstraintError,
    109 109 
             nonExhaustiveGuardsError, patError, noMethodBindingError,
    110 110 
             typeError,
    111 
    -        nonTermination, nestedAtomically, noMatchingContinuationPrompt,
    111 
    +        nonTerminationError, nestedAtomically, noMatchingContinuationPrompt,
    112 112 
       ) where
    113 113
    114 114 
     import           GHC.Internal.Base (
    ... ... @@ -448,8 +448,9 @@ impossibleConstraintError s = errorWithoutStackTrace (unpackCStringUtf8# s)
    448 448
    449 449
    450 450 
     -- GHC's RTS calls this
    451 
    -nonTermination :: SomeException
    452 
    -nonTermination = toException NonTermination
    451 
    +nonTerminationError :: IO ()
    452 
    +nonTerminationError = throwIO NonTermination
    453 
    +
    453 454
    454 455 
     -- GHC's RTS calls this
    455 456 
     nestedAtomically :: SomeException

  • libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
    ... ... @@ -568,6 +568,17 @@ data GenStackFrame b =
    568 568 
           , stack_payload       :: ![GenStackField b]
    569 569 
           }
    570 570
    571 
    +  -- | An @stg_orig_thunk_info_frame@ pushed by @-forig-thunk-info@. It records
    572 
    +  -- the original info table of the thunk being updated (in 'orig_info_tbl'),
    573 
    +  -- which is otherwise lost when the thunk is blackholed.
    574 
    +  -- See @Note [Original thunk info table frames]@ in "GHC.StgToCmm.Bind".
    575 
    +  | OrigThunkInfo
    576 
    +      { info_tbl            :: !StgInfoTable
    577 
    +        -- ^ the frame's own (RTS) info table
    578 
    +      , orig_info_tbl       :: !(Ptr StgInfoTable)
    579 
    +        -- ^ the original info table of the thunk being updated
    580 
    +      }
    581 
    +
    571 582 
       | RetFun
    572 583 
           { info_tbl            :: !StgInfoTable
    573 584 
           , retFunSize          :: !Word

  • libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
    ... ... @@ -192,6 +192,16 @@ foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -
    192 192
    193 193 
     foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
    194 194
    195 
    +foreign import prim "getOrigThunkInfoPtrzh" getOrigThunkInfoPtr# :: StackSnapshot# -> Word# -> Addr#
    196 
    +
    197 
    +-- | @'Just' itbl@ if the frame at the given offset is an
    198 
    +-- @stg_orig_thunk_info_frame@ (where @itbl@ is the recorded original thunk info
    199 
    +-- table), otherwise 'Nothing'. See @Note [Decoding orig_thunk_info frames]@.
    200 
    +origThunkInfoFrame :: StackSnapshot# -> WordOffset -> Maybe (Ptr StgInfoTable)
    201 
    +origThunkInfoFrame stackSnapshot# index =
    202 
    +  let p = Ptr (getOrigThunkInfoPtr# stackSnapshot# (wordOffsetToWord# index))
    203 
    +  in if p == nullPtr then Nothing else Just p
    204 
    +
    195 205 
     -- | Get the 'StgInfoTable' of the stack frame.
    196 206 
     -- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any.
    197 207 
     getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv)
    ... ... @@ -380,6 +390,15 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
    380 390 
                     bco = bco',
    381 391 
                     bcoArgs = bcoArgs'
    382 392 
                   }
    393 
    +        RET_SMALL
    394 
    +          | Just orig_itbl <- origThunkInfoFrame stackSnapshot# index -> do
    395 
    +            orig_info_prov <- lookupIPE (castPtr orig_itbl)
    396 
    +            finaliseStackFrame
    397 
    +              OrigThunkInfo
    398 
    +                { info_tbl = info,
    399 
    +                  orig_info_tbl = orig_itbl
    400 
    +                }
    401 
    +              orig_info_prov
    383 402 
             RET_SMALL ->
    384 403 
               let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
    385 404 
               in

  • rts/Prelude.h
    ... ... @@ -58,7 +58,7 @@ extern StgClosure ZCMain_main_closure;
    58 58 
     #define cannotCompactFunction_closure ghc_hs_iface->cannotCompactFunction_closure
    59 59 
     #define cannotCompactPinned_closure ghc_hs_iface->cannotCompactPinned_closure
    60 60 
     #define cannotCompactMutable_closure ghc_hs_iface->cannotCompactMutable_closure
    61 
    -#define nonTermination_closure    ghc_hs_iface->nonTermination_closure
    61 
    +#define nonTerminationError_closure    ghc_hs_iface->nonTerminationError_closure
    62 62 
     #define nestedAtomically_closure  ghc_hs_iface->nestedAtomically_closure
    63 63 
     #define absentSumFieldError_closure ghc_hs_iface->absentSumFieldError_closure
    64 64 
     #define underflowException_closure ghc_hs_iface->underflowException_closure

  • rts/RtsStartup.c
    ... ... @@ -193,7 +193,7 @@ static void initBuiltinGcRoots(void)
    193 193 
         getStablePtr((StgPtr)heapOverflow_closure);
    194 194 
         getStablePtr((StgPtr)unpackCString_closure);
    195 195 
         getStablePtr((StgPtr)blockedIndefinitelyOnMVar_closure);
    196 
    -    getStablePtr((StgPtr)nonTermination_closure);
    196 
    +    getStablePtr((StgPtr)nonTerminationError_closure);
    197 197 
         getStablePtr((StgPtr)blockedIndefinitelyOnSTM_closure);
    198 198 
         getStablePtr((StgPtr)allocationLimitExceeded_closure);
    199 199 
         getStablePtr((StgPtr)cannotCompactFunction_closure);

  • rts/Schedule.c
    ... ... @@ -3276,6 +3276,17 @@ findAtomicallyFrameHelper (Capability *cap, StgTSO *tso)
    3276 3276 
       }
    3277 3277 
     }
    3278 3278
    3279 
    +static void throwNontermination(Capability *cap, StgTSO *tso) {
    3280 
    +  StgStack *stack = tso->stackobj;
    3281 
    +  stack->sp -= 3;
    3282 
    +  stack->sp[0] = (W_)&stg_enter_info;
    3283 
    +  stack->sp[1] = (W_)nonTerminationError_closure;
    3284 
    +  stack->sp[2] = (W_)&stg_ap_v_info;
    3285 
    +  tso->why_blocked = NotBlocked;
    3286 
    +  appendToRunQueue(cap,tso);
    3287 
    +}
    3288 
    +
    3289 
    +
    3279 3290 
     /* -----------------------------------------------------------------------------
    3280 3291 
        resurrectThreads is called after garbage collection on the list of
    3281 3292 
        threads found to be garbage.  Each of these threads will be woken
    ... ... @@ -3313,8 +3324,7 @@ resurrectThreads (StgTSO *threads)
    3313 3324 
                                       (StgClosure *)blockedIndefinitelyOnMVar_closure);
    3314 3325 
                 break;
    3315 3326 
             case BlockedOnBlackHole:
    3316 
    -            throwToSingleThreaded(cap, tso,
    3317 
    -                                  (StgClosure *)nonTermination_closure);
    3327 
    +            throwNontermination(cap, tso);
    3318 3328 
                 break;
    3319 3329 
             case BlockedOnSTM:
    3320 3330 
                 throwToSingleThreaded(cap, tso,

  • rts/include/rts/RtsToHsIface.h
    ... ... @@ -25,7 +25,7 @@ typedef struct {
    25 25 
         StgClosure *cannotCompactFunction_closure;  // GHC.Internal.IO.Exception.cannotCompactFunction_closure
    26 26 
         StgClosure *cannotCompactPinned_closure;  // GHC.Internal.IO.Exception.cannotCompactPinned_closure
    27 27 
         StgClosure *cannotCompactMutable_closure;  // GHC.Internal.IO.Exception.cannotCompactMutable_closure
    28 
    -    StgClosure *nonTermination_closure;  // GHC.Internal.Control.Exception.Base.nonTermination_closure
    28 
    +    StgClosure *nonTerminationError_closure;  // GHC.Internal.Control.Exception.Base.nonTerminationError_closure
    29 29 
         StgClosure *nestedAtomically_closure;  // GHC.Internal.Control.Exception.Base.nestedAtomically_closure
    30 30 
         StgClosure *noMatchingContinuationPrompt_closure;  // GHC.Internal.Control.Exception.Base.noMatchingContinuationPrompt_closure
    31 31 
         StgClosure *blockedOnBadFD_closure;  // GHC.Internal.Event.Thread.blockedOnBadFD_closure

  • testsuite/tests/rts/LoopBacktrace.hs
    1 
    +{-# OPTIONS_GHC -finfo-table-map -forig-thunk-info #-}
    2 
    +
    3 
    +import GHC.Exception.Backtrace.Experimental
    4 
    +
    5 
    +x :: Integer
    6 
    +x = x + 1
    7 
    +
    8 
    +testing :: IO ()
    9 
    +testing = do
    10 
    +  putStrLn "hello"
    11 
    +  print x
    12 
    +  putStrLn "world"
    13 
    +
    14 
    +main :: IO ()
    15 
    +main = do
    16 
    +  setBacktraceMechanismState IPEBacktrace True
    17 
    +  testing

  • testsuite/tests/rts/LoopBacktrace.stderr
    1 
    +LoopBacktrace: Uncaught exception ghc-internal:GHC.Internal.Control.Exception.Base.NonTermination:
    2 
    +
    3 
    +<<loop>>
    4 
    +
    5 
    +IPE backtrace:
    6 
    +  GHC.Internal.Exception.Backtrace.collectBacktraces' (libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs:(179,1)-(202,25))
    7 
    +  GHC.Internal.Exception.Backtrace.collectBacktraces (libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs:174:39-56)
    8 
    +  GHC.Internal.Exception.toExceptionWithBacktrace (libraries/ghc-internal/src/GHC/Internal/Exception.hs:(179,26)-(181,53))
    9 
    +  GHC.Internal.IO.throwIO (libraries/ghc-internal/src/GHC/Internal/IO.hs:293:36)
    10 
    +  Cmm$rts/HeapStackCheck.cmm. (:)
    11 
    +  GHC.Internal.Bignum.Integer.integerAdd (libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs:(547,1)-(571,52))
    12 
    +  Cmm$rts/Updates.cmm. (:)
    13 
    +  Main.x (LoopBacktrace.hs:6:1-9)
    14 
    +  GHC.Internal.Show.show (libraries/ghc-internal/src/GHC/Internal/Show.hs:497:10-21)
    15 
    +  GHC.Internal.IO.Handle.Text.hPutStr' (libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs:667:29-37)
    16 
    +  GHC.Internal.Base.thenIO (libraries/ghc-internal/src/GHC/Internal/Base.hs:2337:1-72)
    17 
    +  Cmm$rts/Exception.cmm. (:)
    18 
    +  Cmm$rts/StgStartup.cmm. (:)
    19 
    +HasCallStack backtrace:
    20 
    +  throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:452:23 in ghc-internal:GHC.Internal.Control.Exception.Base
    21 
    +

  • testsuite/tests/rts/LoopBacktrace.stdout
    1 
    +hello

  • testsuite/tests/rts/all.T
    ... ... @@ -687,3 +687,5 @@ test('ClosureTable',
    687 687 
          ['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include'])
    688 688
    689 689 
     test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, [''])
    690 
    +
    691 
    +test('LoopBacktrace', [exit_code(1)], compile_and_run, [''])

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