Skip to content

Commit bde97a3

Browse files
committed
improve contention in progress reporting
1 parent 1b27614 commit bde97a3

File tree

1 file changed

+14
-16
lines changed

1 file changed

+14
-16
lines changed

ghcide/src/Development/IDE/Core/ProgressReporting.hs

+14-16
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ module Development.IDE.Core.ProgressReporting
1414
where
1515

1616
import Control.Concurrent.Async
17-
import Control.Concurrent.STM.Stats (STM, TVar, atomicallyNamed,
17+
import Control.Concurrent.STM.Stats (TVar, atomicallyNamed,
1818
newTVarIO, readTVar,
1919
readTVarIO, writeTVar)
2020
import Control.Concurrent.Strict
@@ -82,21 +82,19 @@ data InProgressState = InProgressState
8282
newInProgress :: IO InProgressState
8383
newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO
8484

85-
recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> STM ()
85+
recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
8686
recordProgress InProgressState{..} file shift = do
87-
done <- readTVar doneVar
88-
todo <- readTVar todoVar
89-
(prev, new) <- STM.focus alterPrevAndNew file currentVar
90-
let (done',todo') =
91-
case (prev,new) of
92-
(Nothing,0) -> (done+1, todo+1)
93-
(Nothing,_) -> (done, todo+1)
94-
(Just 0, 0) -> (done , todo)
95-
(Just 0, _) -> (done-1, todo)
96-
(Just _, 0) -> (done+1, todo)
97-
(Just _, _) -> (done , todo)
98-
writeTVar todoVar todo'
99-
writeTVar doneVar done'
87+
(prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar
88+
atomicallyNamed "recordProgress2" $ do
89+
done <- readTVar doneVar
90+
todo <- readTVar todoVar
91+
case (prev,new) of
92+
(Nothing,0) -> writeTVar doneVar (done+1) >> writeTVar todoVar (todo+1)
93+
(Nothing,_) -> writeTVar todoVar (todo+1)
94+
(Just 0, 0) -> pure ()
95+
(Just 0, _) -> writeTVar doneVar (done-1)
96+
(Just _, 0) -> writeTVar doneVar (done+1)
97+
(Just _, _) -> pure()
10098
where
10199
alterPrevAndNew = do
102100
prev <- Focus.lookup
@@ -186,7 +184,7 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
186184
-- Do not remove the eta-expansion without profiling a session with at
187185
-- least 1000 modifications.
188186
where
189-
f shift = atomicallyNamed "recordProgress" $ recordProgress inProgress file shift
187+
f shift = recordProgress inProgress file shift
190188

191189
mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()
192190
mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f

0 commit comments

Comments
 (0)