Add support for Stack annotations with optional source locations (#333)

Author: fendor

haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs

@@ -27,6 +27,7 @@ import GHC.Exts.Heap.Closures
 import GHC.Debugger.Runtime.Eval.RemoteExpr (RemoteExpr)
 import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote
 import GHC.Stack.Annotation.Experimental
+import GHC.Types.SrcLoc
 
 -- | Remote 'GHC.Stack.CloneStack.cloneThreadStack'
 cloneThreadStack :: RemoteExpr ThreadId -> RemoteExpr (IO StackSnapshot)
@@ -88,5 +89,10 @@ f `compose` g = Remote.app (Remote.app composeVar f) g where
   composeVar = Remote.var (mkModuleName "GHC.Base") "." []
 
 displayStackAnnotation :: RemoteExpr SomeStackAnnotation -> RemoteExpr String
-displayStackAnnotation = Remote.app $
-  Remote.var (mkModuleName "GHC.Stack.Annotation.Experimental") "displayStackAnnotation" ["GHC.Stack.Annotation.Experimental.SomeStackAnnotation"]
+displayStackAnnotation = Remote.app $ Remote.var (mkModuleName "GHC.Internal.Stack.Annotation") "displayStackAnnotation" ["GHC.Stack.Annotation.Experimental.SomeStackAnnotation"]
+
+displayStackAnnotationShort :: RemoteExpr SomeStackAnnotation -> RemoteExpr String
+displayStackAnnotationShort = Remote.app $ Remote.var (mkModuleName "GHC.Internal.Stack.Annotation") "displayStackAnnotationShort" ["GHC.Stack.Annotation.Experimental.SomeStackAnnotation"]
+
+stackAnnotationSourceLocation :: RemoteExpr SomeStackAnnotation -> RemoteExpr (Maybe SrcLoc)
+stackAnnotationSourceLocation = Remote.app $ Remote.var (mkModuleName "GHC.Internal.Stack.Annotation") "stackAnnotationSourceLocation" ["SGHC.Stack.Annotation.Experimental.omeStackAnnotation"]

haskell-debugger/GHC/Debugger/Runtime/Interpreter/Custom.hs

@@ -140,8 +140,8 @@ threadInfo threadId = do
 stackFrameInfo :: (StackFrame, Maybe InfoProv) -> IO (Maybe StackFrameInfo)
 stackFrameInfo (AnnFrame{annotation}, _)
   | let Box annVal = annotation
-  , let stack_anno = displayStackAnnotation @SomeStackAnnotation (unsafeCoerce annVal)
-  = pure $ Just $ StackFrameAnnotation Nothing{-No source locations yet-} stack_anno
+  , let stack_frame = stackAnnoToStackFrameInfo (unsafeCoerce @_ @SomeStackAnnotation annVal)
+  = pure $ Just stack_frame
 stackFrameInfo (_, Just ipe)
   = pure $ Just (StackFrameIPEInfo ipe)
 stackFrameInfo (RetBCO{bco}, _)
@@ -150,6 +150,14 @@ stackFrameInfo (RetBCO{bco}, _)
 stackFrameInfo _
   = pure Nothing
 
+stackAnnoToStackFrameInfo :: SomeStackAnnotation -> StackFrameInfo
+stackAnnoToStackFrameInfo stack_anno =
+#if MIN_VERSION_ghc_experimental(9,1402,0)
+  StackFrameAnnotation (stackAnnotationSourceLocation stack_anno) (displayStackAnnotationShort stack_anno)
+#else
+  StackFrameAnnotation Nothing {-No source locations yet-} (displayStackAnnotation stack_anno)
+#endif
+
 -- | Try to find a BRK_FUN breakpoint location at the start of a BCO heap closure
 lookupBCOBreakpoint :: Heap.GenClosure Box -> IO (Maybe InternalBreakpointId)
 lookupBCOBreakpoint Heap.BCOClosure{..}

haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs

@@ -287,10 +287,16 @@ parseList item_parser =
 intParser :: TermParser Int
 intParser = fromIntegral <$> wordParser
 
+intPrimParser :: TermParser Int
+intPrimParser = fromIntegral <$> primParser
+
 -- | Parse a 'Word'
 wordParser :: TermParser Word
 wordParser = subtermWith 0 primParser
 
+wordPrimParser :: TermParser Word
+wordPrimParser = primParser
+
 -- | Parse a 'String' term
 stringParser :: TermParser String
 stringParser = do
@@ -392,4 +398,3 @@ programTermParser =
 
 reifyBool :: Bool -> Debugger ForeignHValue
 reifyBool b = Comp.compileRaw (show b ++ ":: Bool")
-

haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs

@@ -148,9 +148,15 @@ stackAnnoParser = do
       Just Term{val} -> do
         stack_anno <- liftDebugger $
           expectRight =<< Remote.evalString
+#if MIN_VERSION_ghc_experimental(9,1402,0)
+            (Remote.displayStackAnnotationShort (Remote.ref (castForeignRef val)))
+#else
             (Remote.displayStackAnnotation (Remote.ref (castForeignRef val)))
+#endif
+
+        src_loc <- getOptionalStackAnnotationSrcLoc
 
-        pure $ Just (Nothing {- No source locations yet :( -}, stack_anno)
+        pure $ Just (src_loc, stack_anno)
       _ ->
         pure Nothing
 
@@ -170,6 +176,37 @@ bcoInternalBreakpointId = do
         , eb_info_index    = fromIntegral $ brk_info_ix_hi .<<. 16 + brk_info_ix_lo
         }
 
+getOptionalStackAnnotationSrcLoc :: TermParser (Maybe Stack.SrcLoc)
+#if MIN_VERSION_ghc_experimental(9,1402,0)
+getOptionalStackAnnotationSrcLoc = do
+  src_loc_fv <- liftDebugger $
+    expectRight =<< Remote.eval
+      (Remote.stackAnnotationSourceLocation (Remote.ref (castForeignRef val)))
+
+  src_loc_either <- liftDebugger $
+    obtainParsedTerm "Annotation SrcLoc" maxBound True anyTy (castForeignRef src_loc_fv) (maybeParser srcLocParser)
+
+  case src_loc_either of
+    Left err -> fail (show err)
+    Right t  -> return t
+ where
+  -- | Parse a 'SrcLoc'.
+  srcLocParser :: TermParser Stack.SrcLoc
+  srcLocParser = do
+    Stack.SrcLoc
+      <$> subtermWith 0 stringParser -- srcLocPackage
+      <*> subtermWith 1 stringParser -- srcLocModule
+      <*> subtermWith 2 stringParser -- srcLocFile
+      <*> subtermWith 3 intPrimParser -- unpacked srcLocStartLine
+      <*> subtermWith 4 intPrimParser -- unpacked srcLocStartCol
+      <*> subtermWith 5 intPrimParser -- unpacked srcLocEndLine
+      <*> subtermWith 6 intPrimParser -- unpacked srcLocEndCol
+#else
+getOptionalStackAnnotationSrcLoc = do
+  pure Nothing
+#endif
+
+
 -- | Parse a literal 'String' from a BCO given a valid index into the literals array
 bcoLiteralString :: Word -> TermParser String
 bcoLiteralString ix = do

test/golden/T159/T159.ghc-1001.hdb-stdout

@@ -1,5 +1,5 @@
 [1 of 2] Compiling Main             ( <TEMPORARY-DIRECTORY>/T159.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]
 (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}}
 (hdb) Stopped at breakpoint
