Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f5d77d20 by Greg Steuck at 2026-01-25T00:01:43+00:00 Move flags to precede patterns for grep and read files directly This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools. There's no reason to use cat and pipe where direct file argument works. - - - - - 561c3821 by Matthew Pickering at 2026-01-26T08:52:01-05:00 Evaluate backtraces for "error" exceptions at the moment they are thrown See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] which explain the implementation. This commit makes `error` and `throw` behave the same with regard to backtraces. Previously, exceptions raised by `error` would not contain useful IPE backtraces. I did try and implement `error` in terms of `throw` but it started to involve putting diverging functions into hs-boot files, which seemed to risky if the compiler wouldn't be able to see if applying a function would diverge. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383 Fixes #26751 - - - - - 12 changed files: - libraries/base/changelog.md - libraries/base/tests/perf/Makefile - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/tests/stack-annotation/all.T - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - testsuite/tests/driver/T16318/Makefile - testsuite/tests/driver/T18125/Makefile - testsuite/tests/ghci.debugger/scripts/T8487.stdout - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break017.stdout - testsuite/tests/ghci.debugger/scripts/break025.stdout Changes: ===================================== libraries/base/changelog.md ===================================== @@ -23,6 +23,7 @@ * `GHC.Conc.catchSTM` and `GHC.Conc.Sync.catchSTM` now attach `WhileHandling` annotation to exceptions thrown from the handler. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365)) * Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) + * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/tests/perf/Makefile ===================================== @@ -12,4 +12,4 @@ T17752: # All occurrences of elem should be optimized away. # For strings these should result in loops after inlining foldCString. # For lists it should result in a case expression. - echo $$(cat T17752.dump-simpl | grep "elem" -A4 ) + echo $$(grep -A4 "elem" T17752.dump-simpl) ===================================== libraries/ghc-internal/src/GHC/Internal/Err.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} {-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -25,6 +26,7 @@ module GHC.Internal.Err( absentErr, error, errorWithoutStackTrace, undefined ) where import GHC.Internal.Types (Char, RuntimeRep) import GHC.Internal.Stack.Types +import GHC.Internal.Magic import GHC.Internal.Prim import {-# SOURCE #-} GHC.Internal.Exception ( errorCallWithCallStackException @@ -33,7 +35,10 @@ import {-# SOURCE #-} GHC.Internal.Exception -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => [Char] -> a -error s = raise# (errorCallWithCallStackException s ?callStack) +error s = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException s ?callStack) + in raise# se -- Bleh, we should be using 'GHC.Internal.Stack.callStack' instead of -- '?callStack' here, but 'GHC.Internal.Stack.callStack' depends on -- 'GHC.Internal.Stack.popCallStack', which is partial and depends on @@ -73,7 +78,10 @@ undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). -- nor wanted (see #19886). We’d like to use withFrozenCallStack, but that -- is not available in this module yet, and making it so is hard. So let’s just -- use raise# directly. -undefined = raise# (errorCallWithCallStackException "Prelude.undefined" ?callStack) +undefined = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException "Prelude.undefined" ?callStack) + in raise# se -- | Used for compiler-generated error message; -- 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, ['']) test('ann_frame002', ann_frame_opts, compile_and_run, ['']) test('ann_frame003', ann_frame_opts, compile_and_run, ['']) test('ann_frame004', ann_frame_opts, compile_and_run, ['']) +test('ann_frame005', ann_frame_opts, compile_and_run, ['']) ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs ===================================== @@ -0,0 +1,73 @@ +import Control.Concurrent.STM +import Control.Exception +import Control.Exception.Backtrace (BacktraceMechanism(IPEBacktrace), setBacktraceMechanismState) +import Control.Exception.Context (displayExceptionContext) +import Control.Monad +import Data.List (isInfixOf) +import TestUtils + +data SimpleBoom = SimpleBoom deriving (Show) + +instance Exception SimpleBoom + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + mapM_ (uncurry runCase) + [ ("throwIO SimpleBoom", throwIOAction) + , ("undefined", undefinedAction) + , ("error", errorAction) + , ("throwSTM", throwSTMAction) + ] + +runCase :: String -> IO () -> IO () +runCase label action = do + putStrLn ("=== " ++ label ++ " ===") + annotateCallStackIO $ + annotateStackStringIO ("catch site for " ++ label) $ + catch action (handler label) + +throwIOAction :: IO () +throwIOAction = + annotateStackStringIO "raising action" $ + annotateStackStringIO "throwIO SimpleBoom" $ + throwIO SimpleBoom + +undefinedAction :: IO () +undefinedAction = + annotateStackStringIO "raising undefined action" $ + void $ + evaluate $ + annotateStackString "undefined thunk" (undefined :: Int) + +errorAction :: IO () +errorAction = + annotateStackStringIO "raising error action" $ + void $ + evaluate $ + annotateStackString "error thunk" (error "error from annotateStackString" :: Int) + +throwSTMAction :: IO () +throwSTMAction = + annotateStackStringIO "raising throwSTM action" $ + atomically $ + annotateStackString "throwSTM SimpleBoom" $ + throwSTM SimpleBoom + +handler :: String -> SomeException -> IO () +handler label se = + annotateStackStringIO ("handler for " ++ label) $ + annotateStackStringIO ("forcing SomeException for " ++ label) $ do + message <- evaluate (displayException se) + putStrLn ("Caught exception: " ++ message) + let ctx = displayExceptionContext (someExceptionContext se) + ctxLines = lines ctx + putStrLn "Exception context:" + case ctxLines of + [] -> putStrLn "<empty>" + ls -> mapM_ (putStrLn . ("- " ++)) ls + let handlerTag = "handler for " ++ label + -- Check that the callstack is from the callsite, not the handling site + when (any (handlerTag `isInfixOf`) ctxLines) $ + error $ "handler annotation leaked into context for " ++ label + putStrLn "Handler annotation not present in context" ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout ===================================== @@ -0,0 +1,45 @@ +=== throwIO SimpleBoom === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- throwIO SimpleBoom +- raising action +- catch site for throwIO SimpleBoom +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- throwIO, called at ann_frame005.hs:34:7 in main:Main +Handler annotation not present in context +=== undefined === +Caught exception: Prelude.undefined +Exception context: +- IPE backtrace: +- undefined thunk +- raising undefined action +- catch site for undefined +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- undefined, called at ann_frame005.hs:41:48 in main:Main +Handler annotation not present in context +=== error === +Caught exception: error from annotateStackString +Exception context: +- IPE backtrace: +- error thunk +- raising error action +- catch site for error +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- error, called at ann_frame005.hs:48:44 in main:Main +Handler annotation not present in context +=== throwSTM === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- raising throwSTM action +- catch site for throwSTM +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- collectExceptionAnnotation, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:170:37 in ghc-internal:GHC.Internal.Exception +- toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/STM.hs:190:26 in ghc-internal:GHC.Internal.STM +- throwSTM, called at ann_frame005.hs:55:9 in main:Main +Handler annotation not present in context ===================================== testsuite/tests/driver/T16318/Makefile ===================================== @@ -7,5 +7,5 @@ test_pe = test-package-environment T16318: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -v1 -ignore-dot-ghci -package-env $(test_pe) -e "putStrLn \"Hello\"" > out 2>&1 - C=`cat out | grep "Loaded package environment" -c` ; \ + C=`grep -c "Loaded package environment" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/driver/T18125/Makefile ===================================== @@ -9,5 +9,5 @@ T18125: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(GHC_PKG)" field $(test_lib) id --simple-outpu >> $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -Wunused-packages -package-env $(test_pe) T18125.hs > out 2>&1 - C=`cat out | grep "$(test_lib)" -c` ; \ + C=`grep -c "$(test_lib)" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/ghci.debugger/scripts/T8487.stdout ===================================== @@ -1,4 +1,5 @@ Breakpoint 0 activated at T8487.hs:(5,8)-(7,53) Stopped in Main.f, T8487.hs:(5,8)-(7,53) _result :: IO String = _ -ma :: Either SomeException String = Left _ +ma :: Either SomeException String = Left + (SomeException (ErrorCall ...)) ===================================== testsuite/tests/ghci.debugger/scripts/break011.stdout ===================================== @@ -4,9 +4,10 @@ HasCallStack backtrace: error, called at <interactive>:2:1 in interactive:Ghci1 Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = SomeException (ErrorCall _) -1 : main (Test7.hs:2:18-28) -2 : main (Test7.hs:2:8-29) <end of history> @@ -26,7 +27,7 @@ _exception :: SomeException = SomeException (ErrorCall "foo") *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main Stopped in <exception thrown>, <unknown> _exception :: e = _ @@ -35,5 +36,5 @@ _exception :: e = _ *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main ===================================== testsuite/tests/ghci.debugger/scripts/break017.stdout ===================================== @@ -1,5 +1,6 @@ "Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Logged breakpoint at QSort.hs:6:32-34 _result :: Char -> Bool a :: Char ===================================== testsuite/tests/ghci.debugger/scripts/break025.stdout ===================================== @@ -1,3 +1,4 @@ Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c3e64e1e76a6099e96d7ed1dabab5e2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c3e64e1e76a6099e96d7ed1dabab5e2... You're receiving this email because of your account on gitlab.haskell.org.