capture error in worker thread (#4342)

* use safe try that does not catch the asyncException
This commit is contained in:
soulomoon 2024-07-02 21:29:18 +08:00 committed by GitHub
parent 012e809054
commit f0ba40baf6
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194

View File

@ -10,10 +10,13 @@ module Development.IDE.Core.WorkerThread
(withWorkerQueue, awaitRunInThread) (withWorkerQueue, awaitRunInThread)
where where
import Control.Concurrent.Async (withAsync) import Control.Concurrent.Async (AsyncCancelled (AsyncCancelled),
withAsync)
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.Strict (newBarrier, signalBarrier, import Control.Concurrent.Strict (newBarrier, signalBarrier,
waitBarrier) waitBarrier)
import Control.Exception.Safe (Exception (fromException),
SomeException, throwIO, try)
import Control.Monad (forever) import Control.Monad (forever)
import Control.Monad.Cont (ContT (ContT)) import Control.Monad.Cont (ContT (ContT))
@ -42,13 +45,15 @@ withWorkerQueue workerAction = ContT $ \mainAction -> do
workerAction l workerAction l
-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, -- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread,
-- and then blocks until the result is computed. -- and then blocks until the result is computed. If the action throws an
-- non-async exception, it is rethrown in the calling thread.
awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result
awaitRunInThread q act = do awaitRunInThread q act = do
-- Take an action from TQueue, run it and -- Take an action from TQueue, run it and
-- use barrier to wait for the result -- use barrier to wait for the result
barrier <- newBarrier barrier <- newBarrier
atomically $ writeTQueue q $ do atomically $ writeTQueue q $ try act >>= signalBarrier barrier
res <- act resultOrException <- waitBarrier barrier
signalBarrier barrier res case resultOrException of
waitBarrier barrier Left e -> throwIO (e :: SomeException)
Right r -> return r