-(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation, called at <TEMPORARY-DIRECTORY>/T159.hs:7:7 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4], called at <TEMPORARY-DIRECTORY>/T159.hs:6:5 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at <TEMPORARY-DIRECTORY>/T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}]
+(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 7, endLine = 7, startCol = 7, endCol = 28}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 6, endLine = 6, startCol = 5, endCol = 24}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159.hs", startLine = 5, endLine = 5, startCol = 3, endCol = 22}, breakId = Nothing}]
 (hdb) Exiting...

test/golden/T159b/T159b.ghc-1001.hdb-stdout

@@ -1,5 +1,5 @@
 [1 of 2] Compiling Main             ( <TEMPORARY-DIRECTORY>/T159b.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]
 (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}}
 (hdb) Stopped at breakpoint
-(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation, called at <TEMPORARY-DIRECTORY>/T159b.hs:7:7 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4], called at <TEMPORARY-DIRECTORY>/T159b.hs:6:5 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at <TEMPORARY-DIRECTORY>/T159b.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}]
+(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 7, endLine = 7, startCol = 7, endCol = 28}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 6, endLine = 6, startCol = 5, endCol = 24}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO", sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/T159b.hs", startLine = 5, endLine = 5, startCol = 3, endCol = 22}, breakId = Nothing}]
 (hdb) Exiting...

test/golden/T239/T239.fails-239.ghc-1001.hdb-stdout

@@ -1,6 +1,5 @@
-[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory]
-[2 of 3] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, interpreted )[main]
-(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 2], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 27, endLine = 27, startCol = 3, endCol = 28}}
+[1 of 2] Compiling Main             ( <TEMPORARY-DIRECTORY>/Main.hs, <TEMPORARY-DIRECTORY>/.hdb-cache/<CACHE-ENTRY>/Main.gbc )[main]
+(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "<TEMPORARY-DIRECTORY>/Main.hs", startLine = 27, endLine = 27, startCol = 3, endCol = 28}}
 (hdb) Stopped at breakpoint
 (hdb) _result : IO () = <fn> :: IO ()
 container : Container = Container

test/integration-tests/data/T159/T159.cabal

@@ -0,0 +1,12 @@
+cabal-version:   3.8
+name:            T159
+version:         0.1.0.0
+build-type:      Simple
+
+executable T159
+    main-is:          Main.hs
+    build-depends:    base,
+                      ghc-experimental,
+    hs-source-dirs:   app,
+    default-language: Haskell2010
+    ghc-options: -finfo-table-map

test/integration-tests/data/T159/app/Main.hs

@@ -0,0 +1,14 @@
+module Main (main) where
+
+import GHC.Stack.Annotation.Experimental
+
+main :: IO ()
+main = do
+  annotateCallStackIO $ do
+    annotateStackShowIO ([1..4] :: [Int]) $ do
+      annotateStackStringIO "Lovely annotation" $ do
+        foo 500
+
+foo :: Int -> IO ()
+foo arg =
+  putStrLn $ "foo: " <> show (arg * arg * arg)

test/integration-tests/data/T159/cabal.project

@@ -0,0 +1,3 @@
+packages: .
+
+with-compiler: /home/hugin/Documents/haskell/ghc-more-annotations/_default/stage1/bin/ghc