Rodrigo Mesquita pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC Commits: 65b04ffc by Rodrigo Mesquita at 2026-10-14T15:59:25+01:00 fixup: forkIOWithUnmask - - - - - bb069e99 by Rodrigo Mesquita at 2026-10-14T16:12:51+01:00 fixup: mask handleAsyncReq to not throw before replying - - - - - 16e8f30a by Rodrigo Mesquita at 2026-10-14T16:15:10+01:00 fixup Binary/fail - - - - - e1e7a528 by Rodrigo Mesquita at 2026-10-14T16:16:21+01:00 clean up pending replies on exc. in takeTMVar - - - - - 1 changed file: - libraries/ghci/GHCi/Message.hs Changes: ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -835,6 +835,8 @@ remoteAsyncReq pipe msg = do -- Block waiting for reply atomically (takeTMVar wv) + `onException` + atomically (modifyTVar pendingReplies (IntMap.delete uq)) -- | Receive a single asynchronous request and send a matching reply -- asynchronously (the handler may fork a computation that eventually replies @@ -845,7 +847,7 @@ remoteAsyncReq pipe msg = do -- reply more than once). Linear types enforce the handler replies in every -- branch, and if the handler otherwise throws, it is handled by 'withAsyncHandler'. handleAsyncReq :: Pipe -> Get a -> (WriteReply Put %1 -> a -> IO r) -> IO r -handleAsyncReq pipe getit k = do +handleAsyncReq pipe getit k = mask $ \restore -> do ack <- newEmptyMVar -- Block waiting for request @@ -870,7 +872,7 @@ handleAsyncReq pipe getit k = do reply (Left (toException exc)) throwIO exc Right (_, _, it) -> - k (WriteReply reply) it + restore (k (WriteReply reply) it) -- If there's an exception before the reply is sent, reply with an error instead. `catch` \(e :: SomeException) -> do @@ -934,7 +936,7 @@ instance Binary IddMsg where case b of 0 -> Request <$> get <*> get 1 -> Reply <$> get <*> get - _ -> error $ "impossible: Binary IddMsg - " ++ show b + _ -> fail $ "impossible: Binary IddMsg - " ++ show b newAsyncManager :: Pipe -> IO AsyncManager newAsyncManager pipe = do @@ -944,7 +946,7 @@ newAsyncManager pipe = do -- Fork thread to drain read end. -- (cleaned up on 'closePipe') - asyncDrainTid <- forkIO (drainPipe pipe) + asyncDrainTid <- forkIOWithUnmask (drainPipe pipe) let am = AsyncManager{..} pure am @@ -954,8 +956,8 @@ newAsyncManager pipe = do -- In pratice, we'll have both a thread draining the read end of the host's -- '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 -> IO () -drainPipe p = catch loop replyToPendings where +drainPipe :: Pipe -> (forall x. IO x -> IO x) -> IO () +drainPipe p unmask = catch (unmask loop) replyToPendings where loop = do readPipe p >>= \case -- Receive a reply to a pending notification View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0ed97f29fd6e635ad3d44b3be587be6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0ed97f29fd6e635ad3d44b3be587be6... 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