1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
{-# LANGUAGE OverloadedStrings #-}
module GDB (
GDB, gdbProcess,
gdbStart,
addInferior,
gdbSession,
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Text qualified as T
import Data.Text.IO qualified as T
import System.IO.Error
import System.Process
import Output
import Process
data GDB = GDB
{ gdbProcess_ :: Process
}
gdbProcess :: GDB -> Process
gdbProcess = gdbProcess_
gdbCmd :: String
gdbCmd = "gdb --quiet --interpreter=mi3"
gdbStart :: (MonadOutput m, MonadFail m) => m GDB
gdbStart = do
(Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell gdbCmd)
{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
}
pout <- liftIO $ newTVarIO []
let process = Process
{ procName = ProcNameGDB
, procHandle = handle
, procStdin = hin
, procOutput = pout
, procKillWith = Nothing
, procNode = undefined
}
gdb = GDB
{ gdbProcess_ = process
}
out <- getOutput
liftIO $ void $ forkIO $ flip runReaderT out $
lineReadingLoop process hout $ outProc OutputChildStdout process
liftIO $ void $ forkIO $ flip runReaderT out $
lineReadingLoop process herr $ outProc OutputChildStderr process
send process "-gdb-set schedule-multiple on"
send process "-gdb-set mi-async on"
send process "-gdb-set print symbol-loading off"
return gdb
addInferior :: MonadIO m => GDB -> Int -> Pid -> m ()
addInferior GDB { gdbProcess_ = process } i pid = do
send process $ "-add-inferior"
send process $ "-target-attach --thread-group i" <> T.pack (show i) <> " " <> T.pack (show pid)
send process $ "-exec-continue --thread-group i" <> T.pack (show i)
gdbSession :: MonadOutput m => GDB -> m ()
gdbSession gdb = do
outPrompt "gdb> "
liftIO loop
outClearPrompt
where
loop = catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) >>= \case
Just line -> do
send (gdbProcess gdb) ("-interpreter-exec console \"" <> line <> "\"")
loop
Nothing -> return ()
|