Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • libraries/base/changelog.md
    ... ... @@ -24,6 +24,7 @@
    24 24 
       * Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329)
    25 25 
       * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376))
    26 26 
       * Add a new module `System.IO.OS` with operations for obtaining operating-system handles (file descriptors, Windows handles). ([CLC proposal #369](https://github.com/haskell/core-libraries-committee/issues/369))
    27 
    +  * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383))
    27 28
    28 29 
     ## 4.22.0.0 *TBA*
    29 30 
       * Shipped with GHC 9.14.1

  • libraries/ghc-internal/src/GHC/Internal/Err.hs
    1 1 
     {-# LANGUAGE Trustworthy #-}
    2 2 
     {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-}
    3 3 
     {-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-}
    4 
    +{-# LANGUAGE BangPatterns #-}
    4 5 
     {-# OPTIONS_HADDOCK not-home #-}
    5 6
    6 7 
     -----------------------------------------------------------------------------
    ... ... @@ -25,6 +26,7 @@
    25 26 
     module GHC.Internal.Err( absentErr, error, errorWithoutStackTrace, undefined ) where
    26 27 
     import GHC.Internal.Types (Char, RuntimeRep)
    27 28 
     import GHC.Internal.Stack.Types
    29 
    +import GHC.Internal.Magic
    28 30 
     import GHC.Internal.Prim
    29 31 
     import {-# SOURCE #-} GHC.Internal.Exception
    30 32 
       ( errorCallWithCallStackException
    ... ... @@ -33,7 +35,10 @@ import {-# SOURCE #-} GHC.Internal.Exception
    33 35 
     -- | 'error' stops execution and displays an error message.
    34 36 
     error :: forall (r :: RuntimeRep). forall (a :: TYPE r).
    35 37 
              HasCallStack => [Char] -> a
    36 
    -error s = raise# (errorCallWithCallStackException s ?callStack)
    38 
    +error s =
    39 
    +  -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw]
    40 
    +  let !se = noinline (errorCallWithCallStackException s ?callStack)
    41 
    +  in raise# se
    37 42 
               -- Bleh, we should be using 'GHC.Internal.Stack.callStack' instead of
    38 43 
               -- '?callStack' here, but 'GHC.Internal.Stack.callStack' depends on
    39 44 
               -- 'GHC.Internal.Stack.popCallStack', which is partial and depends on
    ... ... @@ -73,7 +78,10 @@ undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r).
    73 78 
     -- nor wanted (see #19886). We’d like to use withFrozenCallStack, but that
    74 79 
     -- is not available in this module yet, and making it so is hard. So let’s just
    75 80 
     -- use raise# directly.
    76 
    -undefined = raise# (errorCallWithCallStackException "Prelude.undefined" ?callStack)
    81 
    +undefined =
    82 
    +    -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw]
    83 
    +    let !se = noinline (errorCallWithCallStackException "Prelude.undefined" ?callStack)
    84 
    +    in raise# se
    77 85
    78 86 
     -- | Used for compiler-generated error message;
    79 87 
     -- encoding saves bytes of string junk.

  • libraries/ghc-internal/tests/stack-annotation/all.T
    ... ... @@ -8,3 +8,4 @@ test('ann_frame001', ann_frame_opts, compile_and_run, [''])
    8 8 
     test('ann_frame002', ann_frame_opts, compile_and_run, [''])
    9 9 
     test('ann_frame003', ann_frame_opts, compile_and_run, [''])
    10 10 
     test('ann_frame004', ann_frame_opts, compile_and_run, [''])
    11 
    +test('ann_frame005', ann_frame_opts, compile_and_run, [''])

  • libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs
    1 
    +import Control.Concurrent.STM
    2 
    +import Control.Exception
    3 
    +import Control.Exception.Backtrace (BacktraceMechanism(IPEBacktrace), setBacktraceMechanismState)
    4 
    +import Control.Exception.Context (displayExceptionContext)
    5 
    +import Control.Monad
    6 
    +import Data.List (isInfixOf)
    7 
    +import TestUtils
    8 
    +
    9 
    +data SimpleBoom = SimpleBoom deriving (Show)
    10 
    +
    11 
    +instance Exception SimpleBoom
    12 
    +
    13 
    +main :: IO ()
    14 
    +main = do
    15 
    +  setBacktraceMechanismState IPEBacktrace True
    16 
    +  mapM_ (uncurry runCase)
    17 
    +    [ ("throwIO SimpleBoom", throwIOAction)
    18 
    +    , ("undefined", undefinedAction)
    19 
    +    , ("error", errorAction)
    20 
    +    , ("throwSTM", throwSTMAction)
    21 
    +    ]
    22 
    +
    23 
    +runCase :: String -> IO () -> IO ()
    24 
    +runCase label action = do
    25 
    +  putStrLn ("=== " ++ label ++ " ===")
    26 
    +  annotateCallStackIO $
    27 
    +    annotateStackStringIO ("catch site for " ++ label) $
    28 
    +      catch action (handler label)
    29 
    +
    30 
    +throwIOAction :: IO ()
    31 
    +throwIOAction =
    32 
    +  annotateStackStringIO "raising action" $
    33 
    +    annotateStackStringIO "throwIO SimpleBoom" $
    34 
    +      throwIO SimpleBoom
    35 
    +
    36 
    +undefinedAction :: IO ()
    37 
    +undefinedAction =
    38 
    +  annotateStackStringIO "raising undefined action" $
    39 
    +    void $
    40 
    +      evaluate $
    41 
    +        annotateStackString "undefined thunk" (undefined :: Int)
    42 
    +
    43 
    +errorAction :: IO ()
    44 
    +errorAction =
    45 
    +  annotateStackStringIO "raising error action" $
    46 
    +    void $
    47 
    +      evaluate $
    48 
    +        annotateStackString "error thunk" (error "error from annotateStackString" :: Int)
    49 
    +
    50 
    +throwSTMAction :: IO ()
    51 
    +throwSTMAction =
    52 
    +  annotateStackStringIO "raising throwSTM action" $
    53 
    +    atomically $
    54 
    +      annotateStackString "throwSTM SimpleBoom" $
    55 
    +        throwSTM SimpleBoom
    56 
    +
    57 
    +handler :: String -> SomeException -> IO ()
    58 
    +handler label se =
    59 
    +  annotateStackStringIO ("handler for " ++ label) $
    60 
    +    annotateStackStringIO ("forcing SomeException for " ++ label) $ do
    61 
    +      message <- evaluate (displayException se)
    62 
    +      putStrLn ("Caught exception: " ++ message)
    63 
    +      let ctx = displayExceptionContext (someExceptionContext se)
    64 
    +          ctxLines = lines ctx
    65 
    +      putStrLn "Exception context:"
    66 
    +      case ctxLines of
    67 
    +        [] -> putStrLn "<empty>"
    68 
    +        ls -> mapM_ (putStrLn . ("- " ++)) ls
    69 
    +      let handlerTag = "handler for " ++ label
    70 
    +      -- Check that the callstack is from the callsite, not the handling site
    71 
    +      when (any (handlerTag `isInfixOf`) ctxLines) $
    72 
    +        error $ "handler annotation leaked into context for " ++ label
    73 
    +      putStrLn "Handler annotation not present in context"

  • libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout
    1 
    +=== throwIO SimpleBoom ===
    2 
    +Caught exception: SimpleBoom
    3 
    +Exception context:
    4 
    +- IPE backtrace:
    5 
    +-   throwIO SimpleBoom
    6 
    +-   raising action
    7 
    +-   catch site for throwIO SimpleBoom
    8 
    +-   annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main
    9 
    +- HasCallStack backtrace:
    10 
    +-   throwIO, called at ann_frame005.hs:34:7 in main:Main
    11 
    +Handler annotation not present in context
    12 
    +=== undefined ===
    13 
    +Caught exception: Prelude.undefined
    14 
    +Exception context:
    15 
    +- IPE backtrace:
    16 
    +-   undefined thunk
    17 
    +-   raising undefined action
    18 
    +-   catch site for undefined
    19 
    +-   annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main
    20 
    +- HasCallStack backtrace:
    21 
    +-   undefined, called at ann_frame005.hs:41:48 in main:Main
    22 
    +Handler annotation not present in context
    23 
    +=== error ===
    24 
    +Caught exception: error from annotateStackString
    25 
    +Exception context:
    26 
    +- IPE backtrace:
    27 
    +-   error thunk
    28 
    +-   raising error action
    29 
    +-   catch site for error
    30 
    +-   annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main
    31 
    +- HasCallStack backtrace:
    32 
    +-   error, called at ann_frame005.hs:48:44 in main:Main
    33 
    +Handler annotation not present in context
    34 
    +=== throwSTM ===
    35 
    +Caught exception: SimpleBoom
    36 
    +Exception context:
    37 
    +- IPE backtrace:
    38 
    +-   raising throwSTM action
    39 
    +-   catch site for throwSTM
    40 
    +-   annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main
    41 
    +- HasCallStack backtrace:
    42 
    +-   collectExceptionAnnotation, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:170:37 in ghc-internal:GHC.Internal.Exception
    43 
    +-   toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/STM.hs:190:26 in ghc-internal:GHC.Internal.STM
    44 
    +-   throwSTM, called at ann_frame005.hs:55:9 in main:Main
    45 
    +Handler annotation not present in context

  • testsuite/tests/ghci.debugger/scripts/T8487.stdout
    1 1 
     Breakpoint 0 activated at T8487.hs:(5,8)-(7,53)
    2 2 
     Stopped in Main.f, T8487.hs:(5,8)-(7,53)
    3 3 
     _result :: IO String = _
    4 
    -ma :: Either SomeException String = Left _
    4 
    +ma :: Either SomeException String = Left
    5 
    +                                      (SomeException (ErrorCall ...))

  • testsuite/tests/ghci.debugger/scripts/break011.stdout
    ... ... @@ -4,9 +4,10 @@ HasCallStack backtrace:
    4 4 
       error, called at <interactive>:2:1 in interactive:Ghci1
    5 5
    6 6 
     Stopped in <exception thrown>, <unknown>
    7 
    -_exception :: e = _
    7 
    +_exception :: e = GHC.Internal.Exception.Type.SomeException
    8 
    +                    (GHC.Internal.Exception.ErrorCall _)
    8 9 
     Stopped in <exception thrown>, <unknown>
    9 
    -_exception :: e = _
    10 
    +_exception :: e = SomeException (ErrorCall _)
    10 11 
     -1  : main (Test7.hs:2:18-28)
    11 12 
     -2  : main (Test7.hs:2:8-29)
    12 13 
     <end of history>
    ... ... @@ -26,7 +27,7 @@ _exception :: SomeException = SomeException (ErrorCall "foo")
    26 27 
     *** Exception: foo
    27 28
    28 29 
     HasCallStack backtrace:
    29 
    -  error, called at Test7.hs:2:18 in main:Main
    30 
    +  error, called at Test7.hs:2:18 in interactive-session:Main
    30 31
    31 32 
     Stopped in <exception thrown>, <unknown>
    32 33 
     _exception :: e = _
    ... ... @@ -35,5 +36,5 @@ _exception :: e = _
    35 36 
     *** Exception: foo
    36 37
    37 38 
     HasCallStack backtrace:
    38 
    -  error, called at Test7.hs:2:18 in main:Main
    39 
    +  error, called at Test7.hs:2:18 in interactive-session:Main
    39 40

  • testsuite/tests/ghci.debugger/scripts/break017.stdout
    1 1 
     "Stopped in <exception thrown>, <unknown>
    2 
    -_exception :: e = _
    2 
    +_exception :: e = GHC.Internal.Exception.Type.SomeException
    3 
    +                    (GHC.Internal.Exception.ErrorCall _)
    3 4 
     Logged breakpoint at QSort.hs:6:32-34
    4 5 
     _result :: Char -> Bool
    5 6 
     a :: Char

  • testsuite/tests/ghci.debugger/scripts/break025.stdout
    1 1 
     Stopped in <exception thrown>, <unknown>
    2 
    -_exception :: e = _
    2 
    +_exception :: e = GHC.Internal.Exception.Type.SomeException
    3 
    +                    (GHC.Internal.Exception.ErrorCall _)
    3 4 
     ()

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