diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index a0436e56ea044abe3c8c0a96ac8825caf2c7cd0d..dd57812b52dc0d8453b74790d846afdb2cb9f1aa 100644
--- a/compiler/GHC/Runtime/Interpreter.hs
+++ b/compiler/GHC/Runtime/Interpreter.hs
@@ -108,7 +108,6 @@ import Control.Monad.Catch as MC (mask)
import Data.Binary
import Data.ByteString (ByteString)
import Data.Array ((!))
-import Data.IORef
import Foreign hiding (void)
import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
@@ -577,12 +576,11 @@ spawnIServ conf = do
(ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf)
[]
(iservConfOpts conf)
- lo_ref <- newIORef Nothing
+ interpPipe <- mkPipeFromHandles rh wh
lock <- newMVar ()
- let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }
let process = InterpProcess
{ interpHandle = ph
- , interpPipe = pipe
+ , interpPipe
, interpLock = lock
}
diff --git a/compiler/GHC/Runtime/Interpreter/JS.hs b/compiler/GHC/Runtime/Interpreter/JS.hs
index 64b0d7ff3533b45ceaed014072765c3928b5f9c2..52b58b568aceda14d137562b0ecebaa71dc428ef 100644
--- a/compiler/GHC/Runtime/Interpreter/JS.hs
+++ b/compiler/GHC/Runtime/Interpreter/JS.hs
@@ -129,12 +129,11 @@ startTHRunnerProcess interp_js settings = do
(nodeExtraArgs settings)
std_in <- readIORef interp_in
- lo_ref <- newIORef Nothing
+ interpPipe <- mkPipeFromHandles rh wh
lock <- newMVar ()
- let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }
let proc = InterpProcess
{ interpHandle = hdl
- , interpPipe = pipe
+ , interpPipe
, interpLock = lock
}
pure (std_in, proc)
diff --git a/compiler/GHC/Runtime/Interpreter/Wasm.hs b/compiler/GHC/Runtime/Interpreter/Wasm.hs
index d2c7bfb19d86cbecf2f80e8b73cfa09a4c005d57..a6dd9513bc7e8f0fa1da9b9cc7469508421fe376 100644
--- a/compiler/GHC/Runtime/Interpreter/Wasm.hs
+++ b/compiler/GHC/Runtime/Interpreter/Wasm.hs
@@ -10,7 +10,6 @@ import GHC.Runtime.Interpreter.Types
#if !defined(mingw32_HOST_OS)
import Control.Concurrent.MVar
-import Data.IORef
import GHC.Data.FastString
import qualified GHC.Data.ShortText as ST
import GHC.Platform
@@ -60,7 +59,7 @@ spawnWasmInterp WasmInterpConfig {..} = do
wh <- Posix.fdToHandle wfd2
hSetBuffering wh NoBuffering
hSetBuffering rh NoBuffering
- lo_ref <- newIORef Nothing
+ interpPipe <- mkPipeFromHandles rh wh
pending_frees <- newMVar []
lock <- newMVar ()
pure
@@ -68,7 +67,7 @@ spawnWasmInterp WasmInterpConfig {..} = do
{ instProcess =
InterpProcess
{ interpHandle = ph,
- interpPipe = Pipe {pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref},
+ interpPipe,
interpLock = lock
},
instPendingFrees = pending_frees,
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index b745bdb536ee83b8e45cb559f41aacf27d4a10c1..2de17797c34068509f3bca85b5b47984429b3e11 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,
GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards,
- CPP #-}
+ CPP, NamedFieldPuns #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
-- |
@@ -21,7 +21,7 @@ module GHCi.Message
, ResumeContext(..)
, QState(..)
, getMessage, putMessage, getTHMessage, putTHMessage
- , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe
+ , Pipe, mkPipeFromHandles, remoteCall, remoteTHCall, readPipe, writePipe
, BreakModule
, LoadedDLL
) where
@@ -48,6 +48,7 @@ import Data.Binary.Get
import Data.Binary.Put
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
+import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as LB
import Data.Dynamic
import Data.Typeable (TypeRep)
@@ -644,47 +645,52 @@ serializeBCOs rbcos = parMap doChunk (chunkList 100 rbcos)
-- -----------------------------------------------------------------------------
-- Reading/writing messages
+-- | An opaque pipe for bidirectional binary data transmission.
data Pipe = Pipe
- { pipeRead :: Handle
- , pipeWrite :: Handle
- , pipeLeftovers :: IORef (Maybe ByteString)
+ { getSome :: !(IO ByteString)
+ , putAll :: !(B.Builder -> IO ())
+ , pipeLeftovers :: !(IORef (Maybe ByteString))
}
+-- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write.
+mkPipeFromHandles :: Handle -> Handle -> IO Pipe
+mkPipeFromHandles pipeRead pipeWrite = do
+ let getSome = B.hGetSome pipeRead (32*1024)
+ putAll b = do
+ B.hPutBuilder pipeWrite b
+ hFlush pipeWrite
+ pipeLeftovers <- newIORef Nothing
+ pure $ Pipe { getSome, putAll, pipeLeftovers }
+
remoteCall :: Binary a => Pipe -> Message a -> IO a
remoteCall pipe msg = do
writePipe pipe (putMessage msg)
readPipe pipe get
+writePipe :: Pipe -> Put -> IO ()
+writePipe Pipe{..} put = putAll $ execPut put
+
remoteTHCall :: Binary a => Pipe -> THMessage a -> IO a
remoteTHCall pipe msg = do
writePipe pipe (putTHMessage msg)
readPipe pipe get
-writePipe :: Pipe -> Put -> IO ()
-writePipe Pipe{..} put
- | LB.null bs = return ()
- | otherwise = do
- LB.hPut pipeWrite bs
- hFlush pipeWrite
- where
- bs = runPut put
-
readPipe :: Pipe -> Get a -> IO a
readPipe Pipe{..} get = do
leftovers <- readIORef pipeLeftovers
- m <- getBin pipeRead get leftovers
+ m <- getBin getSome get leftovers
case m of
Nothing -> throw $
- mkIOError eofErrorType "GHCi.Message.remoteCall" (Just pipeRead) Nothing
+ mkIOError eofErrorType "GHCi.Message.readPipe" Nothing Nothing
Just (result, new_leftovers) -> do
writeIORef pipeLeftovers new_leftovers
return result
getBin
- :: Handle -> Get a -> Maybe ByteString
+ :: (IO ByteString) -> Get a -> Maybe ByteString
-> IO (Maybe (a, Maybe ByteString))
-getBin h get leftover = go leftover (runGetIncremental get)
+getBin getsome get leftover = go leftover (runGetIncremental get)
where
go Nothing (Done leftover _ msg) =
return (Just (msg, if B.null leftover then Nothing else Just leftover))
@@ -693,7 +699,7 @@ getBin h get leftover = go leftover (runGetIncremental get)
go Nothing (fun (Just leftover))
go Nothing (Partial fun) = do
-- putStrLn "before hGetSome"
- b <- B.hGetSome h (32*1024)
+ b <- getsome
-- putStrLn $ "hGetSome: " ++ show (B.length b)
if B.null b
then return Nothing
diff --git a/libraries/ghci/GHCi/Server.hs b/libraries/ghci/GHCi/Server.hs
index 69a5ea7b597aa910d02d46df999b89fc382f515f..c5c661da90acb25ed1202d7d8b25c763775a82cd 100644
--- a/libraries/ghci/GHCi/Server.hs
+++ b/libraries/ghci/GHCi/Server.hs
@@ -19,7 +19,6 @@ import Control.Exception
import Control.Monad
import Control.Concurrent (threadDelay)
import Data.Binary
-import Data.IORef
import Text.Printf
import System.Environment (getProgName, getArgs)
@@ -127,8 +126,7 @@ defaultServer = do
installSignalHandlers
#endif
- lo_ref <- newIORef Nothing
- let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
+ pipe <- mkPipeFromHandles inh outh
when wait $ do
when verbose $