module Gdbmi.IO
(
Context, Config(..), Callback(..)
, default_config
, setup, shutdown, send_command
) where
import Control.Applicative ((<*>), (<$>))
import Control.Concurrent (forkIO, killThread, ThreadId, MVar, newEmptyMVar, tryTakeMVar, putMVar, takeMVar)
import Control.Concurrent.STM (TVar, TChan, TMVar, newEmptyTMVar, newTVarIO, newTChanIO, atomically, takeTMVar, readTVar, writeTVar, writeTChan, readTChan, putTMVar)
import Control.Exception (catchJust)
import Control.Exception.Base (AsyncException(ThreadKilled))
import Control.Monad (replicateM_, when)
import Control.Monad.Fix (mfix)
import Data.List (partition)
import Prelude hiding (catch, interact)
import System.IO (Handle, hSetBuffering, BufferMode(LineBuffering), hPutStr, hWaitForInput, hGetLine, IOMode(WriteMode), stdout, openFile, hFlush, hClose)
import System.Posix.IO (fdToHandle, createPipe)
import System.Process (ProcessHandle, runProcess, waitForProcess)
import qualified Gdbmi.Commands as C
import qualified Gdbmi.Representation as R
import qualified Gdbmi.Semantics as S
data Context = Context {
ctxProcess :: ProcessHandle
, ctxCommandPipe :: Handle
, ctxOutputPipe :: Handle
, ctxLog :: Maybe Handle
, ctxCallback :: Callback
, ctxCommandThread :: ThreadId
, ctxOutputThread :: ThreadId
, ctxCurrentJob :: MVar Job
, ctxFinished :: MVar ()
, ctxNextToken :: TVar R.Token
, ctxJobs :: TChan Job
}
data Job = Job {
jobCommand :: R.Command
, jobResponse :: TMVar R.Response
, jobToken :: R.Token
}
data Callback
= Callback {
cbStream :: [R.Stream] -> IO ()
, cbNotify :: [R.Notification] -> IO ()
, cbStopped :: Maybe ([S.Stopped] -> IO ())
}
data Config
= Config {
confCommandLine :: [String]
, confLogfile :: Maybe FilePath
}
default_config :: Config
default_config = Config ["gdb"] Nothing
setup :: Config -> Callback -> IO Context
setup config callback = do
(commandR, commandW) <- createPipe >>= asHandles
(outputR, outputW) <- createPipe >>= asHandles
phandle <- runProcess "setsid" (confCommandLine config ++ ["--interpreter", "mi"])
Nothing Nothing
(Just commandR)
(Just outputW)
Nothing
mapM_ (`hSetBuffering` LineBuffering) [commandW, outputR]
logH <- case (confLogfile config) of
Nothing -> return $ Nothing
Just "-" -> return $ Just stdout
Just f -> fmap Just $ openFile f WriteMode
currentJob <- newEmptyMVar
finished <- newEmptyMVar
nextToken <- newTVarIO 0
jobs <- newTChanIO
ctx <- mfix (\ctx -> do
itid <- forkIO (handleCommands ctx)
otid <- forkIO (handleOutput ctx)
return $ Context phandle commandW outputR logH callback itid otid currentJob finished nextToken jobs
)
return ctx
where
asHandles (f1, f2) = do
h1 <- fdToHandle f1
h2 <- fdToHandle f2
return (h1, h2)
shutdown :: Context -> IO ()
shutdown ctx = do
mapM_ (killThread . ($ctx)) [ctxCommandThread, ctxOutputThread]
replicateM_ 2 (takeMVar (ctxFinished ctx))
writeCommand ctx C.gdb_exit 0
_ <- waitForProcess (ctxProcess ctx)
putMVar (ctxFinished ctx) ()
case ctxLog ctx of
Nothing -> return ()
Just handle ->
if handle /= stdout
then hClose handle
else return ()
send_command :: Context -> R.Command -> IO R.Response
send_command ctx command = checkShutdown >> sendCommand >>= receiveResponse
where
checkShutdown = do
finished <- tryTakeMVar (ctxFinished ctx)
case finished of
Nothing -> return ()
Just () -> error "context has already been shut down"
sendCommand = atomically $ do
token <- readTVar (ctxNextToken ctx)
writeTVar (ctxNextToken ctx) (if token == maxBound then 0 else token + 1)
response <- newEmptyTMVar
writeTChan (ctxJobs ctx) $ Job command response token
return response
receiveResponse = atomically . takeTMVar
handleCommands :: Context -> IO ()
handleCommands ctx = handleKill ctx $ do
job <- atomically $ readTChan (ctxJobs ctx)
putMVar (ctxCurrentJob ctx) job
writeCommand ctx (jobCommand job) (jobToken job)
handleCommands ctx
handleOutput :: Context -> IO ()
handleOutput ctx = handleKill ctx $ do
output <- readOutput ctx
_ <- callBack ctx output
case R.output_response output of
Nothing -> return ()
Just response -> do
maybJob <- tryTakeMVar (ctxCurrentJob ctx)
case maybJob of
Nothing -> error "result record lost!"
Just job ->
if (R.get_token output /= Just (jobToken job))
then error $ "token missmatch! " ++ show (R.get_token output) ++ " vs. " ++ show (jobToken job)
else atomically $ putTMVar (jobResponse job) response
handleOutput ctx
callBack :: Context -> R.Output -> IO ()
callBack ctx output = forkIO go >> return ()
where
go =
let
callbacks = ctxCallback ctx
streamsCb = cbStream callbacks
notifyCb = cbNotify callbacks
stoppedCbMb = cbStopped callbacks
streams = R.output_stream output
notifications = R.output_notification output
(stops, others) = partition ((&&) <$> (R.Exec==) . R.notiClass <*> (R.ACStop==) . R.notiAsyncClass) notifications
Just stops' = sequence $ map (S.notification_stopped . R.notiResults) stops
in case stoppedCbMb of
Nothing -> do
when (not (null streams)) (streamsCb streams)
when (not (null notifications)) (notifyCb notifications)
Just stoppedCb -> do
when (not (null streams)) (streamsCb streams)
when (not (null others)) (notifyCb others)
when (not (null stops')) (stoppedCb stops')
handleKill :: Context -> IO () -> IO ()
handleKill ctx action = catchJust select action handler
where
select :: AsyncException -> Maybe ()
select ThreadKilled = Just ()
select _ = Nothing
handler :: () -> IO ()
handler _ = putMVar (ctxFinished ctx) ()
writeCommand :: Context -> R.Command -> R.Token -> IO ()
writeCommand ctx cmd token =
let cmdstr = (R.render_command . C.set_token token) cmd in
do
debugLog ctx True cmdstr
hPutStr (ctxCommandPipe ctx) cmdstr
readOutput :: Context -> IO R.Output
readOutput ctx = do
_ <- hWaitForInput (ctxOutputPipe ctx) (1)
str <- outputString (ctxOutputPipe ctx)
debugLog ctx False str
return (R.parse_output str)
where
outputString handle = outputLines handle >>= return . unlines
outputLines handle = do
line <- hGetLine handle
if line == "(gdb) "
then return [line]
else outputLines handle >>= return . (line:)
debugLog :: Context -> Bool -> String -> IO ()
debugLog ctx io text =
let
prefix = if io then "/i " else "/o "
line = ((unlines . map (prefix++) . lines) text)
in
case (ctxLog ctx) of
Nothing -> return ()
Just h -> hPutStr h line >> hFlush h