Hannes Siebenhandl pushed to branch wip/fendor/stack-annotation-ty at Glasgow Haskell Compiler / GHC Commits: 90df50b2 by fendor at 2026-01-21T09:52:22+01:00 Add optional `SrcLoc` to `StackAnnotation` class `StackAnnotation` give access to an optional `SrcLoc` field that stack annotations can use to provide better backtraces in both error messages and when decoding the callstack. We update builtin stack annotations such as `StringAnnotation` and `ShowAnnotation` to also capture the `SrcLoc` of the current `CallStack` to improve backtraces by default (if stack annotations are used). This change is backwards compatible with GHC 9.14.1. - - - - - 10 changed files: - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-experimental/tests/backtraces/T26806a.stderr - libraries/ghc-experimental/tests/backtraces/T26806b.stderr - libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 Changes: ===================================== libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs ===================================== @@ -133,20 +133,32 @@ import GHC.Internal.Stack.Annotation -- Annotations -- ---------------------------------------------------------------------------- + +-- | A 'String' only annotation with an optional source location. data StringAnnotation where - StringAnnotation :: String -> StringAnnotation + StringAnnotation :: !(Maybe SrcLoc) -> String -> StringAnnotation instance StackAnnotation StringAnnotation where - displayStackAnnotation (StringAnnotation str) = str + displayStackAnnotationShort (StringAnnotation _srcLoc str) = + str + + sourceLocationOfStackAnnotation (StringAnnotation srcLoc _str) = + srcLoc -- | Use the 'Show' instance of a type to display as the 'StackAnnotation'. data ShowAnnotation where - ShowAnnotation :: forall a . Show a => a -> ShowAnnotation + ShowAnnotation :: forall a . Show a => !(Maybe SrcLoc) -> a -> ShowAnnotation instance StackAnnotation ShowAnnotation where - displayStackAnnotation (ShowAnnotation showAnno) = show showAnno + displayStackAnnotationShort (ShowAnnotation _srcLoc showAnno) = + show showAnno + + sourceLocationOfStackAnnotation (ShowAnnotation srcLoc _showAnno) = + srcLoc -- | A 'CallStack' stack annotation. +-- +-- Captures the whole 'CallStack'. newtype CallStackAnnotation = CallStackAnnotation CallStack instance Show CallStackAnnotation where @@ -154,9 +166,23 @@ instance Show CallStackAnnotation where -- | Displays the first entry of the 'CallStack' instance StackAnnotation CallStackAnnotation where - displayStackAnnotation (CallStackAnnotation cs) = case getCallStack cs of + sourceLocationOfStackAnnotation (CallStackAnnotation cs) = + callStackHeadSrcLoc cs + + displayStackAnnotationShort (CallStackAnnotation cs) = + callStackHeadFunctionName cs + +callStackHeadSrcLoc :: CallStack -> Maybe SrcLoc +callStackHeadSrcLoc cs = + case getCallStack cs of + [] -> Nothing + (_, srcLoc):_ -> Just srcLoc + +callStackHeadFunctionName :: CallStack -> String +callStackHeadFunctionName cs = + case getCallStack cs of [] -> "<unknown source location>" - ((fnName,srcLoc):_) -> fnName ++ ", called at " ++ prettySrcLoc srcLoc + (fnName, _):_ -> fnName -- ---------------------------------------------------------------------------- -- Annotate the CallStack with custom data @@ -172,7 +198,7 @@ instance StackAnnotation CallStackAnnotation where -- -- WARNING: forces the evaluation of @b@ to WHNF. {-# NOINLINE annotateStack #-} -annotateStack :: forall a b. (Typeable a, StackAnnotation a) => a -> b -> b +annotateStack :: forall a b. (HasCallStack, Typeable a, StackAnnotation a) => a -> b -> b annotateStack ann b = unsafePerformIO $ annotateStackIO ann (evaluate b) @@ -196,9 +222,9 @@ annotateCallStack b = unsafePerformIO $ withFrozenCallStack $ -- information to stack traces. -- -- WARNING: forces the evaluation of @b@ to WHNF. -annotateStackString :: forall b . String -> b -> b +annotateStackString :: forall b . HasCallStack => String -> b -> b annotateStackString ann = - annotateStack (StringAnnotation ann) + annotateStack (StringAnnotation (callStackHeadSrcLoc ?callStack) ann) -- | @'annotateStackShow' showable b@ annotates the evaluation stack of @b@ -- with the value @showable@. @@ -207,16 +233,16 @@ annotateStackString ann = -- information to stack traces. -- -- WARNING: forces the evaluation of @b@ to WHNF. -annotateStackShow :: forall a b . (Typeable a, Show a) => a -> b -> b +annotateStackShow :: forall a b . (HasCallStack, Typeable a, Show a) => a -> b -> b annotateStackShow ann = - annotateStack (ShowAnnotation ann) + annotateStack (ShowAnnotation (callStackHeadSrcLoc ?callStack) ann) -- | @'annotateStackIO' showable b@ annotates the evaluation stack of @b@ -- with the value @showable@. -- -- When decoding the call stack, the annotation frames can be used to add more -- information to stack traces. -annotateStackIO :: forall a b . (Typeable a, StackAnnotation a) => a -> IO b -> IO b +annotateStackIO :: forall a b . (HasCallStack, Typeable a, StackAnnotation a) => a -> IO b -> IO b annotateStackIO ann (IO act) = IO $ \s -> annotateStack# (SomeStackAnnotation ann) act s {-# NOINLINE annotateStackIO #-} @@ -226,18 +252,18 @@ annotateStackIO ann (IO act) = -- -- When decoding the call stack, the annotation frames can be used to add more -- information to stack traces. -annotateStackStringIO :: forall b . String -> IO b -> IO b +annotateStackStringIO :: forall b . HasCallStack => String -> IO b -> IO b annotateStackStringIO ann = - annotateStackIO (StringAnnotation ann) + annotateStackIO (StringAnnotation (callStackHeadSrcLoc ?callStack) ann) -- | @'annotateStackShowIO' msg b@ annotates the evaluation stack of @b@ -- with the value @msg@. -- -- When decoding the call stack, the annotation frames can be used to add more -- information to stack traces. -annotateStackShowIO :: forall a b . (Show a) => a -> IO b -> IO b +annotateStackShowIO :: forall a b . (HasCallStack, Show a) => a -> IO b -> IO b annotateStackShowIO ann = - annotateStackIO (ShowAnnotation ann) + annotateStackIO (ShowAnnotation (callStackHeadSrcLoc ?callStack) ann) -- | @'annotateCallStackIO' b@ annotates the evaluation stack of @b@ with the -- current 'callstack'. ===================================== libraries/ghc-experimental/tests/backtraces/T26806a.stderr ===================================== @@ -3,8 +3,8 @@ T26806a: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: Backtrace Test IPE backtrace: - Lovely annotation - [1,2,3,4] + Lovely annotation, called at T26806a.hs:12:7 in main:Main + [1,2,3,4], called at T26806a.hs:11:5 in main:Main annotateCallStackIO, called at T26806a.hs:10:3 in main:Main HasCallStack backtrace: throwIO, called at T26806a.hs:13:9 in main:Main ===================================== libraries/ghc-experimental/tests/backtraces/T26806b.stderr ===================================== @@ -3,8 +3,8 @@ T26806b: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: Backtrace Test: 125000000 IPE backtrace: - Lovely annotation - [1,2,3,4] + Lovely annotation, called at T26806b.hs:16:7 in main:Main + [1,2,3,4], called at T26806b.hs:15:5 in main:Main annotateCallStack, called at T26806b.hs:14: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 ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs ===================================== @@ -4,6 +4,7 @@ module GHC.Internal.Stack.Annotation where import GHC.Internal.Base import GHC.Internal.Data.Typeable +import GHC.Internal.Stack (SrcLoc, prettySrcLoc) -- ---------------------------------------------------------------------------- -- StackAnnotation @@ -13,8 +14,36 @@ import GHC.Internal.Data.Typeable -- as the payload of 'AnnFrame' stack frames. -- class StackAnnotation a where + -- | Display a human readable string for the 'StackAnnotation'. + -- + -- This is supposed to be the long version of 'displayStackAnnotationShort' + -- and may contain a source location. + -- + -- If not provided, 'displayStackAnnotation' is derived from 'sourceLocationOfStackAnnotation' + -- and 'displayStackAnnotationShort'. displayStackAnnotation :: a -> String + -- | Get the 'SrcLoc' of the given 'StackAnnotation'. + -- + -- This is optional, 'SrcLoc' are not strictly required for 'StackAnnotation', but + -- it is still heavily encouarged to provide a 'SrcLoc' for better IPE backtraces. + sourceLocationOfStackAnnotation :: a -> Maybe SrcLoc + + -- | The description of the StackAnnotation without any metadata such as source locations. + -- + -- Pefer implementing 'displayStackAnnotationShort' over 'displayStackAnnotation'. + displayStackAnnotationShort :: a -> String + + {-# MINIMAL displayStackAnnotation | displayStackAnnotationShort #-} + + displayStackAnnotation ann = + displayStackAnnotationShort ann + ++ case sourceLocationOfStackAnnotation ann of + Nothing -> "" + Just srcLoc -> ", called at " ++ prettySrcLoc srcLoc + sourceLocationOfStackAnnotation _ann = Nothing + displayStackAnnotationShort = displayStackAnnotation + -- ---------------------------------------------------------------------------- -- Annotations -- ---------------------------------------------------------------------------- @@ -29,3 +58,5 @@ data SomeStackAnnotation where instance StackAnnotation SomeStackAnnotation where displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a + sourceLocationOfStackAnnotation (SomeStackAnnotation a) = sourceLocationOfStackAnnotation a + displayStackAnnotationShort (SomeStackAnnotation a) = displayStackAnnotationShort a ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout ===================================== @@ -1,12 +1,12 @@ Stack annotations: -- (2,3) +- (2,3), called at ann_frame001.hs:5:13 in main:Main 47 Stack annotations: -- "bar" -- "foo" -- "tailCallEx" +- "bar", called at ann_frame001.hs:23:9 in main:Main +- "foo", called at ann_frame001.hs:21:11 in main:Main +- "tailCallEx", called at ann_frame001.hs:17:18 in main:Main Stack annotations: -- "bar" -- "foo" -- "tailCallEx" +- "bar", called at ann_frame001.hs:23:9 in main:Main +- "foo", called at ann_frame001.hs:21:11 in main:Main +- "tailCallEx", called at ann_frame001.hs:17:18 in main:Main 40 ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout ===================================== @@ -7,5 +7,5 @@ Finish some work Some more work in bar 17711 Stack annotations: -- bar +- bar, called at ann_frame002.hs:23:29 in main:Main - annotateCallStackIO, called at ann_frame002.hs:23:7 in main:Main ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout ===================================== @@ -1,6 +1,6 @@ 47 Stack annotations: -- "bar" -- "foo" -- "tailCallEx" +- "bar", called at ann_frame003.hs:25:9 in main:Main +- "foo", called at ann_frame003.hs:21:11 in main:Main +- "tailCallEx", called at ann_frame003.hs:16:18 in main:Main 40 ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout ===================================== @@ -13,5 +13,5 @@ Stack annotations: - annotateCallStack, called at ann_frame004.hs:21:17 in main:Main - annotateCallStack, called at ann_frame004.hs:21:17 in main:Main - annotateCallStack, called at ann_frame004.hs:13:10 in main:Main -- bar +- bar, called at ann_frame004.hs:12:29 in main:Main - annotateCallStackIO, called at ann_frame004.hs:12:7 in main:Main ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -6482,25 +6482,27 @@ module GHC.Stack.Annotation.Experimental where newtype CallStackAnnotation = CallStackAnnotation GHC.Internal.Stack.Types.CallStack type ShowAnnotation :: * data ShowAnnotation where - ShowAnnotation :: forall a. GHC.Internal.Show.Show a => a -> ShowAnnotation + ShowAnnotation :: forall a. GHC.Internal.Show.Show a => !(GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.SrcLoc) -> a -> ShowAnnotation type SomeStackAnnotation :: * data SomeStackAnnotation where SomeStackAnnotation :: forall a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> SomeStackAnnotation type StackAnnotation :: * -> Constraint class StackAnnotation a where displayStackAnnotation :: a -> GHC.Internal.Base.String - {-# MINIMAL displayStackAnnotation #-} + sourceLocationOfStackAnnotation :: a -> GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.SrcLoc + displayStackAnnotationShort :: a -> GHC.Internal.Base.String + {-# MINIMAL displayStackAnnotation | displayStackAnnotationShort #-} type StringAnnotation :: * data StringAnnotation where - StringAnnotation :: GHC.Internal.Base.String -> StringAnnotation + StringAnnotation :: !(GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.SrcLoc) -> GHC.Internal.Base.String -> StringAnnotation annotateCallStack :: forall b. GHC.Internal.Stack.Types.HasCallStack => b -> b annotateCallStackIO :: forall a. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a - annotateStack :: forall a b. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> b -> b - annotateStackIO :: forall a b. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b - annotateStackShow :: forall a b. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Show.Show a) => a -> b -> b - annotateStackShowIO :: forall a b. GHC.Internal.Show.Show a => a -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b - annotateStackString :: forall b. GHC.Internal.Base.String -> b -> b - annotateStackStringIO :: forall b. GHC.Internal.Base.String -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b + annotateStack :: forall a b. (GHC.Internal.Stack.Types.HasCallStack, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> b -> b + annotateStackIO :: forall a b. (GHC.Internal.Stack.Types.HasCallStack, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b + annotateStackShow :: forall a b. (GHC.Internal.Stack.Types.HasCallStack, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Show.Show a) => a -> b -> b + annotateStackShowIO :: forall a b. (GHC.Internal.Stack.Types.HasCallStack, GHC.Internal.Show.Show a) => a -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b + annotateStackString :: forall b. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Base.String -> b -> b + annotateStackStringIO :: forall b. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Base.String -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b module GHC.Stats.Experimental where -- Safety: Safe ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -6485,25 +6485,27 @@ module GHC.Stack.Annotation.Experimental where newtype CallStackAnnotation = CallStackAnnotation GHC.Internal.Stack.Types.CallStack type ShowAnnotation :: * data ShowAnnotation where - ShowAnnotation :: forall a. GHC.Internal.Show.Show a => a -> ShowAnnotation + ShowAnnotation :: forall a. GHC.Internal.Show.Show a => !(GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.SrcLoc) -> a -> ShowAnnotation type SomeStackAnnotation :: * data SomeStackAnnotation where SomeStackAnnotation :: forall a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> SomeStackAnnotation type StackAnnotation :: * -> Constraint class StackAnnotation a where displayStackAnnotation :: a -> GHC.Internal.Base.String - {-# MINIMAL displayStackAnnotation #-} + sourceLocationOfStackAnnotation :: a -> GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.SrcLoc + displayStackAnnotationShort :: a -> GHC.Internal.Base.String + {-# MINIMAL displayStackAnnotation | displayStackAnnotationShort #-} type StringAnnotation :: * data StringAnnotation where - StringAnnotation :: GHC.Internal.Base.String -> StringAnnotation + StringAnnotation :: !(GHC.Internal.Maybe.Maybe GHC.Internal.Stack.Types.SrcLoc) -> GHC.Internal.Base.String -> StringAnnotation annotateCallStack :: forall b. GHC.Internal.Stack.Types.HasCallStack => b -> b annotateCallStackIO :: forall a. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a - annotateStack :: forall a b. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> b -> b - annotateStackIO :: forall a b. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b - annotateStackShow :: forall a b. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Show.Show a) => a -> b -> b - annotateStackShowIO :: forall a b. GHC.Internal.Show.Show a => a -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b - annotateStackString :: forall b. GHC.Internal.Base.String -> b -> b - annotateStackStringIO :: forall b. GHC.Internal.Base.String -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b + annotateStack :: forall a b. (GHC.Internal.Stack.Types.HasCallStack, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> b -> b + annotateStackIO :: forall a b. (GHC.Internal.Stack.Types.HasCallStack, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, StackAnnotation a) => a -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b + annotateStackShow :: forall a b. (GHC.Internal.Stack.Types.HasCallStack, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Show.Show a) => a -> b -> b + annotateStackShowIO :: forall a b. (GHC.Internal.Stack.Types.HasCallStack, GHC.Internal.Show.Show a) => a -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b + annotateStackString :: forall b. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Base.String -> b -> b + annotateStackStringIO :: forall b. GHC.Internal.Stack.Types.HasCallStack => GHC.Internal.Base.String -> GHC.Internal.Types.IO b -> GHC.Internal.Types.IO b module GHC.Stats.Experimental where -- Safety: Safe View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/90df50b276e4aed704a32679a9d2dff9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/90df50b276e4aed704a32679a9d2dff9... You're receiving this email because of your account on gitlab.haskell.org.