From 10ca93f1eb318074f20f260565c180dd5f3ba96f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Fri, 21 Oct 2022 21:52:46 +0200
Subject: Handle GDB thread groups properly

---
 src/GDB.hs  | 37 +++++++++++++++++++++++++++++++------
 src/Main.hs |  6 +-----
 2 files changed, 32 insertions(+), 11 deletions(-)

diff --git a/src/GDB.hs b/src/GDB.hs
index 7204c89..f829f5c 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -31,11 +31,19 @@ import Process
 data GDB = GDB
     { gdbProcess_ :: Process
     , gdbResult :: MVar (ResultClass, [(Text, MiValue)])
+    , gdbInferiors :: MVar [Inferior]
+    , gdbThreadGroups :: TChan Text
     }
 
 gdbProcess :: GDB -> Process
 gdbProcess = gdbProcess_
 
+data Inferior = Inferior
+    { infProcess :: Process
+    , infPid :: Pid
+    , infThreadGroup :: Text
+    }
+
 data MiRecord = ResultRecord ResultClass [(Text, MiValue)]
               | ExecAsyncOutput Text [(Text, MiValue)]
               | StatusAsyncOutput Text [(Text, MiValue)]
@@ -75,6 +83,8 @@ gdbStart = do
     gdb <- GDB
         <$> pure process
         <*> liftIO newEmptyMVar
+        <*> liftIO (newMVar [])
+        <*> liftIO newTChanIO
 
     out <- getOutput
     liftIO $ void $ forkIO $ flip runReaderT out $
@@ -102,7 +112,8 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro
             "library-loaded" -> return ()
             "library-unloaded" -> return ()
             "cmd-param-changed" -> return ()
-            "thread-group-added" -> return ()
+            "thread-group-added" | Just (MiString tgid) <- lookup "id" params -> do
+                liftIO $ atomically $ writeTChan (gdbThreadGroups gdb) tgid
             "thread-group-started" -> return ()
             "thread-created" -> return ()
             "thread-selected" -> return ()
@@ -111,11 +122,25 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro
         TargetStreamOutput line -> mapM_ (outProc OutputChildStderr (gdbProcess gdb) . ("target-stream: " <>)) (T.lines line)
         LogStreamOutput line -> mapM_ (outProc OutputChildInfo (gdbProcess gdb) . ("log: " <>)) (T.lines line)
 
-addInferior :: MonadOutput m => GDB -> Int -> Pid -> m ()
-addInferior gdb i pid = do
-    gdbCommand gdb $ "-add-inferior"
-    gdbCommand gdb $ "-target-attach --thread-group i" <> T.pack (show i) <> " " <> T.pack (show pid)
-    gdbCommand gdb $ "-exec-continue --thread-group i" <> T.pack (show i)
+addInferior :: MonadOutput m => GDB -> Process -> m ()
+addInferior gdb process = do
+    liftIO (getPid $ procHandle process) >>= \case
+        Nothing -> outProc OutputError process $ "failed to get PID"
+        Just pid -> do
+            tgid <- liftIO (atomically $ tryReadTChan $ gdbThreadGroups gdb) >>= \case
+                Just tgid -> return tgid
+                Nothing -> do
+                    gdbCommand gdb $ "-add-inferior"
+                    liftIO $ atomically $ readTChan $ gdbThreadGroups gdb
+
+            gdbCommand gdb $ "-target-attach --thread-group " <> tgid <> " " <> T.pack (show pid)
+            gdbCommand gdb $ "-exec-continue --thread-group " <> tgid
+
+            liftIO $ modifyMVar_ (gdbInferiors gdb) $ return . (:) Inferior
+                { infProcess = process
+                , infPid = pid
+                , infThreadGroup = tgid
+                }
 
 gdbCommand :: MonadOutput m => GDB -> Text -> m ()
 gdbCommand gdb cmd = do
diff --git a/src/Main.hs b/src/Main.hs
index 95aa83b..f44ce83 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -233,11 +233,7 @@ spawnOn target pname killWith cmd = do
 
     let net = either id nodeNetwork target
     asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= \case
-        Just gdb -> liftIO (getPid handle) >>= \case
-            Just pid -> do
-                ps <- liftIO $ readMVar (netProcesses net)
-                addInferior gdb (length ps) pid
-            Nothing -> return ()
+        Just gdb -> addInferior gdb process
         Nothing -> return ()
 
     liftIO $ modifyMVar_ (netProcesses net) $ return . (process:)
-- 
cgit v1.2.3