Andrea Vezzosi pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC Commits: 863e9a6a by Andrea Vezzosi at 2026-10-27T22:02:52+01: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 @@ -113,6 +113,7 @@ import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS (CostCentre,CostCentreStack) import System.Directory import System.Process +import System.Timeout (timeout) import qualified GHC.InfoProv as InfoProv import GHC.Builtin.Modules( gHC_PRIM, gHC_PRIMOPWRAPPERS ) @@ -196,14 +197,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 @@ -631,18 +634,41 @@ stopInterp interp = case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) InternalInterp -> pure () #endif - ExternalInterp ext -> withExtInterpStatus ext $ \mstate -> do - MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do + ExternalInterp ext -> (maybe (pure ()) throwIO =<<) $ withExtInterpStatus ext $ \mstate -> do + MC.mask $ \restore -> modifyMVar mstate $ \state -> do case state of - InterpPending -> pure state -- already stopped + InterpPending -> pure (state, Nothing) -- already stopped InterpRunning i -> do ex <- getProcessExitCode (interpHandle (instProcess i)) - if isJust ex - then pure () - else sendMessage i Shutdown - -- We asked the server to shutdown, so we will also shutdown any communication. - closePipe (interpPipe (instProcess i)) - pure InterpPending + e <- if isJust ex + then gracefulShutdown i restore + else closePipe (interpPipe (instProcess i)) >> pure Nothing + modifyMVar_ (loader_state (interpLoader interp)) (const $ pure Nothing) + purgeInterpSymbolCache (interpSymbolCache interp) + modifyMVar_ (interpStringCache interp) (const $ pure emptyFsEnv) + pure (InterpPending,e) + where + gracefulShutdown i restore = do + x <- try (timeLimited restore $ sendMessage i Shutdown `finally` closePipe (interpPipe (instProcess i))) + let ph = interpHandle (instProcess i) + e <- case x of + -- happy path: ext. interp. should be shutting down of its own accord. + Right (Just ()) -> pure Nothing + -- timeout: ext. interp. couldn't handle Shutdown in time. + Right Nothing -> do + terminateProcess ph + pure Nothing + -- something went wrong, probably Pipe already closed. + Left e -> do + terminateProcess ph + returnUnexpectedException e + void $ timeLimited restore $ void $ waitForProcess ph + pure e + timeLimited restore m = timeout 1_000_000 (restore m) + returnUnexpectedException e + | Just (_ :: PipeClosedException) <- fromException e = return Nothing + | Just (_ :: IOException) <- fromException e = return Nothing + | otherwise = pure (Just e) -- ----------------------------------------------------------------------------- {- Note [External GHCi pointers] ===================================== 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/863e9a6a9a84c9b7626d441eeadca154... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/863e9a6a9a84c9b7626d441eeadca154... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help