Rodrigo Mesquita pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC Commits: 691c9382 by Rodrigo Mesquita at 2026-10-12T13:32:45+01:00 Simplify handleRemoteCall interface, don't leak linear types - - - - - 1 changed file: - libraries/ghci/GHCi/Message.hs Changes: ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -1,7 +1,7 @@ {-# LANGUAGE RecursiveDo, GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, CPP, NamedFieldPuns, PatternSynonyms, LambdaCase, TypeAbstractions, TypeApplications, - LinearTypes, RankNTypes, UnboxedTuples, BlockArguments, TupleSections #-} + LinearTypes, RankNTypes, UnboxedTuples, BlockArguments, TupleSections, MagicHash #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -- | @@ -25,19 +25,18 @@ module GHCi.Message , Pipe, mkPipeFromHandles, mkPipeFromContinuations , remoteCall, remoteTHCall - , handleRemoteCall + , handleRemoteCall, handleRemoteTHCall , BreakModule , BreakUnitId , LoadedDLL - -- * Consume `reply` exactly once - , WriteReply -- abstract - , writeReply - -- * Low-level interface for async bidirectional RPC , withAsyncReq , withAsyncHandler + -- ** Consume `reply` exactly once + , WriteReply -- abstract + , writeReply ) where import Prelude -- See note [Why do we import Prelude here?] @@ -57,6 +56,7 @@ import qualified GHC.Exts.Heap as Heap import GHC.ForeignSrcLang import GHC.Fingerprint import GHC.Conc (pseq, par) +import GHC.IO (IO(..)) import Control.Concurrent import Control.DeepSeq import Control.Exception @@ -88,6 +88,8 @@ import System.IO.Error import Control.Monad import Control.Concurrent.STM import Data.Bifunctor +import GHC.Base (State#) +import GHC.Exts (RealWorld) -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server @@ -774,12 +776,13 @@ remoteCall pipe msg = bimap fromSerializableException id . runGet get -- | Handle a single 'Message' request on the interpreter and reply to the host handleRemoteCall :: Pipe -> (Msg -> IO Msg) {-^ Msg hook -} - -> (forall a. Binary a => WriteReply a %1 -> Message a -> IO r) - -> IO r + -> (forall a. Binary a => Message a -> IO a) + -> IO () handleRemoteCall pipe hook k = - withAsyncHandler pipe getMessage \(WriteReply reply) msg0 -> do - hook msg0 >>= \(Msg @a msg) -> - k (WriteReply (reply . fmap (put @a))) msg + withAsyncHandler pipe getMessage \writer msg0 -> IO \s0 -> + case hook msg0 |#> s0 of + (# s1, Msg msg #) -> case k msg |#> s1 of + (# s2, a #) -> writeReply writer (put a) |#> s2 -- | Send a 'THMessage' request to the host and wait for a reply from the host -- to the interpreter @@ -787,12 +790,13 @@ remoteTHCall :: Binary a => Pipe -> THMessage a -> IO (Either SomeException a) remoteTHCall pipe msg = bimap fromSerializableException id . runGet get <$> withAsyncReq pipe (putTHMessage msg) --- | Handle a 'THMessage' request on the host and reply to the interpreter +-- | Handle a 'THMessage' request on the host and reply to the interpreter. handleRemoteTHCall - :: Pipe -> (forall a. Binary a => WriteReply a %1 -> Message a -> IO r) -> IO r + :: Pipe -> (forall a. Binary a => THMessage a -> IO a) -> IO () handleRemoteTHCall pipe k = - withAsyncHandler pipe getMessage \(WriteReply reply) (Msg @a msg) -> do - k (WriteReply (reply . fmap (put @a))) msg + withAsyncHandler pipe getTHMessage \writer (THMsg msg) -> IO \s0 -> + case k msg |#> s0 of + (# s1, a #) -> writeReply writer (put a) |#> s1 -------------------------------------------------------------------------------- -- * Matching requests with async replies @@ -820,7 +824,8 @@ withAsyncReq pipe msg = do -- -- The handler receives as an argument the function to use to reply to the request. -- It must be used exactly once (all requests expect a reply, and you can't --- reply more than once). Linear types enforce this. +-- reply more than once). Linear types enforce the handler replies in every +-- branch, and if the handler otherwise throws, it is handled by 'withAsyncHandler'. -- -- TODO: list of @a -> Bool@s or other proxy for which the handler runs in a -- forked thread? better than linear forkIO that can be misleading or used @@ -980,9 +985,12 @@ withLock Pipe{..} = bracket (takeMVar pipeLock) (putMVar pipeLock) . const -- | Every request should get exactly one reply. data WriteReply a where - WriteReply :: (Either SomeException a -> IO ()) -- unrestricted, but not exposed (for linearity safety) - -> WriteReply a + WriteReply :: (Either SomeException a -> IO ()) %1 -> WriteReply a -- | Write a reply exactly once (consuming the ability to write more replies) writeReply :: WriteReply a %1 -> a -> IO () -writeReply (WriteReply r) = r . Right +writeReply (WriteReply r) = \x -> r (Right x) + +-- | Infix, linear, 'unIO' +(|#>) :: IO a %1 -> State# RealWorld -> (# State# RealWorld, a #) +(|#>) (IO fs) s = fs s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/691c93829b756fb05a3cb1b9cbc29752... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/691c93829b756fb05a3cb1b9cbc29752... 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