rework debugger communication framework to have separate sync and async channels

csabahruska · csabahruska · commit 46ac63fd7e2a · 2023-05-18T16:41:24.000+02:00
diff --git a/external-stg-interpreter/app/ExtStgInterpreter.hs b/external-stg-interpreter/app/ExtStgInterpreter.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase, RecordWildCards #-}
 
 import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi
+import Control.Concurrent.MVar
 
 import Options.Applicative
 import Data.Semigroup ((<>))
@@ -60,12 +61,18 @@ main = do
         { dsKeepGCFacts = keepGCFacts
         }
 
-  (dbgCmdI, dbgCmdO) <- Unagi.newChan 100
-  (dbgOutI, dbgOutO) <- Unagi.newChan 100
-  let dbgChan = DebuggerChan (dbgCmdO, dbgOutI)
+  (dbgAsyncI, dbgAsyncO) <- Unagi.newChan 100
+  dbgRequestMVar <- newEmptyMVar
+  dbgResponseMVar <- newEmptyMVar
+  let dbgChan = DebuggerChan
+        { dbgSyncRequest    = dbgRequestMVar
+        , dbgSyncResponse   = dbgResponseMVar
+        , dbgAsyncEventIn   = dbgAsyncI
+        , dbgAsyncEventOut  = dbgAsyncO
+        }
 
   case runDebugger of
-    True  -> debugProgram switchCWD appPath appArgs dbgChan dbgCmdI dbgOutO dbgScript debugSettings
+    True  -> debugProgram switchCWD appPath appArgs dbgChan dbgScript debugSettings
     False -> loadAndRunProgram isQuiet switchCWD appPath appArgs dbgChan DbgRunProgram doTracing debugSettings
 
 dropRtsOpts :: [String] -> [String]
diff --git a/external-stg-interpreter/lib/Stg/Interpreter.hs b/external-stg-interpreter/lib/Stg/Interpreter.hs
@@ -397,10 +397,6 @@ contextSwitchTimer = do
 
 evalStackMachine :: [Atom] -> M [Atom]
 evalStackMachine result = do
-  (_, dbgOut) <- getDebuggerChan <$> gets ssDebuggerChan
-  --liftIO $ Unagi.writeChan dbgOut $ DbgOutResult result
-  --liftIO $ putStrLn $ "evalStackMachine resultIn = " ++ show result
-
   stackPop >>= \case
     Nothing         -> pure result
     Just stackCont  -> do
@@ -861,9 +857,6 @@ runProgram isQuiet switchCWD progFilePath mods0 progArgs dbgChan dbgState tracin
         when (dbgState == DbgStepByStep) $ do
           Debugger.processCommandsUntilExit
 
-  let (dbgCmdO, _) = getDebuggerChan dbgChan
-  nextDbgCmd <- NextDebugCommand <$> Unagi.tryReadChan dbgCmdO
-
   tracingState <- case tracing of
     False -> pure NoTracing
     True  -> do
@@ -887,7 +880,7 @@ runProgram isQuiet switchCWD progFilePath mods0 progArgs dbgChan dbgState tracin
           _ -> pure ()
   flip catch (\e -> do {freeResources; throw (e :: SomeException)}) $ do
     now <- getCurrentTime
-    s@StgState{..} <- execStateT run (emptyStgState now isQuiet stateStore dl dbgChan nextDbgCmd dbgState tracingState debugSettings gcIn gcOut)
+    s@StgState{..} <- execStateT run (emptyStgState now isQuiet stateStore dl dbgChan dbgState tracingState debugSettings gcIn gcOut)
     when switchCWD $ setCurrentDirectory currentDir
     freeResources
 
diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Base.hs b/external-stg-interpreter/lib/Stg/Interpreter/Base.hs
@@ -221,17 +221,21 @@ newtype PrintableMVar a = PrintableMVar {unPrintableMVar :: MVar a} deriving Eq
 instance Show (PrintableMVar a) where
   show _ = "MVar"
 
-newtype DebuggerChan = DebuggerChan {getDebuggerChan :: (OutChan DebugCommand, InChan DebugOutput)} deriving Eq
+data DebuggerChan
+  = DebuggerChan
+  { dbgSyncRequest    :: MVar DebugRequest
+  , dbgSyncResponse   :: MVar DebugResponse
+  , dbgAsyncEventIn   :: InChan DebugEvent
+  , dbgAsyncEventOut  :: OutChan DebugEvent
+  }
+  deriving Eq
+
 instance Show DebuggerChan where
   show _ = "DebuggerChan"
 
