From 500b218f14d4b25a363fe2e17821b8fedd5be9aa Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 28 Nov 2021 09:49:23 +0000 Subject: [PATCH 1/6] lock-less debouncer --- ghcide/src/Development/IDE/Core/Debouncer.hs | 33 ++++++++++---------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index f0785d56e9..0616ebe44d 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/ghcide/src/Development/IDE/Core/Debouncer.hs @@ -9,12 +9,12 @@ module Development.IDE.Core.Debouncer ) where import Control.Concurrent.Async -import Control.Concurrent.STM.Stats (atomically, atomicallyNamed) +import Control.Concurrent.STM +import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Exception import Control.Monad (join) -import Data.Foldable (traverse_) import Data.Hashable -import qualified Focus +import GHC.Conc (unsafeIOToSTM) import qualified StmContainers.Map as STM import System.Time.Extra @@ -39,20 +39,21 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> STM.newIO -- If there is a pending event for the same key, the pending event will be killed. -- Events are run unmasked so it is up to the user of `registerEvent` -- to mask if required. -asyncRegisterEvent :: (Eq k, Hashable k) => STM.Map k (Async ()) -> Seconds -> k -> IO () -> IO () -asyncRegisterEvent d 0 k fire = do - join $ atomically $ do - prev <- STM.focus Focus.lookupAndDelete k d - return $ traverse_ cancel prev - fire +asyncRegisterEvent :: (Eq k, Hashable k) => STM.Map k (TVar (Seconds, IO())) -> Seconds -> k -> IO () -> IO () asyncRegisterEvent d delay k fire = mask_ $ do - a <- asyncWithUnmask $ \unmask -> unmask $ do - sleep delay - fire - atomically $ STM.delete k d - do - prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d - traverse_ cancel prev + prev <- atomically $ STM.lookup k d + case prev of + Just v -> do + atomicallyNamed "debouncer - reset" $ writeTVar v (delay, fire) + Nothing -> do + var <- newTVarIO (delay, fire) + _ <- asyncWithUnmask $ \unmask -> unmask $ do + join $ atomicallyNamed "debouncer - sleep" $ do + (s,act) <- readTVar var + unsafeIOToSTM $ sleep s + STM.delete k d + return act + atomicallyNamed "debouncer2" $ STM.insert var k d -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k From 82c524cb6c250f1c4af8044be0efa9ba6400ff03 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Dec 2021 12:50:50 +0000 Subject: [PATCH 2/6] merge two transactions --- ghcide/src/Development/IDE/Core/Debouncer.hs | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index 0616ebe44d..8aadb4bc5a 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/ghcide/src/Development/IDE/Core/Debouncer.hs @@ -35,19 +35,14 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> STM.newIO -- | Register an event that will fire after the given delay if no other event -- for the same key gets registered until then. --- --- If there is a pending event for the same key, the pending event will be killed. --- Events are run unmasked so it is up to the user of `registerEvent` --- to mask if required. asyncRegisterEvent :: (Eq k, Hashable k) => STM.Map k (TVar (Seconds, IO())) -> Seconds -> k -> IO () -> IO () -asyncRegisterEvent d delay k fire = mask_ $ do - prev <- atomically $ STM.lookup k d +asyncRegisterEvent d delay k fire = join $ atomically $ do + prev <- STM.lookup k d case prev of - Just v -> do - atomicallyNamed "debouncer - reset" $ writeTVar v (delay, fire) - Nothing -> do + Just v -> writeTVar v (delay, fire) >> return (pure ()) + Nothing -> return $ do var <- newTVarIO (delay, fire) - _ <- asyncWithUnmask $ \unmask -> unmask $ do + _ <- async $ do join $ atomicallyNamed "debouncer - sleep" $ do (s,act) <- readTVar var unsafeIOToSTM $ sleep s From 793bd27a887d09691f4a8d197740a84fbb3e60d4 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Dec 2021 13:09:31 +0000 Subject: [PATCH 3/6] fix transaction --- ghcide/src/Development/IDE/Core/Debouncer.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index 8aadb4bc5a..d95a543ad1 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/ghcide/src/Development/IDE/Core/Debouncer.hs @@ -12,7 +12,7 @@ import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Exception -import Control.Monad (join) +import Control.Monad (join, void) import Data.Hashable import GHC.Conc (unsafeIOToSTM) import qualified StmContainers.Map as STM @@ -40,15 +40,15 @@ asyncRegisterEvent d delay k fire = join $ atomically $ do prev <- STM.lookup k d case prev of Just v -> writeTVar v (delay, fire) >> return (pure ()) - Nothing -> return $ do - var <- newTVarIO (delay, fire) - _ <- async $ do + Nothing -> do + var <- newTVar (delay, fire) + STM.insert var k d + return $ void $ async $ do join $ atomicallyNamed "debouncer - sleep" $ do (s,act) <- readTVar var unsafeIOToSTM $ sleep s STM.delete k d return act - atomicallyNamed "debouncer2" $ STM.insert var k d -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k From 06d77ccbb21808cad9d9b1138add32b5ac94bdef Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Dec 2021 13:15:27 +0000 Subject: [PATCH 4/6] handle the 0 delay case (for tests) --- ghcide/src/Development/IDE/Core/Debouncer.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index d95a543ad1..d92e2548c6 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/ghcide/src/Development/IDE/Core/Debouncer.hs @@ -36,14 +36,16 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> STM.newIO -- | Register an event that will fire after the given delay if no other event -- for the same key gets registered until then. asyncRegisterEvent :: (Eq k, Hashable k) => STM.Map k (TVar (Seconds, IO())) -> Seconds -> k -> IO () -> IO () -asyncRegisterEvent d delay k fire = join $ atomically $ do +asyncRegisterEvent d delay k fire = join $ atomicallyNamed "debouncer - register" $ do prev <- STM.lookup k d case prev of Just v -> writeTVar v (delay, fire) >> return (pure ()) - Nothing -> do + Nothing + | delay == 0 -> return fire + | otherwise -> do var <- newTVar (delay, fire) STM.insert var k d - return $ void $ async $ do + return $ void $ async $ join $ atomicallyNamed "debouncer - sleep" $ do (s,act) <- readTVar var unsafeIOToSTM $ sleep s From ab90c303b45c7e9b20d050a06b51bb9cb01504b1 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Dec 2021 15:35:32 +0000 Subject: [PATCH 5/6] Fix undesired dependency on the debouncer map. The dependency could lead to delaying the action more than intended --- ghcide/src/Development/IDE/Core/Debouncer.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index d92e2548c6..07ef3e4b03 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/ghcide/src/Development/IDE/Core/Debouncer.hs @@ -11,7 +11,6 @@ module Development.IDE.Core.Debouncer import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.Stats (atomicallyNamed) -import Control.Exception import Control.Monad (join, void) import Data.Hashable import GHC.Conc (unsafeIOToSTM) @@ -49,8 +48,9 @@ asyncRegisterEvent d delay k fire = join $ atomicallyNamed "debouncer - register join $ atomicallyNamed "debouncer - sleep" $ do (s,act) <- readTVar var unsafeIOToSTM $ sleep s - STM.delete k d - return act + return $ do + atomically (STM.delete k d) + act -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k From 0230d518ecfd28ac8e520db0e72cb6c16cdce856 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Dec 2021 16:03:41 +0000 Subject: [PATCH 6/6] Fix race condition when deleting an entry from the map --- ghcide/src/Development/IDE/Core/Debouncer.hs | 45 ++++++++++++++++---- 1 file changed, 36 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index 07ef3e4b03..2656efe940 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/ghcide/src/Development/IDE/Core/Debouncer.hs @@ -34,23 +34,50 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> STM.newIO -- | Register an event that will fire after the given delay if no other event -- for the same key gets registered until then. -asyncRegisterEvent :: (Eq k, Hashable k) => STM.Map k (TVar (Seconds, IO())) -> Seconds -> k -> IO () -> IO () +asyncRegisterEvent + :: (Eq k, Hashable k) + => STM.Map k (TVar (Maybe (Seconds, IO()))) + -> Seconds + -> k + -> IO () + -> IO () asyncRegisterEvent d delay k fire = join $ atomicallyNamed "debouncer - register" $ do + -- The previous TVar for this key, if any prev <- STM.lookup k d case prev of - Just v -> writeTVar v (delay, fire) >> return (pure ()) + Just v -> do + current <- readTVar v + case current of + -- Not empty, means that there is a thread running the actions + Just _ -> writeTVar v (Just (delay, fire)) >> return (pure ()) + -- Empty = no thread. We need to start one for running the action + Nothing -> writeTVar v (Just (delay, fire)) >> return (restart v) + + -- No previous TVar, we need to insert one and restart a thread for running the action Nothing | delay == 0 -> return fire | otherwise -> do - var <- newTVar (delay, fire) + var <- newTVar (Just (delay, fire)) STM.insert var k d - return $ void $ async $ + return (restart var) + where + -- | Restart a thread to run the action stored in the given TVar + -- Once the action is done, the thread dies. + -- Assumes the Tvar is not empty + restart var = + void $ async $ join $ atomicallyNamed "debouncer - sleep" $ do - (s,act) <- readTVar var - unsafeIOToSTM $ sleep s - return $ do - atomically (STM.delete k d) - act + contents <- readTVar var + case contents of + Nothing -> error "impossible" + Just (s,act) -> do + -- sleep for the given delay + -- If the TVar is written while sleeping, + -- the transaction will restart + unsafeIOToSTM $ sleep s + -- we are done - empty the TVar before exiting + writeTVar var Nothing + return act -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k