From 3b581a1fbf629440a07ab224adff9464d4f1a1d6 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 13 Dec 2021 01:42:46 +0000 Subject: [PATCH] Decrease contention in Progress reporting (#2357) * STM stats in ghcide * improve contention in progress reporting BEFORE ====== ``` STM transaction statistics (2021-12-12 09:30:40.138006 UTC): Transaction Commits Retries Ratio _anonymous_ 15297 118 0.01 action queue - pop 2 2 1.00 actionQueue - done 2 0 0.00 actionQueue - peek 29 0 0.00 actionQueue - push 2 0 0.00 builder 282354 853 0.00 compute 16882 16 0.00 debouncer 6842 195 0.03 define - dirtyKeys 16895 2 0.00 define - read 1 10710 11 0.00 define - read 2 6232 5 0.00 define - write 6225 1 0.00 diagnostics - hidden 6871 9 0.00 diagnostics - publish 4073 188 0.05 diagnostics - read 6886 4 0.00 diagnostics - update 6871 23 0.00 incDatabase 10966 0 0.00 lastValueIO 4 2200 0 0.00 lastValueIO 5 2200 0 0.00 recordProgress 31238 13856 0.44 updateReverseDeps 64994 358 0.01 ``` AFTER ===== ``` STM transaction statistics (2021-12-12 09:24:24.769304 UTC): Transaction Commits Retries Ratio _anonymous_ 15199 134 0.01 action queue - pop 2 2 1.00 actionQueue - done 2 0 0.00 actionQueue - peek 29 0 0.00 actionQueue - push 2 0 0.00 builder 282244 744 0.00 compute 16882 26 0.00 debouncer 6847 220 0.03 define - dirtyKeys 16908 1 0.00 define - read 1 10710 8 0.00 define - read 2 6244 2 0.00 define - write 6236 1 0.00 diagnostics - hidden 6876 18 0.00 diagnostics - publish 3978 184 0.05 diagnostics - read 6886 2 0.00 diagnostics - update 6876 24 0.00 incDatabase 10966 0 0.00 lastValueIO 4 2200 1 0.00 lastValueIO 5 2200 0 0.00 recordProgress 31252 403 0.01 recordProgress2 31252 207 0.01 updateReverseDeps 64994 430 0.01 ``` * fix tests * Remove reads (@michaelpj suggestion) After ===== ``` STM transaction statistics (2021-12-12 22:11:20.016977 UTC): Transaction Commits Retries Ratio _anonymous_ 15227 116 0.01 action queue - pop 2 2 1.00 actionQueue - done 2 0 0.00 actionQueue - peek 29 0 0.00 actionQueue - push 2 0 0.00 builder 282373 771 0.00 compute 16882 32 0.00 debouncer 6864 215 0.03 define - dirtyKeys 16900 0 0.00 define - read 1 10710 3 0.00 define - read 2 6254 3 0.00 define - write 6248 1 0.00 diagnostics - hidden 6893 10 0.00 diagnostics - publish 4006 200 0.05 diagnostics - read 6901 1 0.00 diagnostics - update 6893 22 0.00 incDatabase 10966 0 0.00 lastValueIO 4 2200 0 0.00 lastValueIO 5 2200 0 0.00 recordProgress 31238 387 0.01 recordProgress2 31238 79 0.00 updateReverseDeps 64994 387 0.01 ``` Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com> --- ghcide/src/Development/IDE/Core/Compile.hs | 2 +- .../Development/IDE/Core/ProgressReporting.hs | 32 ++++++------- ghcide/src/Development/IDE/Core/Shake.hs | 46 +++++++++---------- ghcide/test/exe/Progress.hs | 2 +- 4 files changed, 39 insertions(+), 43 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index df48f991ee..7b002f08fa 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 0cc4241397..79236aa2fa 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 1dfe7ed751..da4264f8e7 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/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 diff --git a/ghcide/test/exe/Progress.hs b/ghcide/test/exe/Progress.hs index 3e1b2f1583..a92fea9bc4 100644 --- a/ghcide/test/exe/Progress.hs +++ b/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