From 42d6102a937f822328988d8eec067adf9bb0d001 Mon Sep 17 00:00:00 2001
From: Luite Stegeman <stegeman@gmail.com>
Date: Thu, 17 Oct 2024 13:12:03 +0000
Subject: [PATCH] Interpreter: Add locking for communication with external
interpreter
This adds locking to communication with the external interpreter
to prevent concurrent tasks interfering with each other. This
fixes Template Haskell with the external interpreter in parallel (-j)
builds.
Fixes #25083
---
compiler/GHC/Runtime/Interpreter.hs | 2 +
compiler/GHC/Runtime/Interpreter/JS.hs | 2 +
compiler/GHC/Runtime/Interpreter/Process.hs | 77 +++++++++++++++------
compiler/GHC/Runtime/Interpreter/Types.hs | 2 +-
compiler/GHC/Runtime/Interpreter/Wasm.hs | 4 +-
testsuite/tests/th/T25083.hs | 21 ++++++
testsuite/tests/th/T25083.stdout | 2 +
testsuite/tests/th/T25083_A.hs | 10 +++
testsuite/tests/th/T25083_B.hs | 8 +++
testsuite/tests/th/all.T | 1 +
utils/jsffi/dyld.mjs | 2 -
11 files changed, 104 insertions(+), 27 deletions(-)
create mode 100644 testsuite/tests/th/T25083.hs
create mode 100644 testsuite/tests/th/T25083.stdout
create mode 100644 testsuite/tests/th/T25083_A.hs
create mode 100644 testsuite/tests/th/T25083_B.hs
diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index 13ab231e775..d0b4175ce87 100644
--- a/compiler/GHC/Runtime/Interpreter.hs
+++ b/compiler/GHC/Runtime/Interpreter.hs
@@ -578,10 +578,12 @@ spawnIServ conf = do
[]
(iservConfOpts conf)
lo_ref <- newIORef Nothing
+ lock <- newMVar ()
let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }
let process = InterpProcess
{ interpHandle = ph
, interpPipe = pipe
+ , interpLock = lock
}
pending_frees <- newMVar []
diff --git a/compiler/GHC/Runtime/Interpreter/JS.hs b/compiler/GHC/Runtime/Interpreter/JS.hs
index f68a61bb8bb..4d6f3460ba1 100644
--- a/compiler/GHC/Runtime/Interpreter/JS.hs
+++ b/compiler/GHC/Runtime/Interpreter/JS.hs
@@ -130,10 +130,12 @@ startTHRunnerProcess interp_js settings = do
std_in <- readIORef interp_in
lo_ref <- newIORef Nothing
+ lock <- newMVar ()
let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }
let proc = InterpProcess
{ interpHandle = hdl
, interpPipe = pipe
+ , interpLock = lock
}
pure (std_in, proc)
diff --git a/compiler/GHC/Runtime/Interpreter/Process.hs b/compiler/GHC/Runtime/Interpreter/Process.hs
index a93d00d7bc7..142fda006ac 100644
--- a/compiler/GHC/Runtime/Interpreter/Process.hs
+++ b/compiler/GHC/Runtime/Interpreter/Process.hs
@@ -1,21 +1,18 @@
+{-# LANGUAGE LambdaCase #-}
module GHC.Runtime.Interpreter.Process
(
- -- * Low-level API
- callInterpProcess
- , readInterpProcess
- , writeInterpProcess
-
-- * Message API
- , Message(..)
+ Message(..)
, DelayedResponse (..)
+ -- * Top-level message API (these acquire/release a lock)
, sendMessage
, sendMessageNoResponse
, sendMessageDelayedResponse
+ , receiveDelayedResponse
+ -- * Nested message API (these require the interpreter to already be locked)
, sendAnyValue
, receiveAnyValue
- , receiveDelayedResponse
, receiveTHMessage
-
)
where
@@ -31,45 +28,79 @@ 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
+-- -----------------------------------------------------------------------------
+-- Top-level Message API
+
-- | Send a message to the interpreter process that doesn't expect a response
+-- (locks the interpreter while sending)
sendMessageNoResponse :: ExtInterpInstance d -> Message () -> IO ()
-sendMessageNoResponse i m = writeInterpProcess (instProcess i) (putMessage m)
+sendMessageNoResponse i m =
+ withLock i $ writeInterpProcess (instProcess i) (putMessage m)
--- | Send a message to the interpreter that excepts a response
+-- | Send a message to the interpreter that expects a response
+-- (locks the interpreter while until the response is received)
sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a
-sendMessage i m = callInterpProcess (instProcess i) m
+sendMessage i m = withLock i $ callInterpProcess (instProcess i) m
-- | Send a message to the interpreter process whose response is expected later
--
-- This is useful to avoid forgetting to receive the value and to ensure that
-- the type of the response isn't lost. Use receiveDelayedResponse to read it.
+-- (locks the interpreter until the response is received using
+-- `receiveDelayedResponse`)
sendMessageDelayedResponse :: ExtInterpInstance d -> Message a -> IO (DelayedResponse a)
sendMessageDelayedResponse i m = do
+ lock i
writeInterpProcess (instProcess i) (putMessage m)
pure DelayedResponse
--- | Send any value
+-- | Expect a delayed result to be received now
+receiveDelayedResponse :: Binary a => ExtInterpInstance d -> DelayedResponse a -> IO a
+receiveDelayedResponse i DelayedResponse = do
+ ensureLocked i
+ r <- readInterpProcess (instProcess i) get
+ unlock i
+ pure r
+
+-- -----------------------------------------------------------------------------
+-- Nested Message API
+
+-- | Send any value (requires locked interpreter)
sendAnyValue :: Binary a => ExtInterpInstance d -> a -> IO ()
-sendAnyValue i m = writeInterpProcess (instProcess i) (put m)
+sendAnyValue i m = ensureLocked i >> writeInterpProcess (instProcess i) (put m)
--- | Expect a value to be received
+-- | Expect a value to be received (requires locked interpreter)
receiveAnyValue :: ExtInterpInstance d -> Get a -> IO a
-receiveAnyValue i get = readInterpProcess (instProcess i) get
+receiveAnyValue i get = ensureLocked i >> readInterpProcess (instProcess i) get
--- | Expect a delayed result to be received now
-receiveDelayedResponse :: Binary a => ExtInterpInstance d -> DelayedResponse a -> IO a
-receiveDelayedResponse i DelayedResponse = readInterpProcess (instProcess i) get
-
--- | Expect a value to be received
+-- | Wait for a Template Haskell message (requires locked interpreter)
receiveTHMessage :: ExtInterpInstance d -> IO THMsg
-receiveTHMessage i = receiveAnyValue i getTHMessage
-
+receiveTHMessage i = ensureLocked i >> receiveAnyValue i getTHMessage
-- -----------------------------------------------------------------------------
--- Low-level API
+
+getLock :: ExtInterpInstance d -> MVar ()
+getLock = interpLock . instProcess
+
+withLock :: ExtInterpInstance d -> IO a -> IO a
+withLock i f = withMVar (getLock i) (const f)
+
+lock :: ExtInterpInstance d -> IO ()
+lock i = takeMVar (getLock i)
+
+unlock :: ExtInterpInstance d -> IO ()
+unlock i = putMVar (getLock i) ()
+
+ensureLocked :: ExtInterpInstance d -> IO ()
+ensureLocked i =
+ isEmptyMVar (getLock i) >>= \case
+ False -> panic "ensureLocked: external interpreter not locked"
+ _ -> pure ()
+
-- | Send a 'Message' and receive the response from the interpreter process
callInterpProcess :: Binary a => InterpProcess -> Message a -> IO a
diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs
index 8c92d5ea16e..24928a716c1 100644
--- a/compiler/GHC/Runtime/Interpreter/Types.hs
+++ b/compiler/GHC/Runtime/Interpreter/Types.hs
@@ -90,6 +90,7 @@ type WasmInterp = ExtInterpState WasmInterpConfig ()
data InterpProcess = InterpProcess
{ interpPipe :: !Pipe -- ^ Pipe to communicate with the server
, interpHandle :: !ProcessHandle -- ^ Process handle of the server
+ , interpLock :: !(MVar ()) -- ^ Lock to prevent concurrent access to the stream
}
-- | Status of an external interpreter
@@ -111,7 +112,6 @@ data IServConfig = IServConfig
data ExtInterpInstance c = ExtInterpInstance
{ instProcess :: {-# UNPACK #-} !InterpProcess
-- ^ External interpreter process and its pipe (communication channel)
-
, instPendingFrees :: !(MVar [HValueRef])
-- ^ Values that need to be freed before the next command is sent.
-- Finalizers for ForeignRefs can append values to this list
diff --git a/compiler/GHC/Runtime/Interpreter/Wasm.hs b/compiler/GHC/Runtime/Interpreter/Wasm.hs
index 12624da4fdf..e3a6231cf70 100644
--- a/compiler/GHC/Runtime/Interpreter/Wasm.hs
+++ b/compiler/GHC/Runtime/Interpreter/Wasm.hs
@@ -61,13 +61,15 @@ spawnWasmInterp WasmInterpConfig {..} = do
hSetBuffering wh NoBuffering
hSetBuffering rh NoBuffering
lo_ref <- newIORef Nothing
+ lock <- newMVar ()
pending_frees <- newMVar []
pure
$ ExtInterpInstance
{ instProcess =
InterpProcess
{ interpHandle = ph,
- interpPipe = Pipe {pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref}
+ interpPipe = Pipe {pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref},
+ interpLock = lock
},
instPendingFrees = pending_frees,
instExtra = ()
diff --git a/testsuite/tests/th/T25083.hs b/testsuite/tests/th/T25083.hs
new file mode 100644
index 00000000000..acffb038772
--- /dev/null
+++ b/testsuite/tests/th/T25083.hs
@@ -0,0 +1,21 @@
+{-
+ T25083_A and T25083_B contain a long-running (100ms) Template Haskell splice.
+
+ Run this with -fexternal-interpreter -j to check that we properly synchronize
+ the communication with the external interpreter.
+
+ This test will fail with a timeout or serialization error if communication
+ is not correctly serialized.
+ -}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+
+import Language.Haskell.TH
+import Control.Concurrent
+
+import T25083_A
+import T25083_B
+
+main :: IO ()
+main = do
+ print ta
+ print tb
diff --git a/testsuite/tests/th/T25083.stdout b/testsuite/tests/th/T25083.stdout
new file mode 100644
index 00000000000..dcd912c89fd
--- /dev/null
+++ b/testsuite/tests/th/T25083.stdout
@@ -0,0 +1,2 @@
+0
+42
diff --git a/testsuite/tests/th/T25083_A.hs b/testsuite/tests/th/T25083_A.hs
new file mode 100644
index 00000000000..e0d8edbf612
--- /dev/null
+++ b/testsuite/tests/th/T25083_A.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+module T25083_A where
+
+import Control.Concurrent
+import Language.Haskell.TH
+
+ta :: Integer
+ta =
+ $(do runIO (threadDelay 100000)
+ litE . integerL . toInteger . length =<< reifyInstances ''Show [])
diff --git a/testsuite/tests/th/T25083_B.hs b/testsuite/tests/th/T25083_B.hs
new file mode 100644
index 00000000000..5a508b460fe
--- /dev/null
+++ b/testsuite/tests/th/T25083_B.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+module T25083_B where
+
+import Control.Concurrent
+import Language.Haskell.TH
+
+tb :: Integer
+tb = $(runIO (threadDelay 100000) >> [| 42 |])
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 9732adc1eac..b8dff687a2d 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -614,3 +614,4 @@ test('T24557e', normal, compile, [''])
test('T24702a', normal, compile, [''])
test('T24702b', normal, compile, [''])
test('T24837', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T25083', [extra_files(['T25083_A.hs', 'T25083_B.hs'])], multimod_compile_and_run, ['T25083', '-v0 -j'])
diff --git a/utils/jsffi/dyld.mjs b/utils/jsffi/dyld.mjs
index 298ce6abd32..30881cebfbe 100755
--- a/utils/jsffi/dyld.mjs
+++ b/utils/jsffi/dyld.mjs
@@ -26,8 +26,6 @@
// library. There's no code unloading logic. The retain_cafs flag is
// ignored and revertCAFs is a no-op.
//
-// ghc -j doesn't work yet (#25285).
-//
// *** What are implications to end users?
//
// Even if you intend to compile fully static wasm modules, you must
--
GitLab