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
2 changed files:
Changes:
| ... | ... | @@ -3,6 +3,7 @@ module GHC.Runtime.Interpreter.Process |
| 3 | 3 | -- * Message API
|
| 4 | 4 | Message(..)
|
| 5 | 5 | , sendMessage
|
| 6 | + , sendTHComputation
|
|
| 6 | 7 | , RemoteCallFailed(..)
|
| 7 | 8 | )
|
| 8 | 9 | where
|
| ... | ... | @@ -19,12 +20,18 @@ import GHC.Utils.Exception as Ex |
| 19 | 20 | import Data.Binary
|
| 20 | 21 | import System.Exit
|
| 21 | 22 | import System.Process
|
| 23 | +import Control.Concurrent
|
|
| 24 | +import Data.IORef
|
|
| 22 | 25 | |
| 23 | 26 | -- -----------------------------------------------------------------------------
|
| 24 | 27 | -- Top-level Message API
|
| 25 | 28 | |
| 26 | 29 | -- | Send a message to the interpreter and expect a response, blocking until it arrives.
|
| 27 | 30 | --
|
| 31 | +-- This issues an asynchronous RPC on the external interpreter which does not
|
|
| 32 | +-- block the external interpreter thread. We block here on the host because we
|
|
| 33 | +-- wait for the asynchronous response to arrive.
|
|
| 34 | +--
|
|
| 28 | 35 | -- Throws 'RemoteCallFailed' if the remote call threw an exception in the
|
| 29 | 36 | -- external interpreter
|
| 30 | 37 | sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a
|
| ... | ... | @@ -38,6 +45,43 @@ sendMessage i msg = unwrapRight =<< |
| 38 | 45 | unwrapRight (Left er) = do
|
| 39 | 46 | throwIO (RemoteCallFailed er)
|
| 40 | 47 | |
| 48 | +-- | Send a message with a TH computation to the ext. interpreter (like
|
|
| 49 | +-- 'RunTH', or 'RunModFinalizers') and handle 'THMessage' requests from the
|
|
| 50 | +-- ext. interpreter to us in the meantime.
|
|
| 51 | +--
|
|
| 52 | +-- This function blocks until the TH computation returns a value, but spawns in
|
|
| 53 | +-- the background a thread to handle the 'THMessage's until the TH computation
|
|
| 54 | +-- is fully done.
|
|
| 55 | +sendTHComputation
|
|
| 56 | + :: Binary a
|
|
| 57 | + => ExtInterpInstance d
|
|
| 58 | + -> Message a
|
|
| 59 | + -> (forall b. Binary b => THMessage b -> IO (Bool, b))
|
|
| 60 | + -- ^ Handle one message. Return True to end the loop.
|
|
| 61 | + -> IO a
|
|
| 62 | +sendTHComputation i msg reqHandler = mask $ \restore -> do
|
|
| 63 | + -- inline "withAsync/wait"
|
|
| 64 | + var <- newEmptyMVar
|
|
| 65 | + ht <- forkFinally (restore handlerLoop) (putMVar var)
|
|
| 66 | + restore (sendMessage i msg <* takeMVar var)
|
|
| 67 | + `finally` cancel ht var
|
|
| 68 | + where
|
|
| 69 | + proc = instProcess i
|
|
| 70 | + handleOne doneRef = do
|
|
| 71 | + handleRemoteTHCall (interpPipe proc) $ \req -> do
|
|
| 72 | + (stop, res) <- reqHandler req
|
|
| 73 | + writeIORef doneRef stop
|
|
| 74 | + return res
|
|
| 75 | + handlerLoop = do
|
|
| 76 | + doneRef <- newIORef False
|
|
| 77 | + let loop = do
|
|
| 78 | + handleOne doneRef
|
|
| 79 | + isDone <- readIORef doneRef
|
|
| 80 | + if isDone then return ()
|
|
| 81 | + else loop
|
|
| 82 | + in loop
|
|
| 83 | + cancel ht var = uninterruptibleMask_ (throwTo ht CancelTHHandler <* takeMVar var)
|
|
| 84 | + |
|
| 41 | 85 | handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a
|
| 42 | 86 | handleInterpProcessFailure i e = do
|
| 43 | 87 | let hdl = interpHandle i
|
| ... | ... | @@ -58,3 +102,8 @@ instance Exception RemoteCallFailed where |
| 58 | 102 | displayException (RemoteCallFailed e)
|
| 59 | 103 | = "A remote call in the external interpreter threw an exception:\n"
|
| 60 | 104 | ++ displayException e
|
| 105 | + |
|
| 106 | +data CancelTHHandler = CancelTHHandler deriving Show
|
|
| 107 | +instance Exception CancelTHHandler where
|
|
| 108 | + fromException = asyncExceptionFromException
|
|
| 109 | + toException = asyncExceptionToException |
| ... | ... | @@ -170,6 +170,7 @@ import Data.IORef |
| 170 | 170 | import GHC.Parser.HaddockLex (lexHsDoc)
|
| 171 | 171 | import GHC.Parser (parseIdentifier)
|
| 172 | 172 | import GHC.Rename.Doc (rnHsDoc)
|
| 173 | +import Data.Function
|
|
| 173 | 174 | |
| 174 | 175 | {-
|
| 175 | 176 | Note [Template Haskell state diagram]
|
| ... | ... | @@ -1165,11 +1166,12 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do |
| 1165 | 1166 | case th_state of
|
| 1166 | 1167 | Nothing -> return () -- TH was not started, nothing to do
|
| 1167 | 1168 | Just fhv -> do
|
| 1168 | - r <- liftIO $ withForeignRef fhv $ \st ->
|
|
| 1169 | - withForeignRefs finRefs $ \qrefs ->
|
|
| 1170 | - sendMessageDelayedResponse inst (RunModFinalizers st qrefs)
|
|
| 1171 | - () <- runRemoteTH inst []
|
|
| 1172 | - qr <- liftIO $ receiveDelayedResponse inst r
|
|
| 1169 | + qr <- withRunInIO $ \runInIO -> do
|
|
| 1170 | + recovers <- newIORef []
|
|
| 1171 | + withForeignRef fhv $ \st ->
|
|
| 1172 | + withForeignRefs finRefs $ \qrefs ->
|
|
| 1173 | + sendTHComputation inst (RunModFinalizers st qrefs) $ \msg ->
|
|
| 1174 | + runInIO (runRemoteTH recovers msg)
|
|
| 1173 | 1175 | checkQResult qr
|
| 1174 | 1176 | |
| 1175 | 1177 | runQResult
|
| ... | ... | @@ -1824,48 +1826,47 @@ runTH ty fhv = do |
| 1824 | 1826 | rstate <- getTHState inst
|
| 1825 | 1827 | loc <- location
|
| 1826 | 1828 | -- run a remote TH request
|
| 1827 | - r <- liftIO $
|
|
| 1829 | + qr <- withRunInIO $ \runInIO -> do
|
|
| 1830 | + recovers <- newIORef []
|
|
| 1828 | 1831 | withForeignRef rstate $ \state_hv ->
|
| 1829 | - withForeignRef fhv $ \q_hv ->
|
|
| 1830 | - sendMessageDelayedResponse inst (RunTH state_hv q_hv ty (Just loc))
|
|
| 1831 | - -- respond to requests from the interpreter
|
|
| 1832 | - runRemoteTH inst []
|
|
| 1833 | - -- get the final result
|
|
| 1834 | - qr <- liftIO $ receiveDelayedResponse inst r
|
|
| 1832 | + withForeignRef fhv $ \q_hv ->
|
|
| 1833 | + sendTHComputation inst (RunTH state_hv q_hv ty (Just loc)) $ \msg ->
|
|
| 1834 | + runInIO (runRemoteTH recovers msg)
|
|
| 1835 | 1835 | bs <- checkQResult qr
|
| 1836 | 1836 | return $! runGet get (LB.fromStrict bs)
|
| 1837 | 1837 | |
| 1838 | 1838 | |
| 1839 | --- | communicate with a remotely-running TH computation until it finishes.
|
|
| 1839 | +-- | Communicate with a remotely-running TH computation until it finishes.
|
|
| 1840 | 1840 | -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
|
| 1841 | 1841 | runRemoteTH
|
| 1842 | - :: ExtInterpInstance d
|
|
| 1843 | - -> [Messages TcRnMessage] -- saved from nested calls to qRecover
|
|
| 1844 | - -> TcM ()
|
|
| 1845 | -runRemoteTH inst recovers = do
|
|
| 1846 | - THMsg msg <- liftIO $ receiveTHMessage inst
|
|
| 1842 | + :: Binary a
|
|
| 1843 | + => IORef [Messages TcRnMessage] -- ^ saved from nested calls to qRecover
|
|
| 1844 | + -> THMessage a
|
|
| 1845 | + -> TcM (Bool, a)
|
|
| 1846 | +runRemoteTH recovers msg = do
|
|
| 1847 | 1847 | case msg of
|
| 1848 | - RunTHDone -> return ()
|
|
| 1848 | + RunTHDone -> return (True, ())
|
|
| 1849 | 1849 | StartRecover -> do -- Note [TH recover with -fexternal-interpreter]
|
| 1850 | 1850 | v <- getErrsVar
|
| 1851 | 1851 | msgs <- readTcRef v
|
| 1852 | 1852 | writeTcRef v emptyMessages
|
| 1853 | - runRemoteTH inst (msgs : recovers)
|
|
| 1853 | + modifyIORef recovers (msgs:) & liftIO
|
|
| 1854 | + return (False, ())
|
|
| 1854 | 1855 | EndRecover caught_error -> do
|
| 1855 | - let (prev_msgs, rest) = case recovers of
|
|
| 1856 | - [] -> panic "EndRecover"
|
|
| 1857 | - a : b -> (a,b)
|
|
| 1856 | + (prev_msgs, rest) <- liftIO $
|
|
| 1857 | + readIORef recovers >>= \case
|
|
| 1858 | + [] -> panic "EndRecover"
|
|
| 1859 | + a : b -> pure (a,b)
|
|
| 1858 | 1860 | v <- getErrsVar
|
| 1859 | 1861 | warn_msgs <- getWarningMessages <$> readTcRef v
|
| 1860 | 1862 | -- keep the warnings only if there were no errors
|
| 1861 | 1863 | writeTcRef v $ if caught_error
|
| 1862 | 1864 | then prev_msgs
|
| 1863 | 1865 | else mkMessages warn_msgs `unionMessages` prev_msgs
|
| 1864 | - runRemoteTH inst rest
|
|
| 1866 | + writeIORef recovers rest & liftIO
|
|
| 1867 | + return (False, ())
|
|
| 1865 | 1868 | _other -> do
|
| 1866 | - r <- handleTHMessage msg
|
|
| 1867 | - liftIO $ sendAnyValue inst r
|
|
| 1868 | - runRemoteTH inst recovers
|
|
| 1869 | + (False,) <$> handleTHMessage msg
|
|
| 1869 | 1870 | |
| 1870 | 1871 | -- | Check a QResult
|
| 1871 | 1872 | checkQResult :: QResult a -> TcM a
|