-newtype NextDebugCommand = NextDebugCommand (Element DebugCommand, IO DebugCommand)
-instance Show NextDebugCommand where
-  show _ = "NextDebugCommand"
-instance Eq NextDebugCommand where
-   _ == _ = True
-instance Ord NextDebugCommand where
-   compare _ _ = EQ
+type DebugRequest = DebugCommand
+type DebugResponse = DebugOutput
+type DebugEvent = DebugOutput
 
 data DebugCommand
   = CmdListClosures
@@ -252,6 +256,7 @@ data DebugOutput
   | DbgOutThreadReport    !Int !ThreadState !Name !Addr String
   | DbgOutHeapObject      !Addr !HeapObject
   | DbgOutResult          ![Atom]
+  | DbgOut
   deriving (Show)
 
 data DebugState
@@ -402,7 +407,6 @@ data StgState
 
   -- debugger API
   , ssDebuggerChan        :: DebuggerChan
-  , ssNextDebugCommand    :: NextDebugCommand
 
   , ssEvaluatedClosures   :: !(Set Name)
   , ssBreakpoints         :: !(Map Name Int)
@@ -440,21 +444,20 @@ data StgState
 
 -- for the primop tests
 fakeStgStateForPrimopTests :: StgState
-fakeStgStateForPrimopTests = emptyStgState undefined undefined undefined undefined undefined undefined DbgRunProgram NoTracing defaultDebugSettings undefined undefined
+fakeStgStateForPrimopTests = emptyStgState undefined undefined undefined undefined undefined DbgRunProgram NoTracing defaultDebugSettings undefined undefined
 
 emptyStgState :: UTCTime
               -> Bool
               -> PrintableMVar StgState
               -> DL
               -> DebuggerChan
-              -> NextDebugCommand
               -> DebugState
               -> TracingState
               -> DebugSettings
               -> PrintableMVar ([Atom], StgState)
               -> PrintableMVar RefSet
               -> StgState
-emptyStgState now isQuiet stateStore dl dbgChan nextDbgCmd dbgState tracingState debugSettings gcIn gcOut = StgState
+emptyStgState now isQuiet stateStore dl dbgChan dbgState tracingState debugSettings gcIn gcOut = StgState
   { ssHeap                = mempty
   , ssStaticGlobalEnv     = mempty
 
@@ -537,7 +540,6 @@ emptyStgState now isQuiet stateStore dl dbgChan nextDbgCmd dbgState tracingState
 
   -- debugger api
   , ssDebuggerChan        = dbgChan
-  , ssNextDebugCommand    = nextDbgCmd
 
   , ssEvaluatedClosures   = Set.empty
   , ssBreakpoints         = mempty
diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger.hs
@@ -7,50 +7,40 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi
+import Control.Concurrent.MVar
 
 import Stg.Interpreter.Base
 import Stg.Syntax
 
 import Stg.Interpreter.Debugger.Internal
 
-fetchNextDebugCommand :: M ()
-fetchNextDebugCommand = do
-  (dbgCmd, _dbgOut) <- getDebuggerChan <$> gets ssDebuggerChan
-  nextCmd <- liftIO $ Unagi.tryReadChan dbgCmd
-  modify' $ \s@StgState{..} -> s {ssNextDebugCommand = NextDebugCommand nextCmd}
-
 getNextDebugCommand :: M DebugCommand
 getNextDebugCommand = do
-  NextDebugCommand (_, nextCmd) <- gets ssNextDebugCommand
-  fetchNextDebugCommand
-  liftIO nextCmd
+  DebuggerChan{..} <- gets ssDebuggerChan
+  liftIO $ takeMVar dbgSyncRequest
 
 tryNextDebugCommand :: M (Maybe DebugCommand)
 tryNextDebugCommand = do
-  NextDebugCommand (nextCmd, _) <- gets ssNextDebugCommand
-  liftIO (Unagi.tryRead nextCmd) >>= \case
-    Nothing -> pure Nothing
-    c@Just{} -> do
-      fetchNextDebugCommand
-      pure c
+  DebuggerChan{..} <- gets ssDebuggerChan
+  liftIO (tryTakeMVar dbgSyncRequest)
 
 runDebugCommand :: HasCallStack => DebugCommand -> M ()
 runDebugCommand cmd = do
   liftIO $ putStrLn $ "runDebugCommand: " ++ show cmd
-  (_, dbgOut) <- getDebuggerChan <$> gets ssDebuggerChan
+  DebuggerChan{..} <- gets ssDebuggerChan
   case cmd of
     CmdCurrentClosure -> do
       currentClosure <- gets ssCurrentClosure
       currentClosureAddr <- gets ssCurrentClosureAddr
       closureEnv <- gets ssCurrentClosureEnv
-      liftIO $ Unagi.writeChan dbgOut $ DbgOutCurrentClosure currentClosure currentClosureAddr closureEnv
+      liftIO $ putMVar dbgSyncResponse $ DbgOutCurrentClosure currentClosure currentClosureAddr closureEnv
 
     CmdClearClosureList -> do
       modify' $ \s@StgState{..} -> s {ssEvaluatedClosures = Set.empty}
 
     CmdListClosures -> do
       closures <- gets ssEvaluatedClosures
-      liftIO $ Unagi.writeChan dbgOut $ DbgOutClosureList $ Set.toList closures
+      liftIO $ putMVar dbgSyncResponse $ DbgOutClosureList $ Set.toList closures
 
     CmdAddBreakpoint n i -> do
       modify' $ \s@StgState{..} -> s {ssBreakpoints = Map.insert n i ssBreakpoints}
@@ -67,7 +57,7 @@ runDebugCommand cmd = do
       heap <- gets ssHeap
       when (IntMap.member addr heap) $ do
         ho <- readHeap $ HeapPtr addr
-        liftIO $ Unagi.writeChan dbgOut $ DbgOutHeapObject addr ho
+        liftIO $ putMVar dbgSyncResponse $ DbgOutHeapObject addr ho
 
     CmdStop -> do
       modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep}
