Hannes Siebenhandl pushed to branch wip/fendor/freeze-throw at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • libraries/ghc-internal/src/GHC/Internal/Exception.hs
    ... ... @@ -87,7 +87,7 @@ throw e =
    87 87 
         -- Note also the absolutely crucial `noinine` in the RHS!
    88 88 
         --   See Note [Hiding precise exception signature in throw]
    89 89 
         let se :: SomeException
    90 
    -        !se = noinline (unsafePerformIO (toExceptionWithBacktrace e))
    90 
    +        !se = noinline (unsafePerformIO (withFrozenCallStack $ toExceptionWithBacktrace e))
    91 91 
         in raise# se
    92 92
    93 93 
     -- Note [Capturing the backtrace in throw]
    ... ... @@ -162,7 +162,12 @@ throw e =
    162 162 
     -- primops which allow more precise guidance of the demand analyser's heuristic
    163 163 
     -- (e.g. #23847).
    164 164
    165 
    --- | @since base-4.20.0.0
    165 
    +-- | Collect a Backtrace and attach it to the 'Exception'.
    166 
    +--
    167 
    +-- It is recommended to use 'withFrozenCallStack' when calling this function
    168 
    +-- in order to avoid leaking implementation details of 'toExceptionWithBacktrace'.
    169 
    +--
    170 
    +--  @since base-4.20.0.0
    166 171 
     toExceptionWithBacktrace :: (HasCallStack, Exception e)
    167 172 
                              => e -> IO SomeException
    168 173 
     toExceptionWithBacktrace e

  • libraries/ghc-internal/src/GHC/Internal/STM.hs
    ... ... @@ -28,7 +28,7 @@ import GHC.Internal.Base
    28 28 
     import GHC.Internal.Exception (Exception, toExceptionWithBacktrace, fromException, addExceptionContext)
    29 29 
     import GHC.Internal.Exception.Context (ExceptionAnnotation)
    30 30 
     import GHC.Internal.Exception.Type (WhileHandling(..))
    31 
    -import GHC.Internal.Stack (HasCallStack)
    31 
    +import GHC.Internal.Stack (HasCallStack, withFrozenCallStack)
    32 32
    33 33 
     -- TVars are shared memory locations which support atomic memory
    34 34 
     -- transactions.
    ... ... @@ -187,7 +187,7 @@ throwSTM e = do
    187 187 
         -- N.B. Typically use of unsafeIOToSTM is very much frowned upon as this
    188 188 
         -- is an easy way to end up with nested transactions. However, we can be
    189 189 
         -- certain that toExceptionWithBacktrace will not initiate a transaction.
    190 
    -    se <- unsafeIOToSTM (toExceptionWithBacktrace e)
    190 
    +    se <- unsafeIOToSTM (withFrozenCallStack $ toExceptionWithBacktrace e)
    191 191 
         STM $ raiseIO# se
    192 192
    193 193 
     -- | Exception handling within STM actions.

  • libraries/ghc-internal/tests/backtraces/T15395.hs
    1 
    +{-# LANGUAGE LambdaCase #-}
    2 
    +
    3 
    +import GHC.Internal.Control.Exception
    4 
    +import GHC.Internal.Data.Foldable (traverse_)
    5 
    +import GHC.Internal.Exception.Backtrace
    6 
    +import GHC.Internal.Exception.Context
    7 
    +import GHC.Internal.Exception.Type
    8 
    +import GHC.Internal.STM
    9 
    +import Control.Monad (when)
    10 
    +import Data.List (isSuffixOf, isInfixOf)
    11 
    +import System.Exit
    12 
    +
    13 
    +main :: IO ()
    14 
    +main = do
    15 
    +  -- Make sure there are HasCallStackBacktraces
    16 
    +  setBacktraceMechanismState HasCallStackBacktrace True
    17 
    +  mapM_ (uncurry runCase)
    18 
    +    [ ("throw", throwAction)
    19 
    +    , ("throwIO", throwIOAction)
    20 
    +    , ("error", errorAction)
    21 
    +    , ("throwSTM", throwSTMAction)
    22 
    +    , ("undefined", undefinedAction)
    23 
    +    ]
    24 
    +
    25 
    +runCase :: String -> IO () -> IO ()
    26 
    +runCase name act = do
    27 
    +  putStrLn $ "=== Validate stack size of '" ++ name ++ "' has length 1"
    28 
    +  catchAndVerifyStackTraceLength name act
    29 
    +  putStrLn ""
    30 
    +
    31 
    +throwAction :: IO ()
    32 
    +throwAction = evaluate $ throw $ ErrorCall "my throw error"
    33 
    +
    34 
    +throwIOAction :: IO ()
    35 
    +throwIOAction = throwIO $ ErrorCall "my throwIO error"
    36 
    +
    37 
    +errorAction :: IO ()
    38 
    +errorAction = error "plain error"
    39 
    +
    40 
    +throwSTMAction :: IO ()
    41 
    +throwSTMAction = atomically $ throwSTM $ ErrorCall "my throwSTM error"
    42 
    +
    43 
    +undefinedAction :: IO ()
    44 
    +undefinedAction = evaluate undefined
    45 
    +
    46 
    +catchAndVerifyStackTraceLength :: String -> IO () -> IO ()
    47 
    +catchAndVerifyStackTraceLength name act = do
    48 
    +  try act >>= \ case
    49 
    +    Right _ -> do
    50 
    +      putStrLn $ "Exception expected but got a result for '" ++ name ++ "'"
    51 
    +      exitFailure
    52 
    +    Left exc ->
    53 
    +      verifyBacktraceSize name exc
    54 
    +
    55 
    +verifyBacktraceSize :: String -> SomeException -> IO ()
    56 
    +verifyBacktraceSize label se = do
    57 
    +  message <- evaluate (displayException se)
    58 
    +  putStrLn "==== Caught exception:"
    59 
    +  putStrLn message
    60 
    +  let ctx = displayExceptionContext (someExceptionContext se)
    61 
    +      ctxLines = lines ctx
    62 
    +  putStrLn "==== Exception context:"
    63 
    +  case ctxLines of
    64 
    +    [] -> putStrLn "<empty>"
    65 
    +    (l:ls) -> do
    66 
    +      when (l /= "HasCallStack backtrace:") $
    67 
    +        fail "Context is expected to be a \"HasCallStack\" backtrace"
    68 
    +      traverse_ mustNotReferenceGhcInternalPackage ls
    69 
    +      mapM_ (putStrLn . ("- " ++) . dropWhile (== ' ')) ls
    70 
    +  where
    71 
    +    mustNotReferenceGhcInternalPackage l =
    72 
    +      if "ghc-internal" `isInfixOf` l
    73 
    +        then fail $ "Stack trace \"" ++ l ++ "\" must not reference ghc-internal"
    74 
    +        else pure ()

  • libraries/ghc-internal/tests/backtraces/T15395.stdout
    1 
    +=== Validate stack size of 'throw' has length 1
    2 
    +==== Caught exception:
    3 
    +my throw error
    4 
    +==== Exception context:
    5 
    +- throw, called at T15395.hs:32:26 in main:Main
    6 
    +
    7 
    +=== Validate stack size of 'throwIO' has length 1
    8 
    +==== Caught exception:
    9 
    +my throwIO error
    10 
    +==== Exception context:
    11 
    +- throwIO, called at T15395.hs:35:17 in main:Main
    12 
    +
    13 
    +=== Validate stack size of 'error' has length 1
    14 
    +==== Caught exception:
    15 
    +plain error
    16 
    +==== Exception context:
    17 
    +- error, called at T15395.hs:38:15 in main:Main
    18 
    +
    19 
    +=== Validate stack size of 'throwSTM' has length 1
    20 
    +==== Caught exception:
    21 
    +my throwSTM error
    22 
    +==== Exception context:
    23 
    +- throwSTM, called at T15395.hs:41:31 in main:Main
    24 
    +
    25 
    +=== Validate stack size of 'undefined' has length 1
    26 
    +==== Caught exception:
    27 
    +Prelude.undefined
    28 
    +==== Exception context:
    29 
    +- undefined, called at T15395.hs:44:28 in main:Main
    30 
    +

  • libraries/ghc-internal/tests/backtraces/all.T
    ... ... @@ -4,3 +4,7 @@ test('T26507', [ when(have_profiling(), extra_ways(['prof']))
    4 4 
                    , when(js_arch(), skip)
    5 5 
                    , when(ghc_with_ipe(), skip) # IPE builds include an IPE backtrace section on stderr.
    6 6 
                    , exit_code(1)], compile_and_run, [''])
    7 
    +
    8 
    +# Stack traces shouldn't expose implementation details
    9 
    +test('T15395', [ when(have_profiling(), extra_ways(['prof']))
    10 
    +               , when(js_arch(), skip)], compile_and_run, [''])

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