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
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:
| ... | ... | @@ -36,6 +36,7 @@ library |
| 36 | 36 | GHC.TypeLits.Experimental
|
| 37 | 37 | GHC.TypeNats.Experimental
|
| 38 | 38 | GHC.RTS.Flags.Experimental
|
| 39 | + GHC.Stack.Annotation.Experimental
|
|
| 39 | 40 | GHC.Stats.Experimental
|
| 40 | 41 | Prelude.Experimental
|
| 41 | 42 | if arch(wasm32)
|
| 1 | +{-# LANGUAGE GADTs #-}
|
|
| 2 | +{-# LANGUAGE ScopedTypeVariables #-}
|
|
| 3 | +{-# LANGUAGE MagicHash #-}
|
|
| 4 | +{-# LANGUAGE ImplicitParams #-}
|
|
| 5 | +module GHC.Stack.Annotation.Experimental where
|
|
| 6 | + |
|
| 7 | +import Data.Typeable
|
|
| 8 | +import GHC.Exts
|
|
| 9 | +import GHC.Internal.Stack.Types
|
|
| 10 | + |
|
| 11 | +data StackAnnotation where
|
|
| 12 | + StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation
|
|
| 13 | + |
|
| 14 | +class IsStackAnnotation a where
|
|
| 15 | + display :: a -> String
|
|
| 16 | + |
|
| 17 | +newtype SrcLocAnno = MkSrcLocAnno SrcLoc
|
|
| 18 | + |
|
| 19 | +instance Show SrcLocAnno where
|
|
| 20 | + show (MkSrcLocAnno l) =
|
|
| 21 | + concat
|
|
| 22 | + [ srcLocPackage l
|
|
| 23 | + , ":"
|
|
| 24 | + , srcLocModule l
|
|
| 25 | + , " "
|
|
| 26 | + , srcLocFile l
|
|
| 27 | + , ":"
|
|
| 28 | + , show $ srcLocStartLine l
|
|
| 29 | + , "-"
|
|
| 30 | + , show $ srcLocStartCol l
|
|
| 31 | + , ":"
|
|
| 32 | + , show $ srcLocEndLine l
|
|
| 33 | + , "-"
|
|
| 34 | + , show $ srcLocEndCol l
|
|
| 35 | + ]
|
|
| 36 | + |
|
| 37 | +annotateStackWith :: forall a b. (Typeable a, Show a) => a -> b -> b
|
|
| 38 | +annotateStackWith ann =
|
|
| 39 | + annotateStack# (StackAnnotation ann)
|
|
| 40 | + |
|
| 41 | +annotateCallStack :: HasCallStack => a -> a
|
|
| 42 | +annotateCallStack =
|
|
| 43 | + let
|
|
| 44 | + cs = getCallStack ?callStack
|
|
| 45 | + in case cs of
|
|
| 46 | + [] -> id
|
|
| 47 | + ((_, srcLoc):_) -> annotateStackWith (MkSrcLocAnno srcLoc) |
| ... | ... | @@ -20,17 +20,36 @@ annotateStack ann = |
| 20 | 20 | annotateStack# (StackAnnotation ann)
|
| 21 | 21 | |
| 22 | 22 | hello :: Int -> Int -> Int
|
| 23 | -hello x y = annotateStack (x,y) $ unsafePerformIO $ do
|
|
| 23 | +hello x y = annotateStack (x,y) $
|
|
| 24 | + decodeAndPrintAnnotationFrames $
|
|
| 25 | + x + y + 42
|
|
| 26 | +{-# OPAQUE hello #-}
|
|
| 27 | + |
|
| 28 | +{-# NOINLINE decodeAndPrintAnnotationFrames #-}
|
|
| 29 | +decodeAndPrintAnnotationFrames :: a -> a
|
|
| 30 | +decodeAndPrintAnnotationFrames a = unsafePerformIO $ do
|
|
| 24 | 31 | stack <- GHC.Stack.CloneStack.cloneMyStack
|
| 25 | 32 | decoded <- GHC.Exts.Stack.Decode.decodeStack stack
|
| 26 | - print [ show x
|
|
| 33 | + print [ show a
|
|
| 27 | 34 | | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded
|
| 28 | - , StackAnnotation x <- pure $ unsafeCoerce ann
|
|
| 35 | + , StackAnnotation a <- pure $ unsafeCoerce ann
|
|
| 29 | 36 | ]
|
| 30 | - return $ x + y + 42
|
|
| 31 | -{-# OPAQUE hello #-}
|
|
| 37 | + pure a
|
|
| 32 | 38 | |
| 33 | 39 | main :: IO ()
|
| 34 | -main =
|
|
| 40 | +main = do
|
|
| 35 | 41 | print $ hello 2 3
|
| 42 | + print $ tailCallEx 4 5
|
|
| 43 | + |
|
| 44 | +{-# INLINE tailCallEx #-}
|
|
| 45 | +tailCallEx :: Int -> Int -> Int
|
|
| 46 | +tailCallEx a b = annotateStack "tailCallEx" $ foo a b
|
|
| 47 | + |
|
| 48 | +{-# INLINE foo #-}
|
|
| 49 | +foo :: Int -> Int -> Int
|
|
| 50 | +foo a b = annotateStack "foo" $ bar $ a * b
|
|
| 51 | + |
|
| 52 | +bar c = annotateStack "bar" $
|
|
| 53 | + decodeAndPrintAnnotationFrames $
|
|
| 54 | + c + c
|
|
| 36 | 55 |
| 1 | +["(2,3)"]
|
|
| 2 | +47 |