@@ -112,7 +102,7 @@ checkBreakpoint breakpointName = do
   shouldStep <- hasFuel
   case dbgState of
     DbgStepByStep -> do
-      reportState
+      reportStateAsync
       unless exit processCommandsUntilExit
     DbgRunProgram -> do
       unless shouldStep $ modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep}
@@ -127,6 +117,6 @@ checkBreakpoint breakpointName = do
           | otherwise -> do
               -- HINT: trigger breakpoint
               liftIO $ putStrLn $ "hit breakpoint: " ++ show breakpointName
-              reportState
+              reportStateAsync
               modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep}
               unless exit processCommandsUntilExit
diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Internal.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/Internal.hs
@@ -15,6 +15,7 @@ import System.Console.Pretty
 
 import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi
 import Control.Concurrent (myThreadId)
+import Control.Concurrent.MVar
 
 import Stg.Interpreter.Base
 import Stg.Syntax
@@ -38,18 +39,28 @@ showOriginTrace i = do
           _ -> liftIO $ putStrLn str
   go i IntSet.empty
 
-reportState :: M ()
-reportState = do
-  (_, dbgOut) <- getDebuggerChan <$> gets ssDebuggerChan
+reportStateSync :: M ()
+reportStateSync = do
+  DebuggerChan{..} <- gets ssDebuggerChan
+  msg <- getThreadReport
+  liftIO $ putMVar dbgSyncResponse msg
+
+reportStateAsync :: M ()
+reportStateAsync = do
+  DebuggerChan{..} <- gets ssDebuggerChan
+  msg <- getThreadReport
+  liftIO $ Unagi.writeChan dbgAsyncEventIn msg
+
+getThreadReport :: M DebugOutput
+getThreadReport = do
   tid <- gets ssCurrentThreadId
   ts <- getThreadState tid
   currentClosure <- gets ssCurrentClosure >>= \case
     Nothing -> pure ""
     Just (Id c) -> pure $ binderUniqueName c
   currentClosureAddr <- gets ssCurrentClosureAddr
-  liftIO $ do
-    ntid <- myThreadId
-    Unagi.writeChan dbgOut $ DbgOutThreadReport tid ts currentClosure currentClosureAddr (show ntid)
+  ntid <- liftIO $ myThreadId
+  pure $ DbgOutThreadReport tid ts currentClosure currentClosureAddr (show ntid)
 
 showRetainer :: Int -> M ()
 showRetainer i = do
@@ -305,7 +316,7 @@ dbgCommands =
 
   , ( ["get-current-thread-state"]
     , "reports the currently running thread state"
-    , \_ -> reportState
+    , \_ -> reportStateSync
     )
 
   ]
diff --git a/external-stg-interpreter/lib/Stg/Interpreter/Debugger/UI.hs b/external-stg-interpreter/lib/Stg/Interpreter/Debugger/UI.hs
