From 5c17afcac5e1609f442496712d533981abcbb2ae Mon Sep 17 00:00:00 2001
From: Cheng Shao <terrorjack@type.dance>
Date: Mon, 10 Mar 2025 19:58:23 +0000
Subject: [PATCH] ghci: make the Pipe type opaque
This commit makes the Pipe type in ghci opaque, and introduce the
mkPipeFromHandles constructor for creating a Pipe from a pair of
Handles. Pipe is now just a pair of receiver/sender continuations
under the hood. This allows a Pipe to be potentially backed by other
IPC mechanisms (e.g. WebSockets) which is essential for wasm ghci
browser mode.
(cherry picked from commit 7d18c19b4c6a55d1fad3ca65c5a0754cf865bc26)
(cherry picked from commit 4148bc13cc02986428ad716635ed8600471b4d50)
---
compiler/GHC/Runtime/Interpreter.hs | 6 ++--
compiler/GHC/Runtime/Interpreter/JS.hs | 5 ++-
compiler/GHC/Runtime/Interpreter/Wasm.hs | 5 ++-
libraries/ghci/GHCi/Message.hs | 44 ++++++++++++++----------
libraries/ghci/GHCi/Server.hs | 4 +--
5 files changed, 32 insertions(+), 32 deletions(-)
diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index d0b4175ce87..b34c0f5e6e2 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 4d6f3460ba1..843d98751e2 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 e3a6231cf70..c89423e5cf2 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
lock <- newMVar ()
pending_frees <- 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 63b9894afe7..14512eb62d4 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
@@ -45,6 +45,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)
@@ -634,47 +635,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))
@@ -683,7 +689,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 69a5ea7b597..c5c661da90a 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 $
--
GitLab