Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: 7fc6bb03 by fendor at 2025-05-16T11:58:49+02:00 WIP: come up with a proper API for annotateStac - - - - - 4 changed files: - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-heap/tests/ann_frame.hs - + libraries/ghc-heap/tests/ann_frame.stdout Changes: ===================================== libraries/ghc-experimental/ghc-experimental.cabal.in ===================================== @@ -36,6 +36,7 @@ library GHC.TypeLits.Experimental GHC.TypeNats.Experimental GHC.RTS.Flags.Experimental + GHC.Stack.Annotation.Experimental GHC.Stats.Experimental Prelude.Experimental if arch(wasm32) ===================================== libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs ===================================== @@ -0,0 +1,47 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ImplicitParams #-} +module GHC.Stack.Annotation.Experimental where + +import Data.Typeable +import GHC.Exts +import GHC.Internal.Stack.Types + +data StackAnnotation where + StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation + +class IsStackAnnotation a where + display :: a -> String + +newtype SrcLocAnno = MkSrcLocAnno SrcLoc + +instance Show SrcLocAnno where + show (MkSrcLocAnno l) = + concat + [ srcLocPackage l + , ":" + , srcLocModule l + , " " + , srcLocFile l + , ":" + , show $ srcLocStartLine l + , "-" + , show $ srcLocStartCol l + , ":" + , show $ srcLocEndLine l + , "-" + , show $ srcLocEndCol l + ] + +annotateStackWith :: forall a b. (Typeable a, Show a) => a -> b -> b +annotateStackWith ann = + annotateStack# (StackAnnotation ann) + +annotateCallStack :: HasCallStack => a -> a +annotateCallStack = + let + cs = getCallStack ?callStack + in case cs of + [] -> id + ((_, srcLoc):_) -> annotateStackWith (MkSrcLocAnno srcLoc) ===================================== libraries/ghc-heap/tests/ann_frame.hs ===================================== @@ -20,17 +20,36 @@ annotateStack ann = annotateStack# (StackAnnotation ann) hello :: Int -> Int -> Int -hello x y = annotateStack (x,y) $ unsafePerformIO $ do +hello x y = annotateStack (x,y) $ + decodeAndPrintAnnotationFrames $ + x + y + 42 +{-# OPAQUE hello #-} + +{-# NOINLINE decodeAndPrintAnnotationFrames #-} +decodeAndPrintAnnotationFrames :: a -> a +decodeAndPrintAnnotationFrames a = unsafePerformIO $ do stack <- GHC.Stack.CloneStack.cloneMyStack decoded <- GHC.Exts.Stack.Decode.decodeStack stack - print [ show x + print [ show a | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded - , StackAnnotation x <- pure $ unsafeCoerce ann + , StackAnnotation a <- pure $ unsafeCoerce ann ] - return $ x + y + 42 -{-# OPAQUE hello #-} + pure a main :: IO () -main = +main = do print $ hello 2 3 + print $ tailCallEx 4 5 + +{-# INLINE tailCallEx #-} +tailCallEx :: Int -> Int -> Int +tailCallEx a b = annotateStack "tailCallEx" $ foo a b + +{-# INLINE foo #-} +foo :: Int -> Int -> Int +foo a b = annotateStack "foo" $ bar $ a * b + +bar c = annotateStack "bar" $ + decodeAndPrintAnnotationFrames $ + c + c ===================================== libraries/ghc-heap/tests/ann_frame.stdout ===================================== @@ -0,0 +1,2 @@ +["(2,3)"] +47 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fc6bb03edccb8a06df85de26dd78536... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fc6bb03edccb8a06df85de26dd78536... You're receiving this email because of your account on gitlab.haskell.org.