Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 26e0db16 by fendor at 2025-09-01T08:47:01-04:00 Expose Stack Annotation frames in IPE backtraces by default When decoding the Haskell-native call stack and displaying the IPE information for the stack frames, we print the `StackAnnotation` of the `AnnFrame` by default. This means, when an exception is thrown, any intermediate stack annotations will be displayed in the `IPE Backtrace`. Example backtrace: ``` Exception: ghc-internal:GHC.Internal.Exception.ErrorCall: Oh no! IPE backtrace: annotateCallStackIO, called at app/Main.hs:48:10 in backtrace-0.1.0.0-inplace-server:Main annotateCallStackIO, called at app/Main.hs:46:13 in backtrace-0.1.0.0-inplace-server:Main Main.handler (app/Main.hs:(46,1)-(49,30)) Main.liftIO (src/Servant/Server/Internal/Handler.hs:30:36-42) Servant.Server.Internal.Delayed.runHandler' (src/Servant/Server/Internal/Handler.hs:27:31-41) Control.Monad.Trans.Resource.runResourceT (./Control/Monad/Trans/Resource.hs:(192,14)-(197,18)) Network.Wai.Handler.Warp.HTTP1.processRequest (./Network/Wai/Handler/Warp/HTTP1.hs:195:20-22) Network.Wai.Handler.Warp.HTTP1.processRequest (./Network/Wai/Handler/Warp/HTTP1.hs:(195,5)-(203,31)) Network.Wai.Handler.Warp.HTTP1.http1server.loop (./Network/Wai/Handler/Warp/HTTP1.hs:(141,9)-(157,42)) HasCallStack backtrace: error, called at app/Main.hs:48:32 in backtrace-0.1.0.0-inplace-server:Main ``` The first two entries have been added by `annotateCallStackIO`, defined in `annotateCallStackIO`. - - - - - 9 changed files: - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - + libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/tests/stack-annotation/ann_frame002.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 ===================================== @@ -58,6 +58,7 @@ import Data.Typeable import GHC.Exts import GHC.IO import GHC.Internal.Stack +import GHC.Internal.Stack.Annotation -- Note [User-defined stack annotations for better stack traces] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -127,31 +128,10 @@ import GHC.Internal.Stack -- This means, right now, if you want to reliably capture stack frame annotations, -- in both pure and impure code, prefer 'throw' and 'throwIO' variants over 'error'. --- ---------------------------------------------------------------------------- --- StackAnnotation --- ---------------------------------------------------------------------------- - --- | 'StackAnnotation's are types which can be pushed onto the call stack --- as the payload of 'AnnFrame' stack frames. --- -class StackAnnotation a where - displayStackAnnotation :: a -> String - -- ---------------------------------------------------------------------------- -- Annotations -- ---------------------------------------------------------------------------- --- | --- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy. --- When the call stack is annotated with a value of type @a@, behind the scenes it is --- encapsulated in a @SomeStackAnnotation@. --- -data SomeStackAnnotation where - SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation - -instance StackAnnotation SomeStackAnnotation where - displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a - data StringAnnotation where StringAnnotation :: String -> StringAnnotation @@ -175,7 +155,7 @@ instance Show CallStackAnnotation where instance StackAnnotation CallStackAnnotation where displayStackAnnotation (CallStackAnnotation cs) = case getCallStack cs of [] -> "<unknown source location>" - ((_,srcLoc):_) -> prettySrcLoc srcLoc + ((fnName,srcLoc):_) -> fnName ++ ", called at " ++ prettySrcLoc srcLoc -- ---------------------------------------------------------------------------- -- Annotate the CallStack with custom data ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -295,6 +295,7 @@ Library GHC.Internal.Stable GHC.Internal.StableName GHC.Internal.Stack + GHC.Internal.Stack.Annotation GHC.Internal.Stack.CCS GHC.Internal.Stack.CloneStack GHC.Internal.Stack.Constants ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -11,7 +11,7 @@ import GHC.Internal.IORef import GHC.Internal.IO.Unsafe (unsafePerformIO) import GHC.Internal.Exception.Context import GHC.Internal.Ptr -import GHC.Internal.Data.Maybe (fromMaybe) +import GHC.Internal.Data.Maybe (fromMaybe, mapMaybe) import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack) import qualified GHC.Internal.Stack as HCS import qualified GHC.Internal.ExecutionStack.Internal as ExecStack @@ -144,7 +144,7 @@ displayBacktraces bts = concat displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor -- references closures can be garbage collected. - displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode + displayIpe = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.Internal.Stack.Annotation where + +import GHC.Internal.Base +import GHC.Internal.Data.Typeable + +-- ---------------------------------------------------------------------------- +-- StackAnnotation +-- ---------------------------------------------------------------------------- + +-- | 'StackAnnotation's are types which can be pushed onto the call stack +-- as the payload of 'AnnFrame' stack frames. +-- +class StackAnnotation a where + displayStackAnnotation :: a -> String + +-- ---------------------------------------------------------------------------- +-- Annotations +-- ---------------------------------------------------------------------------- + +-- | +-- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy. +-- When the call stack is annotated with a value of type @a@, behind the scenes it is +-- encapsulated in a @SomeStackAnnotation@. +-- +data SomeStackAnnotation where + SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation + +instance StackAnnotation SomeStackAnnotation where + displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,6 +24,7 @@ module GHC.Internal.Stack.Decode ( StackEntry(..), -- * Pretty printing prettyStackEntry, + prettyStackFrameWithIpe, ) where @@ -39,6 +41,7 @@ import GHC.Internal.Data.Tuple import GHC.Internal.Foreign.Ptr import GHC.Internal.Foreign.Storable import GHC.Internal.Exts +import GHC.Internal.Unsafe.Coerce import GHC.Internal.ClosureTypes import GHC.Internal.Heap.Closures @@ -52,6 +55,7 @@ import GHC.Internal.Heap.Closures ) import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS) import GHC.Internal.Heap.InfoTable +import GHC.Internal.Stack.Annotation import GHC.Internal.Stack.Constants import GHC.Internal.Stack.CloneStack import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) @@ -560,6 +564,16 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do -- Pretty printing functions for stack entries, stack frames and provenance info -- ---------------------------------------------------------------------------- +prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String +prettyStackFrameWithIpe (frame, mipe) = + case frame of + AnnFrame {annotation = Box someStackAnno } -> + case unsafeCoerce someStackAnno of + SomeStackAnnotation ann -> + Just $ displayStackAnnotation ann + _ -> + (prettyStackEntry . toStackEntry) <$> mipe + prettyStackEntry :: StackEntry -> String prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout ===================================== @@ -1,11 +1,11 @@ Start some work 10946 Stack annotations: -- ann_frame002.hs:18:7 in main:Main -- ann_frame002.hs:12:11 in main:Main +- annotateCallStackIO, called at ann_frame002.hs:18:7 in main:Main +- annotateCallStackIO, called at ann_frame002.hs:12:11 in main:Main Finish some work Some more work in bar 17711 Stack annotations: - bar -- ann_frame002.hs:23:7 in main:Main +- annotateCallStackIO, called at ann_frame002.hs:23:7 in main:Main ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout ===================================== @@ -1,17 +1,17 @@ Stack annotations: -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:21:17 in main:Main -- ann_frame004.hs:13:10 in main:Main +- 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:21:17 in main:Main +- 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:21:17 in main:Main +- 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:21:17 in main:Main +- 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: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 -- ann_frame004.hs:12:7 in main:Main +- annotateCallStackIO, called at ann_frame004.hs:12:7 in main:Main ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -10949,10 +10949,6 @@ module System.Mem.Experimental where -- Instances: -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’ @@ -11151,3 +11147,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’ instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’ ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -10952,10 +10952,6 @@ module System.Mem.Experimental where -- Instances: -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ -instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’ @@ -11154,3 +11150,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’ instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’ +instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/26e0db16365059f0fdfe63b773852df4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/26e0db16365059f0fdfe63b773852df4... You're receiving this email because of your account on gitlab.haskell.org.