Decrease contention in Progress reporting

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

@@ -96,7 +96,7 @@ import           GHC                               (GetDocsFailure (..),
                                                     parsedSource)
 
 import           Control.Concurrent.Extra
-import           Control.Concurrent.STM            hiding (orElse)
+import           Control.Concurrent.STM.Stats      hiding (orElse)
 import           Data.Aeson                        (toJSON)
 import           Data.Binary
 import           Data.Coerce

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

@@ -14,9 +14,9 @@ module Development.IDE.Core.ProgressReporting
    where
 
 import           Control.Concurrent.Async
-import           Control.Concurrent.STM.Stats   (STM, TVar, atomically,
-                                                 newTVarIO, readTVar,
-                                                 readTVarIO, writeTVar)
+import           Control.Concurrent.STM.Stats   (TVar, atomicallyNamed,
+                                                 modifyTVar', newTVarIO,
+                                                 readTVarIO)
 import           Control.Concurrent.Strict
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
@@ -82,21 +82,17 @@ 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
+        case (prev,new) of
+            (Nothing,0) -> modifyTVar' doneVar (+1) >> modifyTVar' todoVar (+1)
+            (Nothing,_) -> modifyTVar' todoVar (+1)
+            (Just 0, 0) -> pure ()
+            (Just 0, _) -> modifyTVar' doneVar pred
+            (Just _, 0) -> modifyTVar' doneVar (+1)
+            (Just _, _) -> pure()
   where
     alterPrevAndNew = do
         prev <- Focus.lookup
@@ -186,7 +182,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 = atomically $ 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

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

@@ -148,6 +148,7 @@ import           GHC.Fingerprint
 import           Language.LSP.Types.Capabilities
 import           OpenTelemetry.Eventlog
 
+import           Control.Concurrent.STM.Stats           (atomicallyNamed)
 import           Control.Exception.Extra                hiding (bracket_)
 import           Data.Aeson                             (toJSON)
 import qualified Data.ByteString.Char8                  as BS8
@@ -342,7 +343,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
             f <- MaybeT $ pure $ HMap.lookup (Key k) pmap
             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
-          atomically $ case mv of
+          atomicallyNamed "lastValueIO" $ case mv of
             Nothing -> do
                 STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state
                 return Nothing
@@ -358,13 +359,13 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
           -- Something already succeeded before, leave it alone
           _        -> old
 
-    atomically (STM.lookup (toKey k file) state) >>= \case
+    atomicallyNamed "lastValueIO 4"  (STM.lookup (toKey k file) state) >>= \case
       Nothing -> readPersistent
       Just (ValueWithDiagnostics v _) -> case v of
         Succeeded ver (fromDynamic -> Just v) ->
-            atomically $ Just . (v,) <$> mappingForVersion positionMapping file ver
+            atomicallyNamed "lastValueIO 5"  $ Just . (v,) <$> mappingForVersion positionMapping file ver
         Stale del ver (fromDynamic -> Just v) ->
-            atomically $ Just . (v,) . maybe id addDelta del <$> mappingForVersion positionMapping file ver
+            atomicallyNamed "lastValueIO 6"  $ Just . (v,) . maybe id addDelta del <$> mappingForVersion positionMapping file ver
         Failed p | not p -> readPersistent
         _ -> pure Nothing
 
@@ -456,7 +457,6 @@ recordDirtyKeys ShakeExtras{dirtyKeys} key file = do
     return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do
         addEvent (fromString $ "dirty " <> show key) (fromString $ unlines $ map fromNormalizedFilePath file)
 
-
 -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
 getValues ::
   forall k v.
