{-# LANGUAGE LambdaCase #-}
module GHC.Runtime.Interpreter.Process
(
Message(..)
, DelayedResponse (..)
, sendMessage
, sendMessageNoResponse
, sendMessageDelayedResponse
, receiveDelayedResponse
, sendAnyValue
, receiveAnyValue
, receiveTHMessage
)
where
import GHC.Prelude
import GHC.Runtime.Interpreter.Types
import GHCi.Message
import GHC.IO (catchException)
import GHC.Utils.Panic
import GHC.Utils.Exception as Ex
import Data.Binary
import System.Exit
import System.Process
import Control.Concurrent.MVar (MVar, withMVar, takeMVar, putMVar, isEmptyMVar)
data DelayedResponse a = DelayedResponse
sendMessageNoResponse :: ExtInterpInstance d -> Message () -> IO ()
sendMessageNoResponse :: forall d. ExtInterpInstance d -> Message () -> IO ()
sendMessageNoResponse ExtInterpInstance d
i Message ()
m =
ExtInterpInstance d -> IO () -> IO ()
forall d a. ExtInterpInstance d -> IO a -> IO a
withLock ExtInterpInstance d
i (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InterpProcess -> Put -> IO ()
writeInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) (Message () -> Put
forall a. Message a -> Put
putMessage Message ()
m)
sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage :: forall a d. Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage ExtInterpInstance d
i Message a
m = ExtInterpInstance d -> IO a -> IO a
forall d a. ExtInterpInstance d -> IO a -> IO a
withLock ExtInterpInstance d
i (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ InterpProcess -> Message a -> IO a
forall a. Binary a => InterpProcess -> Message a -> IO a
callInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) Message a
m
sendMessageDelayedResponse :: ExtInterpInstance d -> Message a -> IO (DelayedResponse a)
sendMessageDelayedResponse :: forall d a.
ExtInterpInstance d -> Message a -> IO (DelayedResponse a)
sendMessageDelayedResponse ExtInterpInstance d
i Message a
m = do
ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
lock ExtInterpInstance d
i
InterpProcess -> Put -> IO ()
writeInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) (Message a -> Put
forall a. Message a -> Put
putMessage Message a
m)
DelayedResponse a -> IO (DelayedResponse a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DelayedResponse a
forall {k} (a :: k). DelayedResponse a
DelayedResponse
receiveDelayedResponse :: Binary a => ExtInterpInstance d -> DelayedResponse a -> IO a
receiveDelayedResponse :: forall a d.
Binary a =>
ExtInterpInstance d -> DelayedResponse a -> IO a
receiveDelayedResponse ExtInterpInstance d
i DelayedResponse a
DelayedResponse = do
ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i
r <- InterpProcess -> Get a -> IO a
forall a. InterpProcess -> Get a -> IO a
readInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) Get a
forall t. Binary t => Get t
get
unlock i
pure r
sendAnyValue :: Binary a => ExtInterpInstance d -> a -> IO ()
sendAnyValue :: forall a d. Binary a => ExtInterpInstance d -> a -> IO ()
sendAnyValue ExtInterpInstance d
i a
m = ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InterpProcess -> Put -> IO ()
writeInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) (a -> Put
forall t. Binary t => t -> Put
put a
m)
receiveAnyValue :: ExtInterpInstance d -> Get a -> IO a
receiveAnyValue :: forall d a. ExtInterpInstance d -> Get a -> IO a
receiveAnyValue ExtInterpInstance d
i Get a
get = ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InterpProcess -> Get a -> IO a
forall a. InterpProcess -> Get a -> IO a
readInterpProcess (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i) Get a
get
receiveTHMessage :: ExtInterpInstance d -> IO THMsg
receiveTHMessage :: forall d. ExtInterpInstance d -> IO THMsg
receiveTHMessage ExtInterpInstance d
i = ExtInterpInstance d -> IO ()
forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i IO () -> IO THMsg -> IO THMsg
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExtInterpInstance d -> Get THMsg -> IO THMsg
forall d a. ExtInterpInstance d -> Get a -> IO a
receiveAnyValue ExtInterpInstance d
i Get THMsg
getTHMessage
getLock :: ExtInterpInstance d -> MVar ()
getLock :: forall d. ExtInterpInstance d -> MVar ()
getLock = InterpProcess -> MVar ()
interpLock (InterpProcess -> MVar ())
-> (ExtInterpInstance d -> InterpProcess)
-> ExtInterpInstance d
-> MVar ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess
withLock :: ExtInterpInstance d -> IO a -> IO a
withLock :: forall d a. ExtInterpInstance d -> IO a -> IO a
withLock ExtInterpInstance d
i IO a
f = MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (ExtInterpInstance d -> MVar ()
forall d. ExtInterpInstance d -> MVar ()
getLock ExtInterpInstance d
i) (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
f)
lock :: ExtInterpInstance d -> IO ()
lock :: forall d. ExtInterpInstance d -> IO ()
lock ExtInterpInstance d
i = MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar (ExtInterpInstance d -> MVar ()
forall d. ExtInterpInstance d -> MVar ()
getLock ExtInterpInstance d
i)
unlock :: ExtInterpInstance d -> IO ()
unlock :: forall d. ExtInterpInstance d -> IO ()
unlock ExtInterpInstance d
i = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (ExtInterpInstance d -> MVar ()
forall d. ExtInterpInstance d -> MVar ()
getLock ExtInterpInstance d
i) ()
ensureLocked :: ExtInterpInstance d -> IO ()
ensureLocked :: forall d. ExtInterpInstance d -> IO ()
ensureLocked ExtInterpInstance d
i =
MVar () -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar (ExtInterpInstance d -> MVar ()
forall d. ExtInterpInstance d -> MVar ()
getLock ExtInterpInstance d
i) IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> String -> IO ()
forall a. HasCallStack => String -> a
panic String
"ensureLocked: external interpreter not locked"
Bool
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
callInterpProcess :: Binary a => InterpProcess -> Message a -> IO a
callInterpProcess :: forall a. Binary a => InterpProcess -> Message a -> IO a
callInterpProcess InterpProcess
i Message a
msg =
Pipe -> Message a -> IO a
forall a. Binary a => Pipe -> Message a -> IO a
remoteCall (InterpProcess -> Pipe
interpPipe InterpProcess
i) Message a
msg
IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \(SomeException
e :: SomeException) -> InterpProcess -> SomeException -> IO a
forall a. InterpProcess -> SomeException -> IO a
handleInterpProcessFailure InterpProcess
i SomeException
e
readInterpProcess :: InterpProcess -> Get a -> IO a
readInterpProcess :: forall a. InterpProcess -> Get a -> IO a
readInterpProcess InterpProcess
i Get a
get =
Pipe -> Get a -> IO a
forall a. Pipe -> Get a -> IO a
readPipe (InterpProcess -> Pipe
interpPipe InterpProcess
i) Get a
get
IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \(SomeException
e :: SomeException) -> InterpProcess -> SomeException -> IO a
forall a. InterpProcess -> SomeException -> IO a
handleInterpProcessFailure InterpProcess
i SomeException
e
writeInterpProcess :: InterpProcess -> Put -> IO ()
writeInterpProcess :: InterpProcess -> Put -> IO ()
writeInterpProcess InterpProcess
i Put
put =
Pipe -> Put -> IO ()
writePipe (InterpProcess -> Pipe
interpPipe InterpProcess
i) Put
put
IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \(SomeException
e :: SomeException) -> InterpProcess -> SomeException -> IO ()
forall a. InterpProcess -> SomeException -> IO a
handleInterpProcessFailure InterpProcess
i SomeException
e
handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a
handleInterpProcessFailure :: forall a. InterpProcess -> SomeException -> IO a
handleInterpProcessFailure InterpProcess
i SomeException
e = do
let hdl :: ProcessHandle
hdl = InterpProcess -> ProcessHandle
interpHandle InterpProcess
i
ex <- ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
hdl
case ex of
Just (ExitFailure Int
n) ->
GhcException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> GhcException
InstallationError (String
"External interpreter terminated (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"))
Maybe ExitCode
_ -> do
ProcessHandle -> IO ()
terminateProcess ProcessHandle
hdl
_ <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
hdl
throw e