11{-
2- Module : Development.IDE.WorkerThread
2+ Module : Development.IDE.Core. WorkerThread
33Author : @soulomoon
44SPDX-License-Identifier: Apache-2.0
55
66Description : This module provides an API for managing worker threads in the IDE.
77see Note [Serializing runs in separate thread]
88-}
9- {-# LANGUAGE LambdaCase #-}
10- {-# LANGUAGE OverloadedStrings #-}
11-
12- module Development.IDE.WorkerThread
9+ module Development.IDE.Core.WorkerThread
1310 ( LogWorkerThread (.. ),
1411 withWorkerQueue ,
1512 awaitRunInThread ,
1613 TaskQueue ,
1714 writeTaskQueue ,
18- withWorkerQueueSimple ,
19- awaitRunInThreadStm ,
20- awaitRunInThreadStmInNewThread
21- ) where
15+ withWorkerQueueSimple
16+ )
17+ where
2218
23- import Control.Concurrent.Async ( Async , async , withAsync )
19+ import Control.Concurrent.Async ( withAsync )
2420import Control.Concurrent.STM
25- import Control.Exception.Safe (MonadMask (.. ),
26- SomeException (SomeException ),
27- finally , throw , try )
28- import Control.Monad.Cont (ContT (ContT ))
29- import qualified Data.Text as T
30-
31- import Control.Concurrent
32- import Control.Exception (catch )
33- import Control.Monad (void , when )
21+ import Control.Concurrent.Strict (newBarrier , signalBarrier ,
22+ waitBarrier )
23+ import Control.Exception.Safe (SomeException , finally , throwIO ,
24+ try )
25+ import Control.Monad.Cont (ContT (ContT ))
26+ import qualified Data.Text as T
27+ import Ide.Logger
3428
3529data LogWorkerThread
3630 = LogThreadEnding ! T. Text
3731 | LogThreadEnded ! T. Text
3832 | LogSingleWorkStarting ! T. Text
3933 | LogSingleWorkEnded ! T. Text
40- | LogMainThreadId ! T. Text! ThreadId
4134 deriving (Show )
4235
43- -- instance Pretty LogWorkerThread where
44- -- pretty = \case
45- -- LogThreadEnding t -> "Worker thread ending:" <+> pretty t
46- -- LogThreadEnded t -> "Worker thread ended:" <+> pretty t
47- -- LogSingleWorkStarting t -> "Worker starting a unit of work: " <+> pretty t
48- -- LogSingleWorkEnded t -> "Worker ended a unit of work: " <+> pretty t
49- -- LogMainThreadId t tid -> "Main thread for" <+> pretty t <+> "is" <+> pretty (show tid)
36+ instance Pretty LogWorkerThread where
37+ pretty = \ case
38+ LogThreadEnding t -> " Worker thread ending:" <+> pretty t
39+ LogThreadEnded t -> " Worker thread ended:" <+> pretty t
40+ LogSingleWorkStarting t -> " Worker starting a unit of work: " <+> pretty t
41+ LogSingleWorkEnded t -> " Worker ended a unit of work: " <+> pretty t
5042
5143{-
5244Note [Serializing runs in separate thread]
@@ -62,17 +54,14 @@ data TaskQueue a = TaskQueue (TQueue a)
6254newTaskQueueIO :: IO TaskQueue a )
6355newTaskQueueIO = TaskQueue <$> newTQueueIO
6456data ExitOrTask t = Exit | Task t
65- type Logger = LogWorkerThread -> IO ()
6657
6758-- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker
6859-- thread which polls the queue for requests and runs the given worker
6960-- function on them.
70- withWorkerQueueSimple :: Logger -> T. Text-> ContT () IO TaskQueue (IO () ))
61+ withWorkerQueueSimple :: Recorder ( WithPriority LogWorkerThread ) -> T. Text-> ContT () IO TaskQueue (IO () ))
7162withWorkerQueueSimple log title = withWorkerQueue log title id
72- withWorkerQueue :: Logger -> T. Text-> (t -> IO () ) -> ContT () IO TaskQueue t )
63+ withWorkerQueue :: Recorder ( WithPriority LogWorkerThread ) -> T. Text-> (t -> IO () ) -> ContT () IO TaskQueue t )
7364withWorkerQueue log title workerAction = ContT $ \ mainAction -> do
74- tid <- myThreadId
75- log (LogMainThreadId title tid)
7665 q <- newTaskQueueIO
7766 -- Use a TMVar as a stop flag to coordinate graceful shutdown.
7867 -- The worker thread checks this flag before dequeuing each job; if set, it exits immediately,
@@ -87,8 +76,8 @@ withWorkerQueue log title workerAction = ContT $ \mainAction -> do
8776 -- if we want to debug the exact location the worker swallows an async exception, we can
8877 -- temporarily comment out the `finally` clause.
8978 `finally` atomically (putTMVar b () )
90- log (LogThreadEnding title)
91- log (LogThreadEnded title)
79+ logWith log Debug (LogThreadEnding title)
80+ logWith log Debug (LogThreadEnded title)
9281 where
9382 -- writerThread :: TaskQueue t -> TMVar () -> (forall a. IO a -> IO a) -> IO ()
9483 writerThread q b =
@@ -104,46 +93,24 @@ withWorkerQueue log title workerAction = ContT $ \mainAction -> do
10493 case task of
10594 Exit -> return ()
10695 Task t -> do
107- log $ LogSingleWorkStarting title
96+ logWith log Debug $ LogSingleWorkStarting title
10897 workerAction t
109- log $ LogSingleWorkEnded title
98+ logWith log Debug $ LogSingleWorkEnded title
11099 writerThread q b
111100
112101
113102-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread,
114103-- and then blocks until the result is computed. If the action throws an
115104-- non-async exception, it is rethrown in the calling thread.
116- awaitRunInThreadStm :: TaskQueue (IO () ) -> IO result -> STM result
117- awaitRunInThreadStm (TaskQueue q) act = do
118- barrier <- newEmptyTMVar
119- -- Take an action from TQueue, run it and
120- -- use barrier to wait for the result
121- writeTQueue q (try act >>= atomically . putTMVar barrier)
122- resultOrException <- takeTMVar barrier
123- case resultOrException of
124- Left -> throw (e :: SomeException )
125- Right -> return r
126-
127- awaitRunInThreadStmInNewThread :: STM Int -> Int -> TaskQueue (IO () ) -> TVar [Async () ] -> IO result -> (SomeException -> IO () ) -> STM ()
128- awaitRunInThreadStmInNewThread getStep deliverStep (TaskQueue q) tthreads act handler = do
129- -- Take an action from TQueue, run it and
130- -- use barrier to wait for the result
131- writeTQueue q (uninterruptibleMask $ \ restore -> do
132- curStep <- atomically getStep
133- when (curStep == deliverStep) $ do
134- sync <- async (restore (void act `catch` \ (SomeException e) -> handler (SomeException e)))
135- atomically $ modifyTVar' tthreads (sync: )
136- )
137-
138105awaitRunInThread :: TaskQueue (IO () ) -> IO result -> IO result
139106awaitRunInThread (TaskQueue q) act = do
140- barrier <- newEmptyTMVarIO
141107 -- Take an action from TQueue, run it and
142108 -- use barrier to wait for the result
143- atomically $ writeTQueue q (try act >>= atomically . putTMVar barrier)
144- resultOrException <- atomically $ takeTMVar barrier
109+ barrier <- newBarrier
110+ atomically $ writeTQueue q (try act >>= signalBarrier barrier)
111+ resultOrException <- waitBarrier barrier
145112 case resultOrException of
146- Left -> throw (e :: SomeException )
113+ Left -> throwIO (e :: SomeException )
147114 Right -> return r
148115
149116writeTaskQueue :: TaskQueue a -> a -> STM ()
0 commit comments