@@ -629,8 +629,8 @@ shakeRestart IdeState{..} reason acts =
         (\runner -> do
               (stopTime,()) <- duration (cancelShakeSession runner)
               res <- shakeDatabaseProfile shakeDb
-              backlog <- readTVarIO (dirtyKeys shakeExtras)
-              queue <- atomically $ peekInProgress $ actionQueue shakeExtras
+              backlog <- readTVarIO $ dirtyKeys shakeExtras
+              queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
               let profile = case res of
                       Just fp -> ", profile saved at " <> fp
                       _       -> ""
@@ -663,7 +663,7 @@ notifyTestingLogMessage extras msg = do
 shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
 shakeEnqueue ShakeExtras{actionQueue, logger} act = do
     (b, dai) <- instantiateDelayedAction act
-    atomically $ pushQueue dai actionQueue
+    atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue
     let wait' b =
             waitBarrier b `catches`
               [ Handler(\BlockedIndefinitelyOnMVar ->
@@ -672,7 +672,7 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do
               , Handler (\e@AsyncCancelled -> do
                   logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"
 
-                  atomically $ abortQueue dai actionQueue
+                  atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue
                   throw e)
               ]
     return (wait' b >>= either throwIO return)
@@ -687,7 +687,7 @@ newSession
     -> IO ShakeSession
 newSession extras@ShakeExtras{..} shakeDb acts reason = do
     IdeOptions{optRunSubset} <- getIdeOptionsIO extras
-    reenqueued <- atomically $ peekInProgress actionQueue
+    reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue
     allPendingKeys <-
         if optRunSubset
           then Just <$> readTVarIO dirtyKeys
@@ -696,14 +696,14 @@ newSession extras@ShakeExtras{..} shakeDb acts reason = do
         -- A daemon-like action used to inject additional work
         -- Runs actions from the work queue sequentially
         pumpActionThread otSpan = do
-            d <- liftIO $ atomically $ popQueue actionQueue
+            d <- liftIO $ atomicallyNamed "action queue - pop" $ popQueue actionQueue
             actionFork (run otSpan d) $ \_ -> pumpActionThread otSpan
 
         -- TODO figure out how to thread the otSpan into defineEarlyCutoff
         run _otSpan d  = do
             start <- liftIO offsetTime
             getAction d
-            liftIO $ atomically $ doneQueue d actionQueue
+            liftIO $ atomicallyNamed "actionQueue - done" $ doneQueue d actionQueue
             runTime <- liftIO start
             let msg = T.pack $ "finish: " ++ actionName d
                             ++ " (took " ++ showDuration runTime ++ ")"
@@ -806,7 +806,7 @@ garbageCollectKeys label maxAge checkParents agedKeys = do
             | age > maxAge
             , Just (kt,_) <- fromKeyType k
             , not(kt `HSet.member` preservedKeys checkParents)
-            = atomically $ do
+            = atomicallyNamed "GC" $ do
                 gotIt <- STM.focus (Focus.member <* Focus.delete) k values
                 when gotIt $
                    modifyTVar' dk (HSet.insert k)
@@ -910,7 +910,7 @@ useWithStaleFast' key file = do
   wait <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file
 
   s@ShakeExtras{state} <- askShake
-  r <- liftIO $ atomically $ getValues state key file
+  r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file
   liftIO $ case r of
     -- block for the result if we haven't computed before
     Nothing -> do
@@ -1019,7 +1019,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
     (if optSkipProgress options key then id else inProgress progress file) $ do
         val <- case old of
             Just old | mode == RunDependenciesSame -> do
-                v <- liftIO $ atomically $ getValues state key file
+                v <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file
                 case v of
                     -- No changes in the dependencies and we have
                     -- an existing successful result.
@@ -1038,10 +1038,10 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
                     (do v <- action; liftIO $ evaluate $ force v) $
                     \(e :: SomeException) -> do
                         pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
-                modTime <- liftIO $ (currentValue . fst =<<) <$> atomically (getValues state GetModificationTime file)
+                modTime <- liftIO $ (currentValue . fst =<<) <$> atomicallyNamed "define - read 2" (getValues state GetModificationTime file)
                 (bs, res) <- case res of
                     Nothing -> do
-                        staleV <- liftIO $ atomically $ getValues state key file
+                        staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file
                         pure $ case staleV of
                             Nothing -> (toShakeValue ShakeResult bs, Failed False)
                             Just v -> case v of
@@ -1052,7 +1052,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
                                 (Failed b, _) ->
                                     (toShakeValue ShakeResult bs, Failed b)
                     Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
-                liftIO $ atomically $ setValues state key file res (Vector.fromList diags)
+                liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags)
                 doDiagnostics diags
                 let eq = case (bs, fmap decodeShakeValue old) of
                         (ShakeResult a, Just (ShakeResult b)) -> cmp a b
@@ -1064,7 +1064,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
                     (encodeShakeValue bs) $
                     A res
-        liftIO $ atomically $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file)
+        liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file)
         return res
 
 traceA :: A v -> String
@@ -1152,7 +1152,7 @@ updateFileDiagnostics :: MonadIO m
   -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
   -> m ()
 updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do
-    modTime <- (currentValue . fst =<<) <$> atomically (getValues state GetModificationTime fp)
+    modTime <- (currentValue . fst =<<) <$> atomicallyNamed "diagnostics - read" (getValues state GetModificationTime fp)
     let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
         uri = filePathToUri' fp
         ver = vfsVersion =<< modTime
@@ -1162,13 +1162,13 @@ updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, p
         -- published. Otherwise, we might never publish certain diagnostics if
         -- an exception strikes between modifyVar but before
         -- publishDiagnosticsNotification.
-        newDiags <- liftIO $ atomically $ update (map snd currentShown) diagnostics
-        _ <- liftIO $ atomically $ update (map snd currentHidden) hiddenDiagnostics
+        newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (map snd currentShown) diagnostics
+        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (map snd currentHidden) hiddenDiagnostics
         let uri = filePathToUri' fp
         let delay = if null newDiags then 0.1 else 0
         registerEvent debouncer delay uri $ do
              join $ mask_ $ do
-                 lastPublish <- atomically $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics
+                 lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics
                  let action = when (lastPublish /= newDiags) $ case lspEnv of
                         Nothing -> -- Print an LSP event.
                             logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags

ghcide/test/exe/Progress.hs

@@ -35,7 +35,7 @@ reportProgressTests = testGroup "recordProgress"
         decrease = recordProgressModel "A" succ increase
         done = recordProgressModel "A" pred decrease
         recordProgressModel key change state =
-            model state $ \st -> atomically $ recordProgress st key change
+            model state $ \st -> recordProgress st key change
         model stateModelIO k = do
             state <- fromModel =<< stateModelIO
             k state