Andrea Vezzosi pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC Commits: b24e78a8 by Andrea Vezzosi at 2026-11-02T14:20:44+01:00 fixup! interp: single-threaded sendTHComputation - - - - - 1 changed file: - libraries/ghci/GHCi/Message/Async.hs Changes: ===================================== libraries/ghci/GHCi/Message/Async.hs ===================================== @@ -304,47 +304,46 @@ handleAsyncReq pipe getit mii k = mask $ \restore -> do ack <- newEmptyMVar -- Block waiting for request - mbreq <- atomically $ do + (uq,bs) <- atomically $ do readTVar (pipeWriteClosed pipe) >>= \case -- We will not be able to write the reply, so no point in continuiting. True -> throwSTM PipeWriteClosedException False -> pure () - isClosed <- readTVar (pipeReadClosed pipe) taken <- case mii of Nothing -> tryReadTQueue $ requestsQueue am Just ii -> tryReadTQueue =<< getMailbox am ii case taken of - Just req@(uq,_) -> pure (Just req) - Nothing | isClosed -> pure Nothing -- empty and closed - | otherwise -> retry -- wait for msg - - case mbreq of - Nothing -> throwIO PipeReadClosedException -- can't expect reqs - Just (uq, bs) -> do - let reply p = do - b <- atomically $ doneHandling am uq - when b $ writePipe pipe (Reply uq (bimap toSerializableException runPut p)) - putMVar ack () - -- Run the continuation which must reply exactly once with 'writeReply' - case runGetOrFail getit bs of - Left (_, _, err) -> do - let exc = DecodeAsyncReqException err - reply (Left (toException exc)) - throwIO exc - Right (_, _, it) -> - restore (k (WriteReply reply) (setActive am uq) it) - - -- If there's an exception before the reply is sent, reply with an error instead. - `catch` \(e :: SomeException) -> do - - tryTakeMVar ack >>= \case - Just () -> - -- Already replied - throwIO e - Nothing -> do - -- Reply with an error - reply (Left e) - throwIO e + Just req -> pure req + Nothing -> readTVar (pipeReadClosed pipe) >>= \case + True -> throwSTM PipeReadClosedException -- can't expect reqs + False -> retry + + let + reply p = do + b <- atomically $ doneHandling am uq + when b $ writePipe pipe (Reply uq (bimap toSerializableException runPut p)) + putMVar ack () + + -- Run the continuation which must reply exactly once with 'writeReply' + case runGetOrFail getit bs of + Left (_, _, err) -> do + let exc = DecodeAsyncReqException err + reply (Left (toException exc)) + throwIO exc + Right (_, _, it) -> + restore (k (WriteReply reply) (setActive am uq) it) + + -- If there's an exception before the reply is sent, reply with an error instead. + `catch` \(e :: SomeException) -> do + + tryTakeMVar ack >>= \case + Just () -> + -- Already replied + throwIO e + Nothing -> do + -- Reply with an error + reply (Left e) + throwIO e -- | 'handleSyncReq' failed to decode an incoming request payload using the given @'Get' a@ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b24e78a8f67e5ca3a03b29880fd0d711... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b24e78a8f67e5ca3a03b29880fd0d711... 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