From 9464bbeb0a0e625cf10178eb9c6ffd6e2c523dc9 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 7 Mar 2022 20:11:06 +0000 Subject: [PATCH 01/11] Review masking and add traces when things don't cancel timely --- ghcide/src/Development/IDE/Core/FileExists.hs | 3 +-- ghcide/src/Development/IDE/Core/Shake.hs | 10 +++++++++- .../Development/IDE/Graph/Internal/Database.hs | 17 +++++++++++++++-- 3 files changed, 25 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 0b032e8686..aa2e309cca 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -109,8 +109,7 @@ modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update - -- update the map - mask_ $ join $ atomicallyNamed "modifyFileExists" $ do + join $ mask_ $ atomicallyNamed "modifyFileExists" $ do forM_ changes $ \(f,c) -> case fromChange c of Just c' -> STM.focus (Focus.insert c') f var diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 546d61c55f..6517df2856 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -173,6 +173,7 @@ data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath) + | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !(Maybe SomeException) | LogDiagsDiffButNoLspEnv ![FileDiagnostic] @@ -192,6 +193,8 @@ instance Pretty Log where , "Action Queue:" <+> pretty (map actionName actionQueue) , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog) , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] + LogBuildSessionRestartTakingTooLong seconds -> + "Build restart is taking too long (" <> pretty seconds <> " seconds)" LogDelayedAction delayedAction duration -> hsep [ "Finished:" <+> pretty (actionName delayedAction) @@ -683,7 +686,7 @@ shakeRestart recorder IdeState{..} reason acts = shakeSession (\runner -> do let log = logWith recorder - (stopTime,()) <- duration (cancelShakeSession runner) + (stopTime,()) <- duration $ errorAfter 10 recorder $ cancelShakeSession runner res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras @@ -706,6 +709,11 @@ shakeRestart recorder IdeState{..} reason acts = -- See https://github.com/haskell/ghcide/issues/79 (\() -> do (,()) <$> newSession recorder shakeExtras shakeDb acts reason) + where + errorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO () + errorAfter seconds recorder action = flip withAsync (const action) $ forever $ do + sleep seconds + logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () notifyTestingLogMessage extras msg = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 824abd14c4..aad613238b 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NumericUnderscores #-} module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where @@ -16,7 +17,7 @@ import Control.Concurrent.Extra import Control.Concurrent.STM.Stats (STM, atomically, atomicallyNamed, modifyTVar', newTVarIO, - readTVarIO) + readTVarIO, registerDelay, check, readTVar, orElse) import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -40,6 +41,7 @@ import qualified ListT import qualified StmContainers.Map as SMap import System.IO.Unsafe import System.Time.Extra (duration) +import Debug.Trace (traceM) newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do @@ -224,6 +226,7 @@ updateReverseDeps -> [Key] -- ^ Previous direct dependencies of Id -> HashSet Key -- ^ Current direct dependencies of Id -> IO () +-- mask to ensure that all the reverse dependencies are updated updateReverseDeps myId db prev new = uninterruptibleMask_ $ do forM_ prev $ \d -> unless (d `HSet.member` new) $ @@ -266,6 +269,7 @@ asyncWithCleanUp :: AIO a -> AIO (IO a) asyncWithCleanUp act = do st <- AIO ask io <- unliftAIO act + -- mask to make sure we keep track of the spawned async liftIO $ uninterruptibleMask $ \restore -> do a <- async $ restore io atomicModifyIORef'_ st (void a :) @@ -284,10 +288,18 @@ withRunInIO k = do k $ RunInIO (\aio -> runReaderT (unAIO aio) st) cleanupAsync :: IORef [Async a] -> IO () +-- mask to make sure we interrupt all the asyncs cleanupAsync ref = uninterruptibleMask_ $ do asyncs <- readIORef ref + -- interrupt all the asyncs without waiting mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs - mapM_ waitCatch asyncs + -- Wait until all the asyncs are done + -- But if it takes more than 10 seconds, log to stderr + let loop unmask = unmask $ forever $ do + threadDelay 10_000_000 + traceM "cleanupAsync: waiting for asyncs to finish" + withAsyncWithUnmask loop $ \_ -> + mapM_ waitCatch asyncs data Wait a = Wait {justWait :: !a} @@ -303,6 +315,7 @@ mapConcurrentlyAIO_ _ [] = pure () mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one mapConcurrentlyAIO_ f many = do ref <- AIO ask + -- mask to make sure we keep track of all the asyncs waits <- liftIO $ uninterruptibleMask $ \restore -> do waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many let asyncs = rights waits From 4db22342140382aa0c4fc8a4d74ab1cb3bb90bca Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 8 Mar 2022 18:20:29 +0000 Subject: [PATCH 02/11] fixup --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6517df2856..4bde233260 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -711,7 +711,7 @@ shakeRestart recorder IdeState{..} reason acts = (,()) <$> newSession recorder shakeExtras shakeDb acts reason) where errorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO () - errorAfter seconds recorder action = flip withAsync (const action) $ forever $ do + errorAfter seconds recorder action = flip withAsync (const action) $ do sleep seconds logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) From f02c5ae9793f06f2f95f8c5ead63699b7e16442a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 8 Mar 2022 18:27:41 +0000 Subject: [PATCH 03/11] use sleep consistently --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index aad613238b..84249fc206 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,7 +8,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NumericUnderscores #-} module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where @@ -33,15 +32,15 @@ import Data.IORef.Extra import Data.Maybe import Data.Traversable (for) import Data.Tuple.Extra +import Debug.Trace (traceM) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types import qualified Focus import qualified ListT import qualified StmContainers.Map as SMap +import System.Time.Extra (duration, sleep) import System.IO.Unsafe -import System.Time.Extra (duration) -import Debug.Trace (traceM) newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do @@ -296,7 +295,7 @@ cleanupAsync ref = uninterruptibleMask_ $ do -- Wait until all the asyncs are done -- But if it takes more than 10 seconds, log to stderr let loop unmask = unmask $ forever $ do - threadDelay 10_000_000 + sleep 10 traceM "cleanupAsync: waiting for asyncs to finish" withAsyncWithUnmask loop $ \_ -> mapM_ waitCatch asyncs From 6019267b94d118f9f5d3741334c4f1a234dfcd0d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 8 Mar 2022 18:34:53 +0000 Subject: [PATCH 04/11] redundant imports --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 84249fc206..b579fc31fb 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -16,7 +16,7 @@ import Control.Concurrent.Extra import Control.Concurrent.STM.Stats (STM, atomically, atomicallyNamed, modifyTVar', newTVarIO, - readTVarIO, registerDelay, check, readTVar, orElse) + readTVarIO) import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO (liftIO)) From 4a6391995c7eddbe63a25afade5d1705b5aee866 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 8 Mar 2022 18:36:15 +0000 Subject: [PATCH 05/11] hlints --- ghcide/src/Development/IDE/Core/Shake.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4bde233260..76d5037200 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -151,7 +151,6 @@ import Development.IDE.Types.Options import Development.IDE.Types.Shake import qualified Focus import GHC.Fingerprint -import GHC.Generics import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS @@ -325,7 +324,7 @@ getVirtualFile nf = do -- Take a snapshot of the current LSP VFS vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS vfsSnapshot Nothing = pure $ VFS mempty "" -vfsSnapshot (Just lspEnv) = LSP.runLspT lspEnv $ LSP.getVirtualFiles +vfsSnapshot (Just lspEnv) = LSP.runLspT lspEnv LSP.getVirtualFiles addIdeGlobal :: IsIdeGlobal a => a -> Rules () @@ -599,7 +598,7 @@ shakeOpen recorder lspEnv defaultConfig logger debouncer dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start - vfs <- atomically . newTVar =<< vfsSnapshot lspEnv + vfs <- newTVarIO =<< vfsSnapshot lspEnv pure ShakeExtras{..} shakeDb <- shakeNewDatabase @@ -1108,7 +1107,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do -- No changes in the dependencies and we have -- an existing successful result. Just (v@(Succeeded _ x), diags) -> do - ver <- estimateFileVersionUnsafely state key (Just x) file + ver <- estimateFileVersionUnsafely key (Just x) file doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags return $ Just $ RunResult ChangedNothing old $ A v _ -> return Nothing @@ -1129,7 +1128,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - ver <- estimateFileVersionUnsafely state key res file + ver <- estimateFileVersionUnsafely key res file (bs, res) <- case res of Nothing -> do pure (toShakeValue ShakeStale bs, staleV) @@ -1155,12 +1154,11 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do estimateFileVersionUnsafely :: forall k v . IdeRule k v - => Values - -> k + => k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion) - estimateFileVersionUnsafely state _k v fp + estimateFileVersionUnsafely _k v fp | fp == emptyFilePath = pure Nothing | Just Refl <- eqT @k @GetModificationTime = pure v -- GetModificationTime depends on these rules, so avoid creating a cycle From 596cd3eb3616d3e954f6556e799ca3d78c28a4db Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 8 Mar 2022 18:44:29 +0000 Subject: [PATCH 06/11] fix 9.2 build --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index b579fc31fb..4da6d05185 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -294,10 +294,10 @@ cleanupAsync ref = uninterruptibleMask_ $ do mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs -- Wait until all the asyncs are done -- But if it takes more than 10 seconds, log to stderr - let loop unmask = unmask $ forever $ do + let loop = forever $ do sleep 10 traceM "cleanupAsync: waiting for asyncs to finish" - withAsyncWithUnmask loop $ \_ -> + withAsyncWithUnmask ($ loop) $ \_ -> mapM_ waitCatch asyncs data Wait a From a5d831684ad2673fc3af9132e498ce68a950a48a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 9 Mar 2022 10:58:23 +0000 Subject: [PATCH 07/11] Fix 9.2 build for real --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 4da6d05185..d85ad69976 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -297,7 +297,7 @@ cleanupAsync ref = uninterruptibleMask_ $ do let loop = forever $ do sleep 10 traceM "cleanupAsync: waiting for asyncs to finish" - withAsyncWithUnmask ($ loop) $ \_ -> + withAsyncWithUnmask (\unmask -> unmask loop) $ \_ -> mapM_ waitCatch asyncs data Wait a From df972e4c7fc98c7ad70cef6ffb57aec5b63e6492 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 9 Mar 2022 22:28:48 +0000 Subject: [PATCH 08/11] remove unnecessary polymorphism --- .../IDE/Graph/Internal/Database.hs | 25 +++++++++---------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index d85ad69976..8171d203fb 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -121,7 +121,7 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do pure (id, val) toForceList <- liftIO $ readTVarIO toForce - let waitAll = run $ mapConcurrentlyAIO_ id toForceList + let waitAll = run $ mapConcurrentlyAIO_ toForceList case toForceList of [] -> return $ Left results _ -> return $ Right $ do @@ -300,23 +300,22 @@ cleanupAsync ref = uninterruptibleMask_ $ do withAsyncWithUnmask (\unmask -> unmask loop) $ \_ -> mapM_ waitCatch asyncs -data Wait a - = Wait {justWait :: !a} - | Spawn {justWait :: !a} - deriving Functor +data Wait + = Wait {justWait :: !(IO ())} + | Spawn {justWait :: !(IO ())} -waitOrSpawn :: Wait (IO a) -> IO (Either (IO a) (Async a)) +waitOrSpawn :: Wait -> IO (Either (IO ()) (Async ())) waitOrSpawn (Wait io) = pure $ Left io -waitOrSpawn (Spawn io) = Right <$> async io +waitOrSpawn (Spawn io) = Right <$> asyncWithUnmask (\unmask -> unmask io) -mapConcurrentlyAIO_ :: (a -> IO ()) -> [Wait a] -> AIO () -mapConcurrentlyAIO_ _ [] = pure () -mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one -mapConcurrentlyAIO_ f many = do +mapConcurrentlyAIO_ :: [Wait] -> AIO () +mapConcurrentlyAIO_ [] = pure () +mapConcurrentlyAIO_ [one] = liftIO $ justWait one +mapConcurrentlyAIO_ many = do ref <- AIO ask -- mask to make sure we keep track of all the asyncs - waits <- liftIO $ uninterruptibleMask $ \restore -> do - waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many + waits <- liftIO $ uninterruptibleMask_ $ do + waits <- liftIO $ traverse waitOrSpawn many let asyncs = rights waits liftIO $ atomicModifyIORef'_ ref (asyncs ++) return waits From 9822e02bebfa55957bb503541569fdc021e81dc0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 10 Mar 2022 09:41:56 +0000 Subject: [PATCH 09/11] Avoid spawning loop async unnecessrily --- .../src/Development/IDE/Graph/Internal/Database.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 8171d203fb..95700fa3bb 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -294,11 +294,12 @@ cleanupAsync ref = uninterruptibleMask_ $ do mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs -- Wait until all the asyncs are done -- But if it takes more than 10 seconds, log to stderr - let loop = forever $ do - sleep 10 - traceM "cleanupAsync: waiting for asyncs to finish" - withAsyncWithUnmask (\unmask -> unmask loop) $ \_ -> - mapM_ waitCatch asyncs + unless (null asyncs) $ do + let loop = forever $ do + sleep 10 + traceM "cleanupAsync: waiting for asyncs to finish" + withAsyncWithUnmask (\unmask -> unmask loop) $ \_ -> + mapM_ waitCatch asyncs data Wait = Wait {justWait :: !(IO ())} From 3754ca6b4246edc8e3ce92cdaf47108fb8c3c733 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 10 Mar 2022 09:42:37 +0000 Subject: [PATCH 10/11] flush asyncs ref --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 95700fa3bb..5e4e87c9a2 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where @@ -289,7 +290,7 @@ withRunInIO k = do cleanupAsync :: IORef [Async a] -> IO () -- mask to make sure we interrupt all the asyncs cleanupAsync ref = uninterruptibleMask_ $ do - asyncs <- readIORef ref + asyncs <- atomicModifyIORef' ref ([],) -- interrupt all the asyncs without waiting mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs -- Wait until all the asyncs are done From b2108d3c5cef5f8dbcbe26cfec222f2a6a034a6e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 10 Mar 2022 20:04:50 +0000 Subject: [PATCH 11/11] Add comments and apply @michaelpj suggestions --- ghcide/src/Development/IDE/Core/Shake.hs | 6 +-- .../IDE/Graph/Internal/Database.hs | 42 ++++++++++++------- 2 files changed, 31 insertions(+), 17 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 76d5037200..05eda3277b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -685,7 +685,7 @@ shakeRestart recorder IdeState{..} reason acts = shakeSession (\runner -> do let log = logWith recorder - (stopTime,()) <- duration $ errorAfter 10 recorder $ cancelShakeSession runner + (stopTime,()) <- duration $ logErrorAfter 10 recorder $ cancelShakeSession runner res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras @@ -709,8 +709,8 @@ shakeRestart recorder IdeState{..} reason acts = (\() -> do (,()) <$> newSession recorder shakeExtras shakeDb acts reason) where - errorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO () - errorAfter seconds recorder action = flip withAsync (const action) $ do + logErrorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO () + logErrorAfter seconds recorder action = flip withAsync (const action) $ do sleep seconds logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 5e4e87c9a2..7853675db1 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -122,7 +122,7 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do pure (id, val) toForceList <- liftIO $ readTVarIO toForce - let waitAll = run $ mapConcurrentlyAIO_ toForceList + let waitAll = run $ waitConcurrently_ toForceList case toForceList of [] -> return $ Left results _ -> return $ Right $ do @@ -172,6 +172,10 @@ compute db@Database{..} stack key mode result = do deps | not(null deps) && runChanged /= ChangedNothing -> do + -- IMPORTANT: record the reverse deps **before** marking the key Clean. + -- If an async exception strikes before the deps have been recorded, + -- we won't be able to accurately propagate dirtiness for this key + -- on the next build. void $ updateReverseDeps key db (getResultDepsDefault [] previousDeps) @@ -227,7 +231,7 @@ updateReverseDeps -> HashSet Key -- ^ Current direct dependencies of Id -> IO () -- mask to ensure that all the reverse dependencies are updated -updateReverseDeps myId db prev new = uninterruptibleMask_ $ do +updateReverseDeps myId db prev new = do forM_ prev $ \d -> unless (d `HSet.member` new) $ doOne (HSet.delete myId) d @@ -255,16 +259,22 @@ transitiveDirtySet database = flip State.execStateT HSet.empty . traverse_ loop next <- lift $ atomically $ getReverseDependencies database x traverse_ loop (maybe mempty HSet.toList next) --- | IO extended to track created asyncs to clean them up when the thread is killed, --- generalizing 'withAsync' +-------------------------------------------------------------------------------- +-- Asynchronous computations with cancellation + +-- | A simple monad to implement cancellation on top of 'Async', +-- generalizing 'withAsync' to monadic scopes. newtype AIO a = AIO { unAIO :: ReaderT (IORef [Async ()]) IO a } deriving newtype (Applicative, Functor, Monad, MonadIO) +-- | Run the monadic computation, cancelling all the spawned asyncs if an exception arises runAIO :: AIO a -> IO a runAIO (AIO act) = do asyncs <- newIORef [] runReaderT act asyncs `onException` cleanupAsync asyncs +-- | Like 'async' but with built-in cancellation. +-- Returns an IO action to wait on the result. asyncWithCleanUp :: AIO a -> AIO (IO a) asyncWithCleanUp act = do st <- AIO ask @@ -289,35 +299,39 @@ withRunInIO k = do cleanupAsync :: IORef [Async a] -> IO () -- mask to make sure we interrupt all the asyncs -cleanupAsync ref = uninterruptibleMask_ $ do +cleanupAsync ref = uninterruptibleMask $ \unmask -> do asyncs <- atomicModifyIORef' ref ([],) -- interrupt all the asyncs without waiting mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs -- Wait until all the asyncs are done -- But if it takes more than 10 seconds, log to stderr unless (null asyncs) $ do - let loop = forever $ do + let warnIfTakingTooLong = unmask $ forever $ do sleep 10 traceM "cleanupAsync: waiting for asyncs to finish" - withAsyncWithUnmask (\unmask -> unmask loop) $ \_ -> + withAsync warnIfTakingTooLong $ \_ -> mapM_ waitCatch asyncs data Wait = Wait {justWait :: !(IO ())} | Spawn {justWait :: !(IO ())} +fmapWait :: (IO () -> IO ()) -> Wait -> Wait +fmapWait f (Wait io) = Wait (f io) +fmapWait f (Spawn io) = Spawn (f io) + waitOrSpawn :: Wait -> IO (Either (IO ()) (Async ())) waitOrSpawn (Wait io) = pure $ Left io -waitOrSpawn (Spawn io) = Right <$> asyncWithUnmask (\unmask -> unmask io) +waitOrSpawn (Spawn io) = Right <$> async io -mapConcurrentlyAIO_ :: [Wait] -> AIO () -mapConcurrentlyAIO_ [] = pure () -mapConcurrentlyAIO_ [one] = liftIO $ justWait one -mapConcurrentlyAIO_ many = do +waitConcurrently_ :: [Wait] -> AIO () +waitConcurrently_ [] = pure () +waitConcurrently_ [one] = liftIO $ justWait one +waitConcurrently_ many = do ref <- AIO ask -- mask to make sure we keep track of all the asyncs - waits <- liftIO $ uninterruptibleMask_ $ do - waits <- liftIO $ traverse waitOrSpawn many + waits <- liftIO $ uninterruptibleMask $ \unmask -> do + waits <- liftIO $ traverse (waitOrSpawn . fmapWait unmask) many let asyncs = rights waits liftIO $ atomicModifyIORef'_ ref (asyncs ++) return waits