Hannes Siebenhandl pushed to branch wip/fendor/stack-annotation-with-backtraces at Glasgow Haskell Compiler / GHC Commits: 022ce2bc by fendor at 2025-08-13T15:40:03+02:00 Changes to tie everything together - - - - - 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 ===================================== @@ -27,29 +27,12 @@ import Data.Typeable import GHC.Exts import GHC.IO import GHC.Internal.Stack - --- ---------------------------------------------------------------------------- --- 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 +import GHC.Internal.Stack.Annotation -- ---------------------------------------------------------------------------- -- 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/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 #-} @@ -40,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 @@ -53,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) @@ -443,7 +446,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi ANN_FRAME -> let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) in - mkStackFrameResult $ + mkStackFrameResult $ AnnFrame { info_tbl = info, annotation = annotation @@ -561,9 +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) = - (prettyStackEntry . toStackEntry) <$> mipe +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}) = View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/022ce2bcfa4100088279bbaabc62015c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/022ce2bcfa4100088279bbaabc62015c... You're receiving this email because of your account on gitlab.haskell.org.