summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-10-21 21:52:46 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-10-21 22:03:27 +0200
commit10ca93f1eb318074f20f260565c180dd5f3ba96f (patch)
tree5b4fcfdf11bf7e4e88a21a4f9ec7b8402404d3ad
parent1126c354e8527a94a3144a3381b81126e1a206e2 (diff)
Handle GDB thread groups properly
-rw-r--r--src/GDB.hs37
-rw-r--r--src/Main.hs6
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:)