Introduce pause frame tracking

client/ghc-debug-client.cabal

@@ -19,6 +19,7 @@ library
                        network >=2.6 && <2.7,
                        unordered-containers,
                        ghc-debug-common, cpu,
-                       dwarfadt, dwarf-el, text, process, filepath, directory
+                       dwarfadt, dwarf-el, text, process, filepath, directory,
+                       mtl
   hs-source-dirs:      src
-  default-language:    Haskell2010
+  default-language:    Haskell2010

client/src/GHC/Debug/Client.hs

@@ -1,10 +1,15 @@
+{-# LANGUAGE GADTs #-}
+
 module GHC.Debug.Client
   ( Debuggee
+  , DebuggeeAction
+  , applyDebuggeeAction
   , withDebuggee
   , withDebuggeeSocket
   , pauseDebuggee
   , request
   , Request(..)
+  , getCurrentFrame
   , getInfoTblPtr
   , decodeClosure
   , decodeStack
@@ -26,6 +31,7 @@ module GHC.Debug.Client
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
+import Control.Monad.State.Lazy
 import GHC.Debug.Types
 import GHC.Debug.Decode
 import GHC.Debug.Decode.Stack
@@ -38,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
@@ -55,11 +62,18 @@ import System.Directory
 import Text.Printf
 
 data Debuggee = Debuggee { debuggeeHdl :: Handle
-                         , debuggeeInfoTblEnv :: MVar (HM.HashMap InfoTablePtr RawInfoTable)
+                         , debuggeeInfoTblEnv :: HM.HashMap InfoTablePtr RawInfoTable
                          , debuggeeDwarf :: Maybe Dwarf
                          , debuggeeFilename :: FilePath
+                         , debuggeeFrame :: Word32
                          }
 
+type DebuggeeAction a = StateT Debuggee IO a
+
+
+applyDebuggeeAction :: Debuggee -> DebuggeeAction a -> IO a
+applyDebuggeeAction = flip evalStateT
+
 
 debuggeeProcess :: FilePath -> FilePath -> IO CreateProcess
 debuggeeProcess exe sockName = do
@@ -69,7 +83,7 @@ debuggeeProcess exe sockName = do
 
 -- | Open a debuggee, this will also read the DWARF information
 withDebuggee :: FilePath  -- ^ path to executable
-             -> (Debuggee -> IO a)
+             -> DebuggeeAction a
              -> IO a
 withDebuggee exeName action = do
     let sockName = "/tmp/ghc-debug2"
@@ -86,33 +100,45 @@ withDebuggee exeName action = do
 withDebuggeeSocket :: FilePath  -- ^ executable name of the debuggee
                    -> FilePath  -- ^ debuggee's socket location
                    -> Maybe Dwarf
-                   -> (Debuggee -> IO a)
+                   -> DebuggeeAction a
                    -> IO a
 withDebuggeeSocket exeName sockName mdwarf action = do
     s <- socket AF_UNIX Stream defaultProtocol
     connect s (SockAddrUnix sockName)
     hdl <- socketToHandle s ReadWriteMode
-    infoTableEnv <- newMVar mempty
-    action (Debuggee hdl infoTableEnv mdwarf exeName)
+    evalStateT action (Debuggee hdl mempty mdwarf exeName 0)
 
 -- | Send a request to a 'Debuggee' paused with 'pauseDebuggee'.
-request :: Debuggee -> Request resp -> IO resp
-request d req = doRequest (debuggeeHdl d) req
+request :: Request resp -> DebuggeeAction resp
+request req = do
+    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 :: Debuggee -> RawClosure -> IO (RawInfoTable, RawClosure)
-lookupInfoTable d rc = do
+lookupInfoTable :: RawClosure -> DebuggeeAction (RawInfoTable, RawClosure)
+lookupInfoTable rc = do
     let ptr = getInfoTblPtr rc
-    itblEnv <- readMVar (debuggeeInfoTblEnv d)
+    itblEnv <- gets debuggeeInfoTblEnv
     case HM.lookup ptr itblEnv of
       Nothing -> do
-        [itbl] <- request d (RequestInfoTables [ptr])
-        modifyMVar_ (debuggeeInfoTblEnv d) $ return . HM.insert ptr itbl
+        [itbl] <- request (RequestInfoTables [ptr])
+        infoTblEnv <- gets debuggeeInfoTblEnv
+        modify' $ \s -> s { debuggeeInfoTblEnv = HM.insert ptr itbl infoTblEnv }
         return (itbl, rc)
       Just itbl ->  return (itbl, rc)
 
-pauseDebuggee :: Debuggee -> IO a -> IO a
-pauseDebuggee d =
-    bracket_ (void $ request d RequestPause) (void $ request d RequestResume)
+pauseDebuggee :: DebuggeeAction a -> DebuggeeAction a
+pauseDebuggee action = do
+    -- TODO: replace poor-mans bracket_ with proper implementation for StateT
+    request RequestPause
+    rc <- action
+    request RequestResume
+    return rc
 
 getDwarfInfo :: FilePath -> IO Dwarf
 getDwarfInfo fn = do
@@ -121,10 +147,12 @@ getDwarfInfo fn = do
 -- print $ DwarfPretty.dwarf dwarf
  return dwarf
 
-lookupDwarf :: Debuggee -> InfoTablePtr -> Maybe ([FilePath], Int, Int)
-lookupDwarf d (InfoTablePtr w) = do
-  (Dwarf units) <- debuggeeDwarf d
-  asum (map (lookupDwarfUnit (fromBE64 w)) units)
+lookupDwarf :: InfoTablePtr -> DebuggeeAction (Maybe ([FilePath], Int, Int))
+lookupDwarf (InfoTablePtr w) = do
+  mDwarf <- gets debuggeeDwarf
+  case mDwarf of
+    Nothing -> return Nothing
+    Just (Dwarf units) -> return $ asum (map (lookupDwarfUnit (fromBE64 w)) units)
 
 lookupDwarfUnit :: Word64 -> Boxed CompilationUnit -> Maybe ([FilePath], Int, Int)
 lookupDwarfUnit w (Boxed _ cu) = do
@@ -158,63 +186,66 @@ lookupDwarfLine w Nothing (d, nd) = do
     else Nothing
 lookupDwarfLine _ (Just r) _ =  Just r
 
-showFileSnippet :: Debuggee -> ([FilePath], Int, Int) -> IO ()
-showFileSnippet d (fps, l, c) = go fps
+showFileSnippet :: ([FilePath], Int, Int) -> DebuggeeAction ()
+showFileSnippet (fps, l, c) =  do
+  dbgFilename <- gets debuggeeFilename
+  liftIO $ go dbgFilename fps
   where
-    go [] = putStrLn ("No files could be found: " ++ show fps)
-    go (fp: fps) = do
-      exists <- doesFileExist fp
+    go :: FilePath -> [FilePath] -> IO ()
+    go _ [] = putStrLn ("No files could be found: " ++ show fps)
+    go dbgFilename (fp:fps) = do
+      exists <- liftIO $ doesFileExist $ fp
       -- get file modtime
       if not exists
-        then go fps
+        then go dbgFilename fps
         else do
-          fp `warnIfNewer` (debuggeeFilename d)
+          -- TODO: get the modtime of debuggee above
+          fp `warnIfNewer` dbgFilename
           src <- zip [1..] . lines <$> readFile fp
           let ctx = take 10 (drop (max (l - 5) 0) src)
           putStrLn (fp <> ":" <> show l <> ":" <> show c)
           mapM_ (\(n, l) ->
            let sn = show n
            in putStrLn (sn <> replicate (5 - length sn) ' ' <> l)) ctx
 
-dereferenceClosure :: Debuggee -> ClosurePtr -> IO Closure
-dereferenceClosure d c = head <$> dereferenceClosures d [c]
+dereferenceClosure :: ClosurePtr -> DebuggeeAction Closure
+dereferenceClosure c = head <$> dereferenceClosures [c]
 
-dereferenceClosures  :: Debuggee -> [ClosurePtr] -> IO [Closure]
-dereferenceClosures d cs = do
-    raw_cs <- request d (RequestClosures cs)
+dereferenceClosures :: [ClosurePtr] -> DebuggeeAction [Closure]
+dereferenceClosures cs = do
+    raw_cs <- request (RequestClosures cs)
     let its = map getInfoTblPtr raw_cs
     --print $ map (lookupDwarf d) its
-    raw_its <- request d (RequestInfoTables its)
+    raw_its <- request (RequestInfoTables its)
     return $ map (uncurry decodeClosure) (zip raw_its (zip cs raw_cs))
 
-dereferenceStack :: Debuggee -> StackCont -> IO Stack
-dereferenceStack d (StackCont stack) = do
-  print stack
-  i <- lookupInfoTable d (coerce stack)
+dereferenceStack :: StackCont -> DebuggeeAction Stack
+dereferenceStack (StackCont stack) = do
+  liftIO $ print stack
+  i <- lookupInfoTable (coerce stack)
   let st_it = decodeInfoTable . fst $ i
-  print i
-  print st_it
-  bt <- request d (RequestBitmap (getInfoTblPtr (coerce stack)))
+  liftIO $ print i
+  liftIO $ print st_it
+  bt <- request (RequestBitmap (getInfoTblPtr (coerce stack)))
   let decoded_stack = decodeStack stack st_it bt
-  print decoded_stack
+  liftIO $ print decoded_stack
   return decoded_stack
 
-dereferenceConDesc :: Debuggee -> ClosurePtr -> IO ConstrDesc
-dereferenceConDesc d i = do
-  request d (RequestConstrDesc i)
+dereferenceConDesc :: ClosurePtr -> DebuggeeAction ConstrDesc
+dereferenceConDesc i = request (RequestConstrDesc i)
 
 
-fullTraversal :: Debuggee -> ClosurePtr -> IO UClosure
-fullTraversal d c = do
-  dc <- dereferenceClosure d c
-  print dc
-  MkFix1 <$> tritraverse (dereferenceConDesc d) (fullStackTraversal d) (fullTraversal d)  dc
+fullTraversal :: ClosurePtr -> DebuggeeAction UClosure
+fullTraversal c = do
+  dc <- dereferenceClosure c
+  liftIO $ print dc
+  MkFix1 <$> tritraverse dereferenceConDesc fullStackTraversal fullTraversal  dc
 
-fullStackTraversal :: Debuggee -> StackCont -> IO UStack
-fullStackTraversal d sc = do
-  ds <- dereferenceStack d sc
-  print ds
-  MkFix2 <$> traverse (fullTraversal d) ds
+fullStackTraversal :: StackCont -> DebuggeeAction UStack
+fullStackTraversal sc = do
+  ds <- dereferenceStack sc
+  liftIO $ print ds
+  MkFix2 <$> traverse fullTraversal ds
 
 -- | Print a warning if source file (first argument) is newer than the binary (second argument)
 warnIfNewer :: FilePath -> FilePath -> IO ()
@@ -228,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

ghc-vis/src/GHC/Vis.hs

@@ -475,8 +475,9 @@ react dbg window canvas = do
 
 derefBox :: Debuggee -> DerefFunction
 derefBox dbg cp = do
-  c <- dereferenceClosure dbg cp
-  tritraverse (dereferenceConDesc dbg) pure pure c
+  let apply = applyDebuggeeAction dbg
+  c <- apply $ dereferenceClosure cp
+  tritraverse (\x -> apply $ dereferenceConDesc x) pure pure c
 
 runCorrect :: MonadIO m => (View -> f) -> m f
 runCorrect f = do

stub/Test.hs

@@ -27,7 +27,7 @@ main :: IO ()
 main = do
   start
   let !y = Data.Sequence.fromList [1..5]
-  -- let !y = [1..5]
+  let !y = [1..5]
   performGC
   saveClosures [Box y]
   print "start"

stub/cbits/stub.cpp

@@ -126,12 +126,12 @@ class Response {
             // Then status
             this->sock.write((char *) &status_payload, sizeof(uint16_t));
             // then the body, usually empty
-    trace("FLUSHING(%lu)( ", len);
-    for (int i = 0; i < len; i++)
-    {
-      trace("%02X", buf[i]);
-    }
-    trace("\n");
+            trace("FLUSHING(%lu)( ", len);
+            for (int i = 0; i < len; i++)
+            {
+              trace("%02X", buf[i]);
+            }
+            trace("\n");
             this->sock.write(this->buf, len);
             this->tail = this->buf;
         }
@@ -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;