Andrea Vezzosi pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC Commits: 05f68d0e by Andrea Vezzosi at 2026-10-26T18:21:34+01:00 interp: more uninterruptibleMask_ removed - - - - - 7e21b3f8 by Andrea Vezzosi at 2026-10-26T23:42:27+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. - - - - - 1c9fe4ea by Andrea Vezzosi at 2026-10-27T08:54:09+01:00 fixup! interp: spawn fillPipe thread, writePipe now safely interruptible - - - - - 8dbf2fd4 by Andrea Vezzosi at 2026-10-27T08:58:54+01:00 interp: withExtInterp calls stopInterp on PipeClosedException - - - - - 5be020df by Andrea Vezzosi at 2026-10-27T09:05:16+01:00 fixup! interp: cancel requests if async exceptions while waiting for reply. - - - - - 6 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 - libraries/ghci/GHCi/Server.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 @@ -469,11 +471,9 @@ lookupSymbol interp str = withSymbolCache interp str $ #endif ExternalInterp ext -> case ext of ExtIServ i -> withIServ i $ \inst -> do - uninterruptibleMask_ $ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) ExtWasm i -> withWasmInterp i $ \inst -> do - uninterruptibleMask_ $ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (RemotePtr ())) @@ -484,7 +484,6 @@ lookupSymbolInDLL interp dll str = withSymbolCache interp str $ #endif ExternalInterp ext -> case ext of ExtIServ i -> withIServ i $ \inst -> do - uninterruptibleMask_ $ sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str))) ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) -- wasm dyld doesn't track which symbol comes from which .so @@ -645,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 @@ -75,7 +75,6 @@ import GHC.Stack.CCS import qualified GHC.Boot.TH.Syntax as TH import qualified GHC.Boot.TH.Monad as TH import GHCi.Message.Async -import Control.Monad.STM -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server ===================================== 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 @@ -539,7 +539,7 @@ fetchedRequest am uq = do {- Note [Exceptions during serialization] ------------------------------------------------------------------------------ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For efficiency reasons, any `IddMsg` to be sent is forced only when already writing onto the Pipe, so we cannot discern whether any raised exception ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -39,7 +39,6 @@ import System.Exit import System.IO import Control.Concurrent -import Control.Monad.STM import GHCi.Message.Async (runWriteReply, (%>>=)) import GHCi.Server.Threads View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a3a217670526335a827a72241538f45... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a3a217670526335a827a72241538f45... 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