Andrea Vezzosi pushed to branch wip/andrea/async-rpc at Glasgow Haskell Compiler / GHC Commits: 14f03672 by Andrea Vezzosi at 2026-10-15T10:02:38+02:00 close Handles when done with Pipe - - - - - 3 changed files: - compiler/GHC/Runtime/Interpreter.hs - libraries/ghci/GHCi/Message/Async.hs - libraries/ghci/GHCi/Server.hs Changes: ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -654,6 +654,8 @@ stopInterp interp = case interpInstance interp of 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 -- ----------------------------------------------------------------------------- ===================================== libraries/ghci/GHCi/Message/Async.hs ===================================== @@ -70,8 +70,13 @@ data Pipe = Pipe , pipeLeftovers :: !(IORef (Maybe ByteString)) , pipeLock :: !(MVar ()) -- ^ Lock to prevent concurrent writes to the stream , pipeAsyncMngr :: !AsyncManager + , pipeCloseRead :: !(IO ()) + -- ^ closes read end of the pipe + , pipeCloseWrite :: !(IO ()) + -- ^ closes write end of the pipe , pipeIsClosed :: !(TVar Bool) - -- ^ After the pipe is closed, requests can no longer be received nor sent + -- ^ After the pipe is closed, messages can no longer be received from the + -- other end, but the 'AsyncManager' queues might not be empty yet. } -- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write. @@ -82,12 +87,17 @@ mkPipeFromHandles pipeRead pipeWrite = do putAll b = do B.hPutBuilder pipeWrite b hFlush pipeWrite - mkPipeFromContinuations getSome putAll + mkPipeFromContinuations getSome putAll (hClose pipeRead) (hClose pipeWrite) -- | Make a 'Pipe' from a reader function and a writer function. --- The pipe should be closed with 'closePipe'. -mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) -> IO Pipe -mkPipeFromContinuations getSome putAll = mdo +-- The pipe should be closed with 'closePipe', which will call 'pipeCloseRead' and 'pipeCloseWrite'. +mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) + -> IO () + -- ^ pipeCloseRead + -> IO () + -- ^ pipeCloseWrite + -> IO Pipe +mkPipeFromContinuations getSome putAll pipeCloseRead pipeCloseWrite = mdo pipeLeftovers <- newIORef Nothing pipeLock <- newMVar () pipeIsClosed <- newTVarIO False @@ -96,18 +106,16 @@ mkPipeFromContinuations getSome putAll = mdo let p = Pipe { .. } pure p --- | Cleanly close our end of the Pipe, terminating the async manager's --- drain-read-end thread. Calling 'closePipe' on an already closed pipe is a no-op. +-- | Cleanly close our ends of the Pipe, terminating the async manager's +-- drain-read-end thread. Also calls 'pipeCloseRead' and 'pipeCloseWrite', in that order. -- --- If the pipe was created using 'mkPipeFromHandles', the handles must only by --- closed after calling 'closePipe'. +-- If the pipe was created using 'mkPipeFromHandles', the handles are also closed. -- -- The requests we've sent that are pending are all canceled with -- 'PipeClosedException' by ourselves. -- --- The remote process does not necessarily detect that this end of the pipe was --- closed, but it must handle cleanly and clean up after exceptions caused from --- it such as a handle being closed. +-- No special notification is sent to the remote process, a message to that +-- effect should be sent ahead of time if one is needed (see 'Shutdown'). closePipe :: Pipe -> IO () closePipe Pipe{..} = do @@ -119,6 +127,8 @@ closePipe Pipe{..} = do -- pending request with 'PipeClosedException'. throwTo (asyncDrainTid pipeAsyncMngr) PipeClosedException + pipeCloseWrite + -- | We've closed the pipe on our end and we terminate all pending requests with this. data PipeClosedException = PipeClosedException deriving Show instance Exception PipeClosedException @@ -369,7 +379,7 @@ newAsyncManager pipe = do -- 'Pipe' and a thread draining the read end of the interpreter's 'Pipe', since -- both processes construct a 'Pipe' and send and receive messages drainPipe :: Pipe -> (forall x. IO x -> IO x) -> IO () -drainPipe p unmask = catch (unmask loop) replyToPendings where +drainPipe p unmask = catch (unmask $ loop `finally` pipeCloseRead p) replyToPendings where loop = do readPipe p >>= \case -- Receive a reply to a pending notification ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -78,6 +78,9 @@ servWithCustom verbose hook pipe restore customHandler = newIORef False >>= loop RunModFinalizers ii st qrefs -> wrapRunTH ii $ runModFinalizerRefs pipe ii st qrefs _other -> run msg >>= reply + -- closePipe here will wait until every active pipeWrite pipe exits, but + -- they should never block for long, as the host process is either reading + -- or has called pipeCloseRead. isDone <- readIORef doneRef if isDone then closePipe pipe else loop doneRef @@ -184,7 +187,7 @@ defaultServerWithCustom customHandler = do #if defined(wasm32_HOST_ARCH) -- See Note [wasm ghci signal handlers] for details installSignalHandlers $ js_register_signal_handler cb_sig - pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send) + pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send) (pure ()) (pure ()) #else when verbose $ printf "GHC iserv starting (in: %s; out: %s)\n" (show inh) (show outh) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14f03672c3eeadcdea77560aeae3b233... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14f03672c3eeadcdea77560aeae3b233... 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