Improve thread contention around diagnostics

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

@@ -11,7 +11,8 @@ module Development.IDE.Core.Debouncer
 import           Control.Concurrent.Async
 import           Control.Concurrent.Extra
 import           Control.Exception
-import           Control.Monad.Extra
+import           Control.Monad            (join)
+import           Data.Foldable            (traverse_)
 import           Data.HashMap.Strict      (HashMap)
 import qualified Data.HashMap.Strict      as Map
 import           Data.Hashable
@@ -40,17 +41,18 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty
 -- to mask if required.
 asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
 asyncRegisterEvent d 0 k fire = do
-    modifyVar_ d $ \m -> mask_ $ do
-        whenJust (Map.lookup k m) cancel
-        pure $ Map.delete k m
+    join $ modifyVar d $ \m -> do
+        (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Nothing)) k m
+        return (m', cancel)
     fire
-asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do
-    whenJust (Map.lookup k m) cancel
+asyncRegisterEvent d delay k fire = mask_ $ do
     a <- asyncWithUnmask $ \unmask -> unmask $ do
         sleep delay
         fire
-        modifyVar_ d (pure . Map.delete k)
-    pure $ Map.insert k a m
+        modifyVar_ d (evaluate . Map.delete k)
+    join $ modifyVar d $ \m -> do
+        (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Just a)) k m
+        return (m', cancel)
 
 -- | Debouncer used in the DAML CLI compiler that emits events immediately.
 noopDebouncer :: Debouncer k

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

@@ -1100,15 +1100,16 @@ updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, p
         let uri = filePathToUri' fp
         let delay = if null newDiags then 0.1 else 0
         registerEvent debouncer delay uri $ do
-             mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
+             join $ mask_ $ modifyVar publishedDiagnostics $ \published -> do
                  let lastPublish = HMap.lookupDefault [] uri published
-                 when (lastPublish /= newDiags) $ case lspEnv of
-                   Nothing -> -- Print an LSP event.
-                     logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags
-                   Just env -> LSP.runLspT env $
-                     LSP.sendNotification LSP.STextDocumentPublishDiagnostics $
-                       LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags)
-                 pure $! HMap.insert uri newDiags published
+                     !published' = HMap.insert uri newDiags published
+                     action = when (lastPublish /= newDiags) $ case lspEnv of
+                        Nothing -> -- Print an LSP event.
+                            logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags
+                        Just env -> LSP.runLspT env $
+                            LSP.sendNotification LSP.STextDocumentPublishDiagnostics $
+                            LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags)
+                 return (published', action)
 
 newtype Priority = Priority Double
 

ghcide/src/Development/IDE/Main.hs

@@ -15,7 +15,8 @@ import           Data.Maybe                            (catMaybes, fromMaybe,
 import qualified Data.Text                             as T
 import qualified Data.Text.IO                          as T
 import           Development.IDE                       (Action, Rules)
-import           Development.IDE.Core.Debouncer        (newAsyncDebouncer)
+import           Development.IDE.Core.Debouncer        (Debouncer,
+                                                        newAsyncDebouncer)
 import           Development.IDE.Core.FileStore        (makeVFSHandle)
 import           Development.IDE.Core.IdeConfiguration (IdeConfiguration (..),
                                                         registerIdeConfiguration)
@@ -43,7 +44,8 @@ import           Development.IDE.Session               (SessionLoadingOptions,
                                                         loadSessionWithOptions,
                                                         runWithDb,
                                                         setInitialDynFlags)
-import           Development.IDE.Types.Location        (toNormalizedFilePath')
+import           Development.IDE.Types.Location        (NormalizedUri,
+                                                        toNormalizedFilePath')
 import           Development.IDE.Types.Logger          (Logger (Logger))
 import           Development.IDE.Types.Options         (IdeGhcSession,
                                                         IdeOptions (optCheckParents, optCheckProject, optReportProgress),
@@ -86,6 +88,7 @@ data Arguments = Arguments
     , argsLspOptions :: LSP.Options
     , argsDefaultHlsConfig :: Config
     , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project
+    , argsDebouncer :: IO (Debouncer NormalizedUri) -- ^ Debouncer used for diagnostics
     }
 
 instance Default Arguments where
@@ -101,6 +104,7 @@ instance Default Arguments where
         , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."}
         , argsDefaultHlsConfig = def
         , argsGetHieDbLoc = getHieDbLoc
+        , argsDebouncer = newAsyncDebouncer
         }
 
 -- | Cheap stderr logger that relies on LineBuffering
@@ -123,6 +127,8 @@ defaultMain Arguments{..} = do
         argsOnConfigChange _ide = pure . getConfigFromNotification argsDefaultHlsConfig
         rules = argsRules >> pluginRules plugins
 
+    debouncer <- argsDebouncer
+
     case argFiles of
         Nothing -> do
             t <- offsetTime
@@ -148,7 +154,6 @@ defaultMain Arguments{..} = do
                             { optReportProgress = clientSupportsProgress caps
                             }
                     caps = LSP.resClientCapabilities env
-                debouncer <- newAsyncDebouncer
                 initialise
                     argsDefaultHlsConfig
                     rules
@@ -184,7 +189,6 @@ defaultMain Arguments{..} = do
             when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"
             putStrLn "\nStep 3/4: Initializing the IDE"
             vfs <- makeVFSHandle
-            debouncer <- newAsyncDebouncer
             sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir
             let options = (argsIdeOptions Nothing sessionLoader)
                         { optCheckParents = pure NeverCheck