GitLab

Rodrigo Mesquita pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC

Commits:

61f0d8e0

by Andrea Vezzosi at 2026-10-27T11:00:15+00:00

interp: do not terminate ext. interp. process on exception

`sendMessage` throwing an exception does not warrant terminating the external
interpreter process anymore, because communication can keep going no matter what.

`stopInterp` now resets the whole `Interp` state, so that a new
ExtInterpInstance can be later created and work correctly.

`withExtInterp` now calls `stopInterp` on a `PipeClosedException` and rethrows.

Fixes #18852

5 changed files:

compiler/GHC/Runtime/Interpreter.hs
compiler/GHC/Runtime/Interpreter/Process.hs
compiler/GHC/Tc/Gen/Splice.hs
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/Message/Async.hs

Changes:

compiler/GHC/Runtime/Interpreter.hs

@@ -105,7 +105,7 @@ import GHCi.Run
  import Control.Concurrent
  import Control.Monad
  import Control.Monad.IO.Class
 -import Control.Monad.Catch as MC (mask)
 +import Control.Monad.Catch as MC (mask, handle, MonadThrow (..))
  import Data.Binary
  import Data.ByteString (ByteString)
  import qualified Data.ByteString.Short as SBS
@@ -196,14 +196,16 @@ interpCmd interp msg = case interpInstance interp of
  #if defined(HAVE_INTERNAL_INTERPRETER)
    InternalInterp     -> run msg -- Just run it directly
  #endif
 -  ExternalInterp ext -> withExtInterp ext $ \inst ->
 +  ExternalInterp ext -> withExtInterp interp ext $ \inst ->
      sendMessage inst msg
 -withExtInterp :: ExceptionMonad m => ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
 -withExtInterp ext action = case ext of
 +withExtInterp :: ExceptionMonad m => Interp -> ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
 +withExtInterp interp ext action = stopInterpOnPipeClosed $ case ext of
    ExtJS    i -> withJSInterp i action
    ExtWasm  i -> withWasmInterp i action
    ExtIServ i -> withIServ    i action
 +  where
 +    stopInterpOnPipeClosed = MC.handle $ \ (e :: PipeClosedException) -> liftIO (stopInterp interp) >> MC.throwM e
  withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
  withExtInterpStatus ext action = case ext of
@@ -642,6 +644,9 @@ stopInterp interp = case interpInstance interp of
                 else sendMessage i Shutdown
              -- We asked the server to shutdown, so we will also shutdown any communication.
              closePipe (interpPipe (instProcess i))
 +            modifyMVar_ (loader_state (interpLoader interp)) (const $ pure Nothing)
 +            purgeInterpSymbolCache (interpSymbolCache interp)
 +            modifyMVar_ (interpStringCache interp) (const $ pure emptyFsEnv)
              pure InterpPending
  -- -----------------------------------------------------------------------------

compiler/GHC/Runtime/Interpreter/Process.hs

@@ -12,13 +12,10 @@ 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
  import Data.IORef
  import Control.Concurrent.STM
@@ -34,7 +31,6 @@ import Control.Concurrent.STM
  sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a
  sendMessage i msg =
    remoteCall (interpPipe proc) msg
 -    `catchException` \(e :: SomeException) -> handleInterpProcessFailure proc e
    where
      proc = instProcess i
@@ -77,18 +73,6 @@ sendTHComputation i msg reqHandler = mask $ \restore -> do
                        else loop
         in loop
 -handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a
 -handleInterpProcessFailure i e = do
 -  let hdl = interpHandle i
 -  ex <- getProcessExitCode hdl
 -  case ex of
 -    Just (ExitFailure n) ->
 -      throwIO (InstallationError ("External interpreter terminated (" ++ show n ++ ")"))
 -    _ -> do
 -      terminateProcess hdl
 -      _ <- waitForProcess hdl
 -      throw e
+-
  data CancelTHHandler = CancelTHHandler deriving Show
  instance Exception CancelTHHandler where
    fromException = asyncExceptionFromException

compiler/GHC/Tc/Gen/Splice.hs

@@ -1160,7 +1160,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
        runQinTcM $ sequence_ qs
  #endif
 -    ExternalInterp ext -> withExtInterp ext $ \inst -> do
 +    ExternalInterp ext -> withExtInterp interp ext $ \inst -> do
        tcg <- getGblEnv
        th_state <- readTcRef (tcg_th_remote_state tcg)
        case th_state of
@@ -1817,7 +1817,7 @@ runTH ty fhv = do
        return r
  #endif
 -    ExternalInterp ext -> withExtInterp ext $ \inst -> do
 +    ExternalInterp ext -> withExtInterp interp ext $ \inst -> do
        -- Run it on the server.  For an overview of how TH works with
        -- Remote GHCi, see Note [Remote Template Haskell] in
        -- libraries/ghci/GHCi/TH.hs.

libraries/ghci/GHCi/Message.hs

@@ -27,7 +27,7 @@ module GHCi.Message
    , Pipe(..), mkPipeFromHandles, mkPipeFromContinuations, closePipe
    , remoteCall, remoteTHCall
    , handleRemoteCall, handleRemoteTHCall, writeReply
 -  , RemoteProcessException(..), PipeReadClosedException(..)
 +  , RemoteProcessException(..), PipeClosedException(..)
    , InboxId(..)
    , newMailbox

libraries/ghci/GHCi/Message/Async.hs

@@ -7,7 +7,7 @@ module GHCi.Message.Async
+   (
      -- * Pipes
      Pipe(..), mkPipeFromHandles, mkPipeFromContinuations
 -  , closePipe, PipeReadClosedException(..)
 +  , closePipe, PipeClosedException(..)
      -- * Interface for async bidirectional RPC
    , remoteAsyncReq, handleAsyncReq
@@ -145,13 +145,13 @@ closePipe p@Pipe{..} = do
        unless writeAlreadyClosed
          (throwTo (asyncFillTid pipeAsyncMngr) PipeWriteClosedException)
 --- | We've closed the pipe read end on this process
 -data PipeReadClosedException = PipeReadClosedException deriving Show
 -instance Exception PipeReadClosedException
 +data PipeClosedException
 +  = PipeReadClosedException -- ^ We've closed the pipe read end on this process
++
 +  | PipeWriteClosedException -- ^ We've closed the pipe write end on this process
 +  deriving Show
 +instance Exception PipeClosedException
 --- | We've closed the pipe write end on this process
 -data PipeWriteClosedException = PipeWriteClosedException deriving Show
 -instance Exception PipeWriteClosedException
  --------------------------------------------------------------------------------
  -- ** Pipe thread-safe read/write