Rodrigo Mesquita pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC Commits: 91debe61 by Rodrigo Mesquita at 2026-10-12T15:49:10+01:00 RunTH in remote interp using async IPC - - - - - 2 changed files: - compiler/GHC/Runtime/Interpreter/Process.hs - compiler/GHC/Tc/Gen/Splice.hs Changes: ===================================== compiler/GHC/Runtime/Interpreter/Process.hs ===================================== @@ -3,6 +3,7 @@ module GHC.Runtime.Interpreter.Process -- * Message API Message(..) , sendMessage + , sendTHComputation , RemoteCallFailed(..) ) where @@ -19,12 +20,18 @@ import GHC.Utils.Exception as Ex import Data.Binary import System.Exit import System.Process +import Control.Concurrent +import Data.IORef -- ----------------------------------------------------------------------------- -- Top-level Message API -- | Send a message to the interpreter and expect a response, blocking until it arrives. -- +-- This issues an asynchronous RPC on the external interpreter which does not +-- block the external interpreter thread. We block here on the host because we +-- wait for the asynchronous response to arrive. +-- -- Throws 'RemoteCallFailed' if the remote call threw an exception in the -- external interpreter sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a @@ -38,6 +45,43 @@ sendMessage i msg = unwrapRight =<< unwrapRight (Left er) = do throwIO (RemoteCallFailed er) +-- | Send a message with a TH computation to the ext. interpreter (like +-- 'RunTH', or 'RunModFinalizers') and handle 'THMessage' requests from the +-- ext. interpreter to us in the meantime. +-- +-- This function blocks until the TH computation returns a value, but spawns in +-- the background a thread to handle the 'THMessage's until the TH computation +-- is fully done. +sendTHComputation + :: Binary a + => ExtInterpInstance d + -> Message a + -> (forall b. Binary b => THMessage b -> IO (Bool, b)) + -- ^ Handle one message. Return True to end the loop. + -> IO a +sendTHComputation i msg reqHandler = mask $ \restore -> do + -- inline "withAsync/wait" + var <- newEmptyMVar + ht <- forkFinally (restore handlerLoop) (putMVar var) + restore (sendMessage i msg <* takeMVar var) + `finally` cancel ht var + where + proc = instProcess i + handleOne doneRef = do + handleRemoteTHCall (interpPipe proc) $ \req -> do + (stop, res) <- reqHandler req + writeIORef doneRef stop + return res + handlerLoop = do + doneRef <- newIORef False + let loop = do + handleOne doneRef + isDone <- readIORef doneRef + if isDone then return () + else loop + in loop + cancel ht var = uninterruptibleMask_ (throwTo ht CancelTHHandler <* takeMVar var) + handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a handleInterpProcessFailure i e = do let hdl = interpHandle i @@ -58,3 +102,8 @@ instance Exception RemoteCallFailed where displayException (RemoteCallFailed e) = "A remote call in the external interpreter threw an exception:\n" ++ displayException e + +data CancelTHHandler = CancelTHHandler deriving Show +instance Exception CancelTHHandler where + fromException = asyncExceptionFromException + toException = asyncExceptionToException ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -170,6 +170,7 @@ import Data.IORef import GHC.Parser.HaddockLex (lexHsDoc) import GHC.Parser (parseIdentifier) import GHC.Rename.Doc (rnHsDoc) +import Data.Function {- Note [Template Haskell state diagram] @@ -1165,11 +1166,12 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do case th_state of Nothing -> return () -- TH was not started, nothing to do Just fhv -> do - r <- liftIO $ withForeignRef fhv $ \st -> - withForeignRefs finRefs $ \qrefs -> - sendMessageDelayedResponse inst (RunModFinalizers st qrefs) - () <- runRemoteTH inst [] - qr <- liftIO $ receiveDelayedResponse inst r + qr <- withRunInIO $ \runInIO -> do + recovers <- newIORef [] + withForeignRef fhv $ \st -> + withForeignRefs finRefs $ \qrefs -> + sendTHComputation inst (RunModFinalizers st qrefs) $ \msg -> + runInIO (runRemoteTH recovers msg) checkQResult qr runQResult @@ -1824,48 +1826,47 @@ runTH ty fhv = do rstate <- getTHState inst loc <- location -- run a remote TH request - r <- liftIO $ + qr <- withRunInIO $ \runInIO -> do + recovers <- newIORef [] withForeignRef rstate $ \state_hv -> - withForeignRef fhv $ \q_hv -> - sendMessageDelayedResponse inst (RunTH state_hv q_hv ty (Just loc)) - -- respond to requests from the interpreter - runRemoteTH inst [] - -- get the final result - qr <- liftIO $ receiveDelayedResponse inst r + withForeignRef fhv $ \q_hv -> + sendTHComputation inst (RunTH state_hv q_hv ty (Just loc)) $ \msg -> + runInIO (runRemoteTH recovers msg) bs <- checkQResult qr return $! runGet get (LB.fromStrict bs) --- | communicate with a remotely-running TH computation until it finishes. +-- | Communicate with a remotely-running TH computation until it finishes. -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH - :: ExtInterpInstance d - -> [Messages TcRnMessage] -- saved from nested calls to qRecover - -> TcM () -runRemoteTH inst recovers = do - THMsg msg <- liftIO $ receiveTHMessage inst + :: Binary a + => IORef [Messages TcRnMessage] -- ^ saved from nested calls to qRecover + -> THMessage a + -> TcM (Bool, a) +runRemoteTH recovers msg = do case msg of - RunTHDone -> return () + RunTHDone -> return (True, ()) StartRecover -> do -- Note [TH recover with -fexternal-interpreter] v <- getErrsVar msgs <- readTcRef v writeTcRef v emptyMessages - runRemoteTH inst (msgs : recovers) + modifyIORef recovers (msgs:) & liftIO + return (False, ()) EndRecover caught_error -> do - let (prev_msgs, rest) = case recovers of - [] -> panic "EndRecover" - a : b -> (a,b) + (prev_msgs, rest) <- liftIO $ + readIORef recovers >>= \case + [] -> panic "EndRecover" + a : b -> pure (a,b) v <- getErrsVar warn_msgs <- getWarningMessages <$> readTcRef v -- keep the warnings only if there were no errors writeTcRef v $ if caught_error then prev_msgs else mkMessages warn_msgs `unionMessages` prev_msgs - runRemoteTH inst rest + writeIORef recovers rest & liftIO + return (False, ()) _other -> do - r <- handleTHMessage msg - liftIO $ sendAnyValue inst r - runRemoteTH inst recovers + (False,) <$> handleTHMessage msg -- | Check a QResult checkQResult :: QResult a -> TcM a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91debe611ff26226cdfaf6aa65021d02... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91debe611ff26226cdfaf6aa65021d02... 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