Introduce pause frame tracking

* stub tracks the numbe of pauses, starting at zero.

* stub returns the current pause frame number on all pause requests

* Client.hs tracks the current pause frame number in Debuggee

Author: obreitwi

client/src/GHC/Debug/Client.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
 module GHC.Debug.Client
   ( Debuggee
   , DebuggeeAction
@@ -7,6 +9,7 @@ module GHC.Debug.Client
   , pauseDebuggee
   , request
   , Request(..)
+  , getCurrentFrame
   , getInfoTblPtr
   , decodeClosure
   , decodeStack
@@ -41,6 +44,7 @@ import System.Endian
 import Data.Foldable
 import Data.Coerce
 import Data.Bitraversable
+import Data.Word (Word32)
 
 
 import qualified Data.Dwarf as Dwarf
@@ -61,6 +65,7 @@ data Debuggee = Debuggee { debuggeeHdl :: Handle
                          , debuggeeInfoTblEnv :: HM.HashMap InfoTablePtr RawInfoTable
                          , debuggeeDwarf :: Maybe Dwarf
                          , debuggeeFilename :: FilePath
+                         , debuggeeFrame :: Word32
                          }
 
 type DebuggeeAction a = StateT Debuggee IO a
@@ -101,13 +106,19 @@ withDebuggeeSocket exeName sockName mdwarf action = do
     s <- socket AF_UNIX Stream defaultProtocol
     connect s (SockAddrUnix sockName)
     hdl <- socketToHandle s ReadWriteMode
-    evalStateT action (Debuggee hdl mempty mdwarf exeName)
+    evalStateT action (Debuggee hdl mempty mdwarf exeName 0)
 
 -- | Send a request to a 'Debuggee' paused with 'pauseDebuggee'.
 request :: Request resp -> DebuggeeAction resp
 request req = do
-  hdl <- gets debuggeeHdl
-  liftIO $ doRequest hdl req
+    hdl <- gets debuggeeHdl
+    payload <- liftIO $ doRequest hdl req
+    -- if we did a successful pause, the payload contains the current frame
+    -- number
+    case req of
+      RequestPause -> modify' $ \d -> d { debuggeeFrame = payload }
+      _ -> return ()
+    return payload
 
 lookupInfoTable :: RawClosure -> DebuggeeAction (RawInfoTable, RawClosure)
 lookupInfoTable rc = do
@@ -248,3 +259,7 @@ warnIfNewer fpSrc fpBin = do
           fpSrc fpBin
     else
       return ()
+
+-- | Return the current frame number
+getCurrentFrame :: DebuggeeAction Word32
+getCurrentFrame = gets debuggeeFrame

common/src/GHC/Debug/Types.hs

@@ -35,8 +35,8 @@ import GHC.Debug.Types.Ptr as T
 data Request a where
     -- | Request protocol version
     RequestVersion :: Request Word32
-    -- | Pause the debuggee.
-    RequestPause :: Request ()
+    -- | Pause the debuggee, get number of current pause frame.
+    RequestPause :: Request Word32
     -- | Resume the debuggee.
     RequestResume :: Request ()
     -- | Request the debuggee's root pointers.
@@ -136,7 +136,7 @@ putRequest (RequestFindPtr c)       =
 
 getResponse :: Request a -> Get a
 getResponse RequestVersion       = getWord32be
-getResponse RequestPause         = get
+getResponse RequestPause         = getWord32be
 getResponse RequestResume        = get
 getResponse RequestRoots         = many get
 getResponse (RequestClosures _)  = many getRawClosure

stub/cbits/stub.cpp

@@ -187,6 +187,8 @@ class Response {
 };
 
 static bool paused = false;
+// track how often the target was paused
+static uint32_t num_pause_frame = 0;
 static RtsPaused r_paused;
 static Response * r_poll_pause_resp = NULL;
 
@@ -199,6 +201,7 @@ void pause_mutator() {
       r_poll_pause_resp->finish(RESP_OKAY);
   }
   paused = true;
+  ++num_pause_frame;
 }
 
 extern "C"
@@ -282,9 +285,13 @@ static int handle_command(Socket& sock, const char *buf, uint32_t cmd_len) {
         trace("PAUSE: %d", paused);
         if (paused) {
             trace("ALREADY");
+            // even though we are already paused we tell the callee what pause
+            // frame we are in
+            resp.write(htonl(num_pause_frame));
             resp.finish(RESP_ALREADY_PAUSED);
         } else {
             pause_mutator();
+            resp.write(htonl(num_pause_frame));
             resp.finish(RESP_OKAY);
         }
         break;

test/Test.hs

@@ -4,12 +4,13 @@ import GHC.Debug.Client
 import GHC.Debug.Types.Graph
 
 import Control.Monad
-import Control.Monad.State.Lazy (liftIO, get)
+import Control.Monad.State.Lazy (liftIO, get, gets)
 import Debug.Trace
 import Control.Exception
 import Control.Concurrent
 import Data.Bitraversable
 import GHC.Vis
+import Text.Printf
 
 prog = "/home/matt/ghc-debug/dist-newstyle/build/x86_64-linux/ghc-8.9.0.20190806/ghc-debug-stub-0.1.0.0/x/debug-test/build/debug-test/debug-test"
 
@@ -201,3 +202,15 @@ p16 = do
   dbg <- get
   hg <- liftIO $ buildHeapGraph (derefBox dbg) 20 () so
   liftIO $ putStrLn $ ppHeapGraph hg
+
+p17 = do
+  printFrame
+  replicateM_ 20 $ do
+    printFrame
+    request RequestPause
+    request RequestResume
+  where
+    printFrame = do
+      frame <- getCurrentFrame
+      liftIO $ putStrLn $
+        printf "Current frame number: %d" frame