summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-10-23 20:18:00 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-10-23 20:18:00 +0200
commit3e70d73d4499689840596598ea943296a34b53ab (patch)
tree458b32ae9d715e34612ae5a0b35900ee9b3c6ccc
parent10ca93f1eb318074f20f260565c180dd5f3ba96f (diff)
Start GDB session on signal captured by the debugger
-rw-r--r--src/GDB.hs41
-rw-r--r--src/Main.hs3
2 files changed, 30 insertions, 14 deletions
diff --git a/src/GDB.hs b/src/GDB.hs
index f829f5c..75f42fe 100644
--- a/src/GDB.hs
+++ b/src/GDB.hs
@@ -14,6 +14,7 @@ import Control.Monad.Identity
import Control.Monad.Reader
import Data.Char
+import Data.List
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
@@ -33,6 +34,7 @@ data GDB = GDB
, gdbResult :: MVar (ResultClass, [(Text, MiValue)])
, gdbInferiors :: MVar [Inferior]
, gdbThreadGroups :: TChan Text
+ , gdbOnCrash :: Process -> IO ()
}
gdbProcess :: GDB -> Process
@@ -42,6 +44,7 @@ data Inferior = Inferior
{ infProcess :: Process
, infPid :: Pid
, infThreadGroup :: Text
+ , infThreads :: [Text]
}
data MiRecord = ResultRecord ResultClass [(Text, MiValue)]
@@ -65,8 +68,8 @@ data MiValue = MiString Text
gdbCmd :: String
gdbCmd = "gdb --quiet --interpreter=mi3"
-gdbStart :: (MonadOutput m, MonadFail m) => m GDB
-gdbStart = do
+gdbStart :: (MonadOutput m, MonadFail m) => (Process -> IO ()) -> m GDB
+gdbStart onCrash = do
(Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell gdbCmd)
{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
}
@@ -85,6 +88,7 @@ gdbStart = do
<*> liftIO newEmptyMVar
<*> liftIO (newMVar [])
<*> liftIO newTChanIO
+ <*> pure onCrash
out <- getOutput
liftIO $ void $ forkIO $ flip runReaderT out $
@@ -106,18 +110,28 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro
where
go = \case
ResultRecord cls params -> liftIO $ putMVar (gdbResult gdb) (cls, params)
- ExecAsyncOutput cls params -> outProc OutputChildInfo (gdbProcess gdb) $ "exec: " <> cls <> " " <> T.pack (show params)
+ ExecAsyncOutput cls params -> (cls,) <$> liftIO (readMVar (gdbInferiors gdb)) >>= \case
+ ("stopped", infs)
+ | Just (MiString "signal-received") <- lookup "reason" params
+ , Just (MiString tid) <- lookup "thread-id" params
+ , Just inf <- find (elem tid . infThreads) infs
+ -> liftIO $ gdbOnCrash gdb $ infProcess inf
+ _ -> return ()
StatusAsyncOutput cls params -> outProc OutputChildInfo (gdbProcess gdb) $ "status: " <> cls <> " " <> T.pack (show params)
NotifyAsyncOutput cls params -> case cls of
- "library-loaded" -> return ()
- "library-unloaded" -> return ()
- "cmd-param-changed" -> 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 ()
- _ -> outProc OutputChildInfo (gdbProcess gdb) $ "notify: " <> cls <> " " <> T.pack (show params)
+ "thread-group-exited" | Just (MiString tgid) <- lookup "id" params -> do
+ liftIO $ modifyMVar_ (gdbInferiors gdb) $ return . filter ((/=tgid) . infThreadGroup)
+ "thread-created"
+ | Just (MiString tid) <- lookup "id" params
+ , Just (MiString tgid) <- lookup "group-id" params
+ -> liftIO $ modifyMVar_ (gdbInferiors gdb) $ return . map (\inf -> if infThreadGroup inf == tgid then inf { infThreads = tid : infThreads inf } else inf)
+ "thread-exited"
+ | Just (MiString tid) <- lookup "id" params
+ , Just (MiString tgid) <- lookup "group-id" params
+ -> liftIO $ modifyMVar_ (gdbInferiors gdb) $ return . map (\inf -> if infThreadGroup inf == tgid then inf { infThreads = filter (/=tid) $ infThreads inf } else inf)
+ _ -> return ()
ConsoleStreamOutput line -> mapM_ (outProc OutputChildStdout (gdbProcess gdb)) (T.lines line)
TargetStreamOutput line -> mapM_ (outProc OutputChildStderr (gdbProcess gdb) . ("target-stream: " <>)) (T.lines line)
LogStreamOutput line -> mapM_ (outProc OutputChildInfo (gdbProcess gdb) . ("log: " <>)) (T.lines line)
@@ -133,15 +147,16 @@ addInferior gdb process = 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
+ , infThreads = []
}
+ gdbCommand gdb $ "-target-attach --thread-group " <> tgid <> " " <> T.pack (show pid)
+ gdbCommand gdb $ "-exec-continue --thread-group " <> tgid
+
gdbCommand :: MonadOutput m => GDB -> Text -> m ()
gdbCommand gdb cmd = do
send (gdbProcess gdb) cmd
diff --git a/src/Main.hs b/src/Main.hs
index f44ce83..9d2f9cc 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -150,7 +150,8 @@ initNetwork inner = do
useGDB <- asks $ optGDB . teOptions . fst
mgdb <- if useGDB
then do
- gdb <- gdbStart
+ failedVar <- asks $ teFailed . fst
+ gdb <- gdbStart $ atomically . writeTVar failedVar . Just . ProcessCrashed
liftIO $ modifyMVar_ (netProcesses net) $ return . (gdbProcess gdb:)
Just <$> liftIO (newMVar gdb)
else return Nothing