diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index 366edd322dd9c11ec0b2f3868f6458036946d661..a0436e56ea044abe3c8c0a96ac8825caf2c7cd0d 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 276d9419be2288766f9682446be38e99baafe651..64b0d7ff3533b45ceaed014072765c3928b5f9c2 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 a93d00d7bc7216f391ce6fcd6f237753608bce8f..142fda006ac5c03b131817d95f1e53d6c80f42ff 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 8c92d5ea16e09d1e0eb3f2b0ff106e8725e8fd57..ca51d612c8e8405b587d25648d92398e9a03b45c 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
diff --git a/compiler/GHC/Runtime/Interpreter/Wasm.hs b/compiler/GHC/Runtime/Interpreter/Wasm.hs
index 12624da4fdf3f34300bd2f98e8896dc1cc72d29c..d2c7bfb19d86cbecf2f80e8b73cfa09a4c005d57 100644
--- a/compiler/GHC/Runtime/Interpreter/Wasm.hs
+++ b/compiler/GHC/Runtime/Interpreter/Wasm.hs
@@ -62,12 +62,14 @@ spawnWasmInterp WasmInterpConfig {..} = do
   hSetBuffering rh NoBuffering
   lo_ref <- newIORef Nothing
   pending_frees <- newMVar []
+  lock <- 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 0000000000000000000000000000000000000000..acffb03877241ae19e528fc31cd311e89dde5602
--- /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 0000000000000000000000000000000000000000..dcd912c89fdceb16dfc084b9d41b75244e452a85
--- /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 0000000000000000000000000000000000000000..e0d8edbf612e6a41f035b43dd36e68c818ec3da6
--- /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 0000000000000000000000000000000000000000..5a508b460fe881d410cea1c1681cc2dcf10bb996
--- /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 578eac4490bba2ff5570668c9beeb7112e5c223a..78cec13d86bbc7c6ef09cd96f7bd1a62df4d17b8 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -630,3 +630,4 @@ test('T25252',
    req_th,
    req_c],
   compile_and_run, ['-fPIC T25252_c.c'])
+test('T25083', [extra_files(['T25083_A.hs', 'T25083_B.hs'])], multimod_compile_and_run, ['T25083', '-v0 -j'])