STM stats in ghcide

Author: pepeiborra

ghcide/session-loader/Development/IDE/Session.hs

@@ -75,7 +75,7 @@ import           System.Info
 import           Control.Applicative                  (Alternative ((<|>)))
 import           Data.Void
 
-import           Control.Concurrent.STM               (atomically)
+import           Control.Concurrent.STM.Stats         (atomically)
 import           Control.Concurrent.STM.TQueue
 import           Data.Foldable                        (for_)
 import qualified Data.HashSet                         as Set

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/FileExists.hs

@@ -10,7 +10,8 @@ module Development.IDE.Core.FileExists
   )
 where
 
-import           Control.Concurrent.STM                (atomically)
+import           Control.Concurrent.STM.Stats          (atomically,
+                                                        atomicallyNamed)
 import           Control.Exception
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
@@ -94,7 +95,7 @@ modifyFileExists state changes = do
   -- Masked to ensure that the previous values are flushed together with the map update
   mask $ \_ -> do
     -- update the map
-    void $ atomically $ forM_ changes $ \(f,c) ->
+    void $ atomicallyNamed "modifyFileExists" $ forM_ changes $ \(f,c) ->
         case fromChange c of
             Just c' -> STM.focus (Focus.insert c') f var
             Nothing -> pure ()

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

@@ -24,7 +24,7 @@ module Development.IDE.Core.FileStore(
     registerFileWatches
     ) where
 
-import           Control.Concurrent.STM                       (atomically,
+import           Control.Concurrent.STM.Stats                 (atomically,
                                                                modifyTVar')
 import           Control.Concurrent.STM.TQueue                (writeTQueue)
 import           Control.Concurrent.Strict

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         (TVar, atomically, newTVarIO,
-                                                 readTVar, readTVarIO,
-                                                 writeTVar)
+import           Control.Concurrent.STM.Stats   (TVar, atomicallyNamed,
+                                                 newTVarIO, readTVar,
+                                                 readTVarIO, writeTVar)
 import           Control.Concurrent.Strict
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
@@ -83,7 +83,7 @@ newInProgress :: IO InProgressState
 newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO
 
 recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
-recordProgress InProgressState{..} file shift = atomically $ do
+recordProgress InProgressState{..} file shift = atomicallyNamed "recordProgress" $ do
     done <- readTVar doneVar
     todo <- readTVar todoVar
     (prev, new) <- STM.focus alterPrevAndNew file currentVar

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,11 +343,11 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
           case mv of
             Nothing -> do
-                void $ atomically $ STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state
+                void $ atomicallyNamed "lastValueIO 1" $ STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state
                 return Nothing
             Just (v,del,ver) -> do
-                void $ atomically $ STM.focus (Focus.alter (alterValue $ Stale (Just del) ver (toDyn v))) (toKey k file) state
-                atomically $ Just . (v,) . addDelta del <$> mappingForVersion positionMapping file ver
+                void $ atomicallyNamed "lastValueIO 2"  $ STM.focus (Focus.alter (alterValue $ Stale (Just del) ver (toDyn v))) (toKey k file) state
+                atomicallyNamed "lastValueIO 3"  $ Just . (v,) . addDelta del <$> mappingForVersion positionMapping file ver
 
         -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics
         alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics
@@ -356,13 +357,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
 
@@ -439,7 +440,7 @@ deleteValue
   -> k
   -> NormalizedFilePath
   -> IO ()
-deleteValue ShakeExtras{dirtyKeys, state} key file = atomically $ do
+deleteValue ShakeExtras{dirtyKeys, state} key file = atomicallyNamed "deleteValue" $ do
     STM.delete (toKey key file) state
     modifyTVar' dirtyKeys $ HSet.insert (toKey key file)
 
@@ -450,7 +451,7 @@ recordDirtyKeys
   -> [NormalizedFilePath]
   -> IO ()
 recordDirtyKeys ShakeExtras{dirtyKeys} key file = withEventTrace "recordDirtyKeys" $ \addEvent -> do
-    atomically $ modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file)
+    atomicallyNamed "recordDirtyKeys" $ modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file)
     addEvent (fromString $ "dirty " <> show key) (fromString $ unlines $ map fromNormalizedFilePath file)
 
 
@@ -626,8 +627,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
                       _       -> ""
@@ -660,7 +661,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 ->
@@ -669,7 +670,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)
@@ -684,7 +685,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
@@ -693,14 +694,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 ++ ")"
@@ -759,11 +760,11 @@ instantiateDelayedAction (DelayedAction _ s p a) = do
 
 getDiagnostics :: IdeState -> IO [FileDiagnostic]
 getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
-    atomically $ getAllDiagnostics diagnostics
+    atomicallyNamed "getAllDiagnostics" $ getAllDiagnostics diagnostics
 
 getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
 getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
-    atomically $ getAllDiagnostics hiddenDiagnostics
+    atomicallyNamed "getAllDiagnostics - hidden" $ getAllDiagnostics hiddenDiagnostics
 
 -- | Find and release old keys from the state Hashmap
 --   For the record, there are other state sources that this process does not release:
@@ -803,7 +804,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)
@@ -907,7 +908,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
@@ -1016,7 +1017,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 "defineEarlyCutoff - read 1" $ getValues state key file
                 case v of
                     -- No changes in the dependencies and we have
                     -- an existing successful result.
@@ -1035,10 +1036,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 "defineEarlyCutoff - read 2" (getValues state GetModificationTime file)
                 (bs, res) <- case res of
                     Nothing -> do
-                        staleV <- liftIO $ atomically $ getValues state key file
+                        staleV <- liftIO $ atomicallyNamed "defineEarlyCutoff -read 3" $ getValues state key file
                         pure $ case staleV of
                             Nothing -> (toShakeValue ShakeResult bs, Failed False)
                             Just v -> case v of
@@ -1049,7 +1050,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 "defineEarlyCutoff - 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
@@ -1061,7 +1062,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 "defineEarlyCutoff - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file)
         return res
 
 traceA :: A v -> String
@@ -1149,7 +1150,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
@@ -1159,13 +1160,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
@@ -1224,7 +1225,7 @@ getAllDiagnostics =
 
 updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
 updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) =
-    atomically $ STM.focus (Focus.alter f) uri positionMapping
+    atomicallyNamed "updatePositionMapping" $ STM.focus (Focus.alter f) uri positionMapping
       where
         uri = toNormalizedUri _uri
         f = Just . f' . fromMaybe mempty