improve contention in progress reporting

haskell · Dec 11, 2021 · e887a50 · e887a50
1 parent fde7de2
commit e887a50
Showing 1 changed file with 14 additions and 16 deletions.
diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs
@@ -14,7 +14,7 @@ module Development.IDE.Core.ProgressReporting
    where
 
 import           Control.Concurrent.Async
-import           Control.Concurrent.STM.Stats   (STM, TVar, atomicallyNamed,
+import           Control.Concurrent.STM.Stats   (TVar, atomicallyNamed,
                                                  newTVarIO, readTVar,
                                                  readTVarIO, writeTVar)
 import           Control.Concurrent.Strict
@@ -82,21 +82,19 @@ data InProgressState = InProgressState
 newInProgress :: IO InProgressState
 newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO
 
-recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> STM ()
+recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
 recordProgress InProgressState{..} file shift = do
-    done <- readTVar doneVar
-    todo <- readTVar todoVar
-    (prev, new) <- STM.focus alterPrevAndNew file currentVar
-    let (done',todo') =
-            case (prev,new) of
-                (Nothing,0) -> (done+1, todo+1)
-                (Nothing,_) -> (done,   todo+1)
-                (Just 0, 0) -> (done  , todo)
-                (Just 0, _) -> (done-1, todo)
-                (Just _, 0) -> (done+1, todo)
-                (Just _, _) -> (done  , todo)
-    writeTVar todoVar todo'
-    writeTVar doneVar done'
+    (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar
+    atomicallyNamed "recordProgress2" $ do
+        done <- readTVar doneVar
+        todo <- readTVar todoVar
+        case (prev,new) of
+            (Nothing,0) -> writeTVar doneVar (done+1) >> writeTVar todoVar (todo+1)
+            (Nothing,_) -> writeTVar todoVar (todo+1)
+            (Just 0, 0) -> pure ()
+            (Just 0, _) -> writeTVar doneVar (done-1)
+            (Just _, 0) -> writeTVar doneVar (done+1)
+            (Just _, _) -> pure()
   where
     alterPrevAndNew = do
         prev <- Focus.lookup
@@ -186,7 +184,7 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
             -- Do not remove the eta-expansion without profiling a session with at
             -- least 1000 modifications.
             where
-              f shift = atomicallyNamed "recordProgress" $ recordProgress inProgress file shift
+              f shift = recordProgress inProgress file shift
 
 mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()
 mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f