[Git][ghc/ghc][wip/fendor/stack-annotation-with-backtraces] Expose Stack Annotation frames in IPE backtraces by default

26 Aug 2025

Hannes Siebenhandl pushed to branch wip/fendor/stack-annotation-with-backtraces at Glasgow Haskell Compiler / GHC


Commits:
76bf8e68 by fendor at 2025-08-26T17:30:55+02:00
Expose Stack Annotation frames in IPE backtraces by default

- - - - -


5 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


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,28 +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
 
@@ -175,7 +158,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,28 @@
+{-# 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


=====================================
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 entires, 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 ++ ")"



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76bf8e686ff0edb90f66f1e03cfe01ae...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76bf8e686ff0edb90f66f1e03cfe01ae...
You're receiving this email because of your account on gitlab.haskell.org.

    

Hannes Siebenhandl (＠fendor)

tags

participants (1)