From ac3943c9d373620620bf02ed43375253d56d5d07 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 8 Mar 2021 06:35:44 +0000 Subject: [PATCH 1/4] tighten up the update diagnostics loop to avoid contention --- ghcide/src/Development/IDE/Core/Debouncer.hs | 7 ++++--- ghcide/src/Development/IDE/Core/Shake.hs | 17 +++++++++-------- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index 41ffd766cc..52c0a2e1b1 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/ghcide/src/Development/IDE/Core/Debouncer.hs @@ -44,13 +44,14 @@ asyncRegisterEvent d 0 k fire = do whenJust (Map.lookup k m) cancel pure $ Map.delete k m fire -asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do - whenJust (Map.lookup k m) cancel +asyncRegisterEvent d delay k fire = do a <- asyncWithUnmask $ \unmask -> unmask $ do sleep delay fire modifyVar_ d (pure . Map.delete k) - pure $ Map.insert k a m + modifyVar_ d $ \m -> mask_ $ do + whenJust (Map.lookup k m) cancel + pure $ Map.insert k a m -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b0d7d53277..17f82caad2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/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 From 41850eb3051f45fec53a484c1eb84bf20c67ecc0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 9 Mar 2021 22:07:23 +0000 Subject: [PATCH 2/4] Tighten the Debouncer --- ghcide/src/Development/IDE/Core/Debouncer.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index 52c0a2e1b1..4cc5bc21d2 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/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,18 +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 = do a <- asyncWithUnmask $ \unmask -> unmask $ do sleep delay fire - modifyVar_ d (pure . Map.delete k) - modifyVar_ d $ \m -> mask_ $ do - whenJust (Map.lookup k m) cancel - pure $ Map.insert k a m + modifyVar_ d (evaluate . Map.delete k) + join $ modifyVar d $ \m -> mask_ $ 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 From 4f42a7e590c99247ca74fa9e534ee8cbdc902908 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 10 Mar 2021 06:25:58 +0000 Subject: [PATCH 3/4] customize the Debouncer --- ghcide/src/Development/IDE/Main.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 14f58a0a83..2d8128e69a 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/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 From 0161c5b0cb0a1ef5c7de278f1c60f4452523dbe0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 11 Mar 2021 10:09:01 +0000 Subject: [PATCH 4/4] Fix mask scope --- ghcide/src/Development/IDE/Core/Debouncer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index 4cc5bc21d2..d7df9bad49 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/ghcide/src/Development/IDE/Core/Debouncer.hs @@ -45,12 +45,12 @@ asyncRegisterEvent d 0 k fire = do (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Nothing)) k m return (m', cancel) fire -asyncRegisterEvent d delay k fire = do +asyncRegisterEvent d delay k fire = mask_ $ do a <- asyncWithUnmask $ \unmask -> unmask $ do sleep delay fire modifyVar_ d (evaluate . Map.delete k) - join $ modifyVar d $ \m -> mask_ $ do + join $ modifyVar d $ \m -> do (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Just a)) k m return (m', cancel)