From 43c63047d1e2436d7e67c4ea891af5869893fc1d Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Wed, 22 Jul 2026 23:24:39 +0200 Subject: [PATCH 01/10] Close escaped rule computations at scope teardown --- .../IDE/Graph/Internal/Database.hs | 64 +++++++++++++++---- 1 file changed, 50 insertions(+), 14 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 359e5ceb6a..30783ca53a 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -300,18 +300,48 @@ transitiveDirtySet database = flip State.execStateT mempty . traverse_ loop -- 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 } +-- generalizing 'withAsync' to monadic scopes. +-- +-- See Note [Closing escaped rule computations]. +newtype AIO a = AIO { unAIO :: ReaderT (IORef (Maybe [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 [] + asyncs <- newIORef (Just []) runReaderT act asyncs `onException` cleanupAsync asyncs +{- Note [Closing escaped rule computations] + +Rule computations run as asyncs inside a per-'build' AIO scope, which +'cleanupAsync' drains when the scope ends. One kind of async escapes that drain. + + - A memoized 'splitIO' thunk in a 'Running' status can be forced by a later + build. + - That force runs in the original scope that produced the thunk. + - If that scope has already ended, the async it spawns has no parent to cancel + it, so on a restart it escapes the step bump and leaks. See + https://github.com/haskell/haskell-language-server/issues/4985. + +We close the leak at registration rather than teardown. The scope registry is +a 'Maybe'. 'cleanupAsync' sets it to 'Nothing', and 'registerAsyncs' refuses a +closed scope and cancels it, so the thunk can't spawn a surviving thread. +-} + +-- | Register asyncs into a scope, or, if the scope has already closed, cancel +-- them and report failure. See Note [Closing escaped rule computations]. +registerAsyncs :: IORef (Maybe [Async ()]) -> [Async ()] -> IO Bool +registerAsyncs st as = do + registered <- atomicModifyIORef' st $ \case + Nothing -> (Nothing, False) + Just xs -> (Just (as ++ xs), True) + unless registered $ mapM_ uninterruptibleCancel as + pure registered + -- | Like 'async' but with built-in cancellation. -- Returns an IO action to wait on the result. +-- See Note [Closing escaped rule computations]. asyncWithCleanUp :: AIO a -> AIO (IO a) asyncWithCleanUp act = do st <- AIO ask @@ -319,8 +349,8 @@ asyncWithCleanUp act = do -- mask to make sure we keep track of the spawned async liftIO $ uninterruptibleMask $ \restore -> do a <- async $ restore io - atomicModifyIORef'_ st (void a :) - return $ wait a + registered <- registerAsyncs st [void a] + return $ if registered then wait a else throwIO AsyncCancelled unliftAIO :: AIO a -> AIO (IO a) unliftAIO act = do @@ -334,10 +364,12 @@ withRunInIO k = do st <- AIO ask k $ RunInIO (\aio -> runReaderT (unAIO aio) st) -cleanupAsync :: IORef [Async a] -> IO () +cleanupAsync :: IORef (Maybe [Async a]) -> IO () -- mask to make sure we interrupt all the asyncs cleanupAsync ref = uninterruptibleMask $ \unmask -> do - asyncs <- atomicModifyIORef' ref ([],) + -- Close the scope so no later force can register, and take the live asyncs + -- to interrupt. See Note [Closing escaped rule computations]. + asyncs <- atomicModifyIORef' ref $ \m -> (Nothing, fromMaybe [] m) -- interrupt all the asyncs without waiting mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs -- Wait until all the asyncs are done @@ -368,12 +400,16 @@ waitConcurrently_ many = do ref <- AIO ask -- spawn the async computations. -- mask to make sure we keep track of all the asyncs. - (asyncs, syncs) <- liftIO $ uninterruptibleMask $ \unmask -> do + (asyncs, syncs, registered) <- liftIO $ uninterruptibleMask $ \unmask -> do waits <- liftIO $ traverse (waitOrSpawn . fmapWait unmask) many let (syncs, asyncs) = partitionEithers waits - liftIO $ atomicModifyIORef'_ ref (asyncs ++) - return (asyncs, syncs) - -- work on the sync computations - liftIO $ sequence_ syncs - -- wait for the async computations before returning - liftIO $ traverse_ wait asyncs + registered <- liftIO $ registerAsyncs ref asyncs + return (asyncs, syncs, registered) + -- A closed scope means our asyncs were cancelled, so abort the superseded work. + if not registered + then liftIO $ throwIO AsyncCancelled + else do + -- work on the sync computations + liftIO $ sequence_ syncs + -- wait for the async computations before returning + liftIO $ traverse_ wait asyncs From f5d0565858226e254d1896d198ae5629e73bfc08 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Wed, 22 Jul 2026 23:24:39 +0200 Subject: [PATCH 02/10] Add edit flaky stale diagnostic test --- ghcide-test/exe/DiagnosticTests.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/ghcide-test/exe/DiagnosticTests.hs b/ghcide-test/exe/DiagnosticTests.hs index 99f2191f3b..f70c6d58d5 100644 --- a/ghcide-test/exe/DiagnosticTests.hs +++ b/ghcide-test/exe/DiagnosticTests.hs @@ -15,7 +15,8 @@ import Development.IDE.Test (diagnostic, expectDiagnostics, expectDiagnosticsWithTags, expectNoMoreDiagnostics, - flushMessages, waitForAction) + flushMessages, waitForAction, + waitForBuildQueue) import Development.IDE.Types.Location import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -54,6 +55,20 @@ tests = testGroup "diagnostics" } changeDoc doc [change] expectDiagnostics [("Testing.hs", [])] + , testWithDummyPluginEmpty "rapid edits then save does not strand a stale diagnostic" $ do + let v rhs = T.unlines ["module Testing where", "foo :: Int", "foo = " <> rhs] + whole rhs = TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ v rhs + doc <- createDoc "Testing.hs" "haskell" (v "()") + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (2, 6), "Couldn't match expected type 'Int' with actual type '()'", Just "GHC-83865")])] + changeDoc doc [whole "()"] + changeDoc doc [whole "'a'"] + changeDoc doc [whole "True"] + changeDoc doc [whole "0"] + sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams doc Nothing) + waitForBuildQueue + liftIO $ sleep 0.2 + flushMessages + expectCurrentDiagnostics doc [] , testWithDummyPluginEmpty "introduce syntax error" $ do let content = T.unlines [ "module Testing where" ] doc <- createDoc "Testing.hs" "haskell" content From 9f55261e8cb17f16e451586fd8ea0acca0c86024 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Wed, 22 Jul 2026 23:42:07 +0200 Subject: [PATCH 03/10] Test the scope-close registration invariant --- hls-graph/hls-graph.cabal | 1 + .../IDE/Graph/Internal/Database.hs | 4 +++- hls-graph/test/ActionSpec.hs | 22 ++++++++++++++++++- 3 files changed, 25 insertions(+), 2 deletions(-) diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 52bec5beac..52bc142edb 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -129,6 +129,7 @@ test-suite tests -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts build-depends: + , async , base , extra , hls-graph diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 30783ca53a..10957a572c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,7 +8,9 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where +module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, + -- * Exposed for testing. See Note [Closing escaped rule computations]. + registerAsyncs, cleanupAsync) where import Prelude hiding (unzip) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 97ab5555ac..174c41c11c 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -5,13 +5,18 @@ module ActionSpec where import Control.Concurrent (MVar, readMVar) import qualified Control.Concurrent as C +import Control.Concurrent.Async (async, poll) import Control.Concurrent.STM import Control.Monad.IO.Class (MonadIO (..)) +import Data.IORef (newIORef, readIORef) +import Data.Maybe (isJust, isNothing) import Development.IDE.Graph (shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase, shakeRunDatabaseForKeys) -import Development.IDE.Graph.Internal.Database (build, incDatabase) +import Development.IDE.Graph.Internal.Database (build, cleanupAsync, + incDatabase, + registerAsyncs) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule @@ -129,3 +134,18 @@ spec = do res `shouldBe` [[True]] Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb resultDeps res `shouldBe` UnknownDeps + + describe "Closing escaped rule computations" $ do + it "tracks an async registered while the scope is open" $ do + scope <- newIORef (Just []) + a <- async $ C.threadDelay maxBound + registerAsyncs scope [a] `shouldReturn` True + it "refuses to register into a closed scope and cancels the late async" $ do + scope <- newIORef (Just []) + cleanupAsync scope + readIORef scope >>= \m -> isNothing m `shouldBe` True + late <- async $ C.threadDelay maxBound + -- Registration fails rather than leaking the async past teardown. + registerAsyncs scope [late] `shouldReturn` False + -- The refused async was cancelled, not left running. + poll late >>= \res -> isJust res `shouldBe` True From a6aab6f03d8909dc1fa63f4f59189283298178e1 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sat, 25 Jul 2026 17:19:55 +0200 Subject: [PATCH 04/10] Avoid executing the rule at all if the scope is closed --- .../IDE/Graph/Internal/Database.hs | 45 ++++++++++++------- 1 file changed, 30 insertions(+), 15 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 10957a572c..bdace34044 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -318,7 +318,6 @@ runAIO (AIO act) = do Rule computations run as asyncs inside a per-'build' AIO scope, which 'cleanupAsync' drains when the scope ends. One kind of async escapes that drain. - - A memoized 'splitIO' thunk in a 'Running' status can be forced by a later build. - That force runs in the original scope that produced the thunk. @@ -326,13 +325,17 @@ Rule computations run as asyncs inside a per-'build' AIO scope, which it, so on a restart it escapes the step bump and leaks. See https://github.com/haskell/haskell-language-server/issues/4985. -We close the leak at registration rather than teardown. The scope registry is -a 'Maybe'. 'cleanupAsync' sets it to 'Nothing', and 'registerAsyncs' refuses a -closed scope and cancels it, so the thunk can't spawn a surviving thread. +The fix closes the leak at registration rather than teardown, and conditions on it: + - A spawned thread runs its rule computation only after it successfully + registered. Otherwise it does nothing. + - A closed scope refuses registration and cancels the parked thread, so + nothing escapes teardown. -} --- | Register asyncs into a scope, or, if the scope has already closed, cancel --- them and report failure. See Note [Closing escaped rule computations]. +-- | Register threads into a scope, or, if the scope has already closed, cancel +-- them and report failure. +-- +-- See Note [Closing escaped rule computations]. registerAsyncs :: IORef (Maybe [Async ()]) -> [Async ()] -> IO Bool registerAsyncs st as = do registered <- atomicModifyIORef' st $ \case @@ -342,17 +345,29 @@ registerAsyncs st as = do pure registered -- | Like 'async' but with built-in cancellation. --- Returns an IO action to wait on the result. --- See Note [Closing escaped rule computations]. +-- Returns an IO action to wait on the result. +-- +-- See Note [Closing escaped rule computations]. 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 - registered <- registerAsyncs st [void a] - return $ if registered then wait a else throwIO AsyncCancelled + st <- AIO ask + io <- unliftAIO act + let registeredAction registered act = + if registered + then act + else throwIO AsyncCancelled + -- mask so the spawn and registration can't be split by interrupt + liftIO $ uninterruptibleMask_ $ do + -- Use a signal to indicate whether the thread is being spawned into a + -- open/closed scope. + gate <- newEmptyMVar + a <- asyncWithUnmask $ \unmask -> do + registered <- unmask (takeMVar gate) + -- Only if the thread was successfully registered do we execute + registeredAction registered $ unmask io + registered <- registerAsyncs st [void a] + putMVar gate registered + return $ registeredAction registered $ wait a unliftAIO :: AIO a -> AIO (IO a) unliftAIO act = do From a4f79a8fc94b673263d5a6d1299adefa8bfa2a28 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 26 Jul 2026 08:43:15 +0800 Subject: [PATCH 05/10] let the scope handles the throw instead --- .../IDE/Graph/Internal/Database.hs | 39 +++++++++++-------- 1 file changed, 23 insertions(+), 16 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index bdace34044..951b6e77d5 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -341,7 +341,6 @@ registerAsyncs st as = do registered <- atomicModifyIORef' st $ \case Nothing -> (Nothing, False) Just xs -> (Just (as ++ xs), True) - unless registered $ mapM_ uninterruptibleCancel as pure registered -- | Like 'async' but with built-in cancellation. @@ -352,22 +351,28 @@ asyncWithCleanUp :: AIO a -> AIO (IO a) asyncWithCleanUp act = do st <- AIO ask io <- unliftAIO act - let registeredAction registered act = - if registered - then act - else throwIO AsyncCancelled -- mask so the spawn and registration can't be split by interrupt - liftIO $ uninterruptibleMask_ $ do + (registered, a) <- liftIO $ uninterruptibleMask_ $ do -- Use a signal to indicate whether the thread is being spawned into a -- open/closed scope. gate <- newEmptyMVar - a <- asyncWithUnmask $ \unmask -> do - registered <- unmask (takeMVar gate) - -- Only if the thread was successfully registered do we execute - registeredAction registered $ unmask io + a <- runAsyncIfRegistered gate io registered <- registerAsyncs st [void a] putMVar gate registered - return $ registeredAction registered $ wait a + return (registered, a) + return $ if registered + then wait a + -- we don't want to throw an exception here because the async is already running and will be cancelled by the scope, + -- so we just wait for it to finish + else (forever $ sleep 10) + +runAsyncIfRegistered :: MVar Bool -> IO a -> IO (Async a) +runAsyncIfRegistered gate io = + asyncWithUnmask $ \unmask -> unmask $ do + b <- readMVar gate + -- Only if the thread was successfully registered do we execute + if b then io else (error "asyncWithCleanUp: scope closed before thread could be spawned") + unliftAIO :: AIO a -> AIO (IO a) unliftAIO act = do @@ -406,9 +411,9 @@ 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 <$> async io +waitOrSpawn :: MVar Bool -> Wait -> IO (Either (IO ()) (Async ())) +waitOrSpawn _mv (Wait io) = pure $ Left io +waitOrSpawn mv (Spawn io) = Right <$> runAsyncIfRegistered mv io waitConcurrently_ :: [Wait] -> AIO () waitConcurrently_ [] = pure () @@ -418,13 +423,15 @@ waitConcurrently_ many = do -- spawn the async computations. -- mask to make sure we keep track of all the asyncs. (asyncs, syncs, registered) <- liftIO $ uninterruptibleMask $ \unmask -> do - waits <- liftIO $ traverse (waitOrSpawn . fmapWait unmask) many + gate <- newEmptyMVar + waits <- liftIO $ traverse (waitOrSpawn gate. fmapWait unmask) many let (syncs, asyncs) = partitionEithers waits registered <- liftIO $ registerAsyncs ref asyncs + putMVar gate registered return (asyncs, syncs, registered) -- A closed scope means our asyncs were cancelled, so abort the superseded work. if not registered - then liftIO $ throwIO AsyncCancelled + then liftIO $ (forever sleep 10) -- wait for the asyncs to finish, but don't block the main thread else do -- work on the sync computations liftIO $ sequence_ syncs From 41668faf9fa4081e475930a37bd2a50f84183190 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 26 Jul 2026 08:59:38 +0800 Subject: [PATCH 06/10] fix hlg-graph tests --- .../src/Development/IDE/Graph/Internal/Database.hs | 2 +- hls-graph/test/ActionSpec.hs | 13 +++++++++---- 2 files changed, 10 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 951b6e77d5..ddd5658311 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -10,7 +10,7 @@ module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, -- * Exposed for testing. See Note [Closing escaped rule computations]. - registerAsyncs, cleanupAsync) where + registerAsyncs, cleanupAsync, runAsyncIfRegistered) where import Prelude hiding (unzip) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 174c41c11c..f099b04599 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -3,7 +3,8 @@ module ActionSpec where -import Control.Concurrent (MVar, readMVar) +import Control.Concurrent (MVar, newEmptyMVar, + readMVar) import qualified Control.Concurrent as C import Control.Concurrent.Async (async, poll) import Control.Concurrent.STM @@ -16,7 +17,8 @@ import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabaseForKeys) import Development.IDE.Graph.Internal.Database (build, cleanupAsync, incDatabase, - registerAsyncs) + registerAsyncs, + runAsyncIfRegistered) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule @@ -138,8 +140,11 @@ spec = do describe "Closing escaped rule computations" $ do it "tracks an async registered while the scope is open" $ do scope <- newIORef (Just []) - a <- async $ C.threadDelay maxBound + gate <- newEmptyMVar + a <- runAsyncIfRegistered gate $ do C.threadDelay maxBound registerAsyncs scope [a] `shouldReturn` True + -- should still running + poll a >>= \res -> isJust res `shouldBe` False it "refuses to register into a closed scope and cancels the late async" $ do scope <- newIORef (Just []) cleanupAsync scope @@ -148,4 +153,4 @@ spec = do -- Registration fails rather than leaking the async past teardown. registerAsyncs scope [late] `shouldReturn` False -- The refused async was cancelled, not left running. - poll late >>= \res -> isJust res `shouldBe` True + poll late >>= \res -> isJust res `shouldBe` False From 77050e93b594ca9aad769188661a30f8a1d266bc Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sun, 26 Jul 2026 18:21:05 +0200 Subject: [PATCH 07/10] Abort superseded rule spawns instead of blocking --- .../IDE/Graph/Internal/Database.hs | 40 +++++++------------ hls-graph/test/ActionSpec.hs | 6 ++- 2 files changed, 19 insertions(+), 27 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index ddd5658311..957a53facb 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -341,6 +341,7 @@ registerAsyncs st as = do registered <- atomicModifyIORef' st $ \case Nothing -> (Nothing, False) Just xs -> (Just (as ++ xs), True) + unless registered $ mapM_ uninterruptibleCancel as pure registered -- | Like 'async' but with built-in cancellation. @@ -360,19 +361,15 @@ asyncWithCleanUp act = do registered <- registerAsyncs st [void a] putMVar gate registered return (registered, a) - return $ if registered - then wait a - -- we don't want to throw an exception here because the async is already running and will be cancelled by the scope, - -- so we just wait for it to finish - else (forever $ sleep 10) + -- A closed scope means the async was refused and cancelled, abort. + return $ if registered then wait a else throwIO AsyncCancelled runAsyncIfRegistered :: MVar Bool -> IO a -> IO (Async a) runAsyncIfRegistered gate io = - asyncWithUnmask $ \unmask -> unmask $ do - b <- readMVar gate - -- Only if the thread was successfully registered do we execute - if b then io else (error "asyncWithCleanUp: scope closed before thread could be spawned") - + asyncWithUnmask $ \unmask -> unmask $ do + registered <- readMVar gate + -- Only if the thread was successfully registered do we run the computation. + if registered then io else throwIO AsyncCancelled unliftAIO :: AIO a -> AIO (IO a) unliftAIO act = do @@ -392,25 +389,19 @@ cleanupAsync ref = uninterruptibleMask $ \unmask -> do -- Close the scope so no later force can register, and take the live asyncs -- to interrupt. See Note [Closing escaped rule computations]. asyncs <- atomicModifyIORef' ref $ \m -> (Nothing, fromMaybe [] m) - -- 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 + -- Cancel the asyncs concurrently. If teardown takes over 10 seconds, log + -- to stderr. unless (null asyncs) $ do let warnIfTakingTooLong = unmask $ forever $ do sleep 10 traceM "cleanupAsync: waiting for asyncs to finish" withAsync warnIfTakingTooLong $ \_ -> - mapM_ waitCatch asyncs + mapConcurrently_ cancel 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 :: MVar Bool -> Wait -> IO (Either (IO ()) (Async ())) waitOrSpawn _mv (Wait io) = pure $ Left io waitOrSpawn mv (Spawn io) = Right <$> runAsyncIfRegistered mv io @@ -420,18 +411,17 @@ waitConcurrently_ [] = pure () waitConcurrently_ [one] = liftIO $ justWait one waitConcurrently_ many = do ref <- AIO ask - -- spawn the async computations. - -- mask to make sure we keep track of all the asyncs. - (asyncs, syncs, registered) <- liftIO $ uninterruptibleMask $ \unmask -> do + -- Mask so spawn + register stay atomic. + (asyncs, syncs, registered) <- liftIO $ uninterruptibleMask_ $ do gate <- newEmptyMVar - waits <- liftIO $ traverse (waitOrSpawn gate. fmapWait unmask) many + waits <- liftIO $ traverse (waitOrSpawn gate) many let (syncs, asyncs) = partitionEithers waits registered <- liftIO $ registerAsyncs ref asyncs putMVar gate registered return (asyncs, syncs, registered) - -- A closed scope means our asyncs were cancelled, so abort the superseded work. + -- A closed scope means our threads were cancelled, so abort. if not registered - then liftIO $ (forever sleep 10) -- wait for the asyncs to finish, but don't block the main thread + then liftIO $ throwIO AsyncCancelled else do -- work on the sync computations liftIO $ sequence_ syncs diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index f099b04599..06272ce385 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -143,7 +143,9 @@ spec = do gate <- newEmptyMVar a <- runAsyncIfRegistered gate $ do C.threadDelay maxBound registerAsyncs scope [a] `shouldReturn` True - -- should still running + -- Confirm registration so the parked thread proceeds to its computation. + C.putMVar gate True + -- The registered async runs and stays alive. poll a >>= \res -> isJust res `shouldBe` False it "refuses to register into a closed scope and cancels the late async" $ do scope <- newIORef (Just []) @@ -153,4 +155,4 @@ spec = do -- Registration fails rather than leaking the async past teardown. registerAsyncs scope [late] `shouldReturn` False -- The refused async was cancelled, not left running. - poll late >>= \res -> isJust res `shouldBe` False + poll late >>= \res -> isJust res `shouldBe` True From 5a250886c216471bd401bf2ce70f74512953f4d1 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sat, 8 Aug 2026 23:40:14 +0200 Subject: [PATCH 08/10] Refuse rule spawns into a closed AIO scope --- .../Development/IDE/Graph/Internal/Action.hs | 2 + .../IDE/Graph/Internal/Database.hs | 230 +++++++++++------- .../Development/IDE/Graph/Internal/Types.hs | 10 + hls-graph/test/ActionSpec.hs | 62 +++-- hls-graph/test/Example.hs | 17 ++ 5 files changed, 204 insertions(+), 117 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 6d47d9b511..e4b5c907a6 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -84,6 +84,8 @@ isAsyncException e | Just (_ :: AsyncCancelled) <- fromException e = True | Just (_ :: AsyncException) <- fromException e = True | Just (_ :: ExitCode) <- fromException e = True + -- See Note [Closing escaped rule computations]. + | Just (_ :: ScopeClosed) <- fromException e = True | otherwise = False diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 957a53facb..f779ebbfa7 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,9 +8,20 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, - -- * Exposed for testing. See Note [Closing escaped rule computations]. - registerAsyncs, cleanupAsync, runAsyncIfRegistered) where +module Development.IDE.Graph.Internal.Database + ( compute + , newDatabase + , incDatabase + , build + , getDirtySet + , getKeysAndVisitAge + -- * Exposed for testing + , Scope + , newScope + , scopeSize + , spawnInScope + , cleanupAsync + ) where import Prelude hiding (unzip) @@ -90,14 +101,17 @@ build => Database -> Stack -> f key -> IO (f Key, f value) -- build _ st k | traceShow ("build", st, k) False = undefined build db stack keys = do - built <- runAIO $ do - built <- builder db stack (fmap newKey keys) - case built of - Left clean -> return clean - Right dirty -> liftIO dirty + -- 'repairRefusal' demoted the key before the refusal escaped, so the retry + -- recomputes it in a live scope. See Note [Closing escaped rule computations]. + built <- attempt `catch` \ScopeClosed -> attempt let (ids, vs) = unzip built pure (ids, fmap (asV . resultValue) vs) where + attempt = runAIO $ do + built <- builder db stack (fmap newKey keys) + case built of + Left clean -> return clean + Right dirty -> liftIO dirty asV :: Value -> value asV (Value x) = unwrapDynamic x @@ -126,7 +140,7 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do pure val Dirty s -> do let act = run (refresh db stack id s) - (force, val) = splitIO (join act) + (force, val) = splitIO (repairRefusal db current id (join act)) SMap.focus (updateStatus $ Running current force val s) id databaseValues modifyTVar' toForce (Spawn force:) pure val @@ -229,6 +243,27 @@ updateStatus res = Focus.alter (Just . maybe (KeyDetails res mempty) (\it -> it{keyStatus = res})) +-- | Drop a refused key's 'Running' status before rethrowing, so its next build +-- recomputes it in a live scope. Refusing the spawn stops the thread leaking. +-- The entry it leaves behind is bound to the dead scope, so every later force +-- in this step refuses too. +-- +-- See Note [Closing escaped rule computations]. +repairRefusal :: Database -> Step -> Key -> IO a -> IO a +repairRefusal db step key act = act `catch` \e@ScopeClosed -> + -- Masking stops a second exception from skipping the repair and leaving the + -- poisoned entry installed. + mask_ $ do + -- By the time the repair runs, 'compute' may have written 'Clean' or a + -- newer step may have taken the key over. + let demote = Focus.adjust $ \it -> case keyStatus it of + Running s _ _ prev | s == step -> it{keyStatus = Dirty prev} + _ -> it + + atomicallyNamed "builder repair refused" $ + SMap.focus demote key (databaseValues db) + throwIO e + -- | Returns the set of dirty keys annotated with their age (in # of builds) getDirtySet :: Database -> IO [(Key, Int)] getDirtySet db = do @@ -305,44 +340,77 @@ transitiveDirtySet database = flip State.execStateT mempty . traverse_ loop -- generalizing 'withAsync' to monadic scopes. -- -- See Note [Closing escaped rule computations]. -newtype AIO a = AIO { unAIO :: ReaderT (IORef (Maybe [Async ()])) IO a } +newtype AIO a = AIO { unAIO :: ReaderT Scope IO a } deriving newtype (Applicative, Functor, Monad, MonadIO) +-- | The threads a scope owns, or 'Nothing' once it has closed. +-- See Note [Closing escaped rule computations]. +data Scope = Scope + { scopeClosing :: !(IORef Bool) + , scopeAsyncs :: !(MVar (Maybe [Async ()])) + } + +newScope :: IO Scope +newScope = Scope <$> newIORef False <*> newMVar (Just []) + +-- | How many asyncs the scope owns, or 'Nothing' if it has closed. +scopeSize :: Scope -> IO (Maybe Int) +scopeSize = fmap (fmap length) . readMVar . scopeAsyncs + -- | Run the monadic computation, cancelling all the spawned asyncs if an exception arises runAIO :: AIO a -> IO a runAIO (AIO act) = do - asyncs <- newIORef (Just []) - runReaderT act asyncs `onException` cleanupAsync asyncs + scope <- newScope + -- Close on every exit, so no later force can spawn into a scope that ended. + -- Cancel only on an exception, since a normal return has already waited on + -- everything it spawned. + (runReaderT act scope `onException` cleanupAsync scope) + `finally` void (closeScope scope) {- Note [Closing escaped rule computations] -Rule computations run as asyncs inside a per-'build' AIO scope, which -'cleanupAsync' drains when the scope ends. One kind of async escapes that drain. - - A memoized 'splitIO' thunk in a 'Running' status can be forced by a later - build. - - That force runs in the original scope that produced the thunk. - - If that scope has already ended, the async it spawns has no parent to cancel - it, so on a restart it escapes the step bump and leaks. See - https://github.com/haskell/haskell-language-server/issues/4985. - -The fix closes the leak at registration rather than teardown, and conditions on it: - - A spawned thread runs its rule computation only after it successfully - registered. Otherwise it does nothing. - - A closed scope refuses registration and cancels the parked thread, so - nothing escapes teardown. +A 'Running' status memoizes a 'splitIO' thunk bound to the AIO scope that +created it. Forcing that thunk after its scope has ended spawns an async with no +parent to cancel it, so on a restart it escapes the step bump and leaks. + + See https://github.com/haskell/haskell-language-server/issues/4985. + +How the thunk outlives its scope, all at one step S: + 1. A build opens scope-1 and installs 'Running S' for the key. + 2. That build throws before forcing the thunk, so scope-1 spawned nothing for + the key and its teardown finds nothing to cancel. The 'Running S' entry + survives. + 3. A second build at step S opens scope-2, sees that entry, waits on the + thunk, and forces it on scope-2's thread. + +'spawnInScope' decides whether to spawn while holding the scope open, +so a refused computation is never started and the forcing thread raises +'ScopeClosed'. + * 'repairRefusal' demotes the key to 'Dirty' before re-throwing. + * 'build' retries once, so the demoted key recomputes in a live scope. + * 'isAsyncException' classes it async, so it isn't swallowed. -} --- | Register threads into a scope, or, if the scope has already closed, cancel --- them and report failure. +-- | Spawn one async into the scope, or refuse if the scope has closed. +-- +-- The wait is returned rather than run, so the lock is free before anyone +-- blocks on a result. -- -- See Note [Closing escaped rule computations]. -registerAsyncs :: IORef (Maybe [Async ()]) -> [Async ()] -> IO Bool -registerAsyncs st as = do - registered <- atomicModifyIORef' st $ \case - Nothing -> (Nothing, False) - Just xs -> (Just (as ++ xs), True) - unless registered $ mapM_ uninterruptibleCancel as - pure registered +spawnInScope :: Scope -> IO a -> IO (IO a) +spawnInScope Scope{scopeClosing, scopeAsyncs} io = + mask_ $ modifyMVar scopeAsyncs $ \case + Nothing -> pure (Nothing, refuse) + Just as -> do + closing <- readIORef scopeClosing + if closing + -- Teardown is on its way and will take this list. + then pure (Just as, refuse) + else do + a <- asyncWithUnmask $ \unmask -> unmask io + pure (Just (void a : as), wait a) + where + refuse = throwIO ScopeClosed -- | Like 'async' but with built-in cancellation. -- Returns an IO action to wait on the result. @@ -350,26 +418,9 @@ registerAsyncs st as = do -- See Note [Closing escaped rule computations]. asyncWithCleanUp :: AIO a -> AIO (IO a) asyncWithCleanUp act = do - st <- AIO ask - io <- unliftAIO act - -- mask so the spawn and registration can't be split by interrupt - (registered, a) <- liftIO $ uninterruptibleMask_ $ do - -- Use a signal to indicate whether the thread is being spawned into a - -- open/closed scope. - gate <- newEmptyMVar - a <- runAsyncIfRegistered gate io - registered <- registerAsyncs st [void a] - putMVar gate registered - return (registered, a) - -- A closed scope means the async was refused and cancelled, abort. - return $ if registered then wait a else throwIO AsyncCancelled - -runAsyncIfRegistered :: MVar Bool -> IO a -> IO (Async a) -runAsyncIfRegistered gate io = - asyncWithUnmask $ \unmask -> unmask $ do - registered <- readMVar gate - -- Only if the thread was successfully registered do we run the computation. - if registered then io else throwIO AsyncCancelled + scope <- AIO ask + io <- unliftAIO act + liftIO $ spawnInScope scope io unliftAIO :: AIO a -> AIO (IO a) unliftAIO act = do @@ -383,47 +434,42 @@ withRunInIO k = do st <- AIO ask k $ RunInIO (\aio -> runReaderT (unAIO aio) st) -cleanupAsync :: IORef (Maybe [Async a]) -> IO () +-- | Close the scope so no later force can spawn into it, handing back whatever +-- asyncs it still owns. +closeScope :: Scope -> IO [Async ()] +closeScope Scope{scopeClosing, scopeAsyncs} = do + writeIORef scopeClosing True + mask_ $ modifyMVar scopeAsyncs $ \m -> pure (Nothing, fromMaybe [] m) + +cleanupAsync :: Scope -> IO () -- mask to make sure we interrupt all the asyncs -cleanupAsync ref = uninterruptibleMask $ \unmask -> do - -- Close the scope so no later force can register, and take the live asyncs - -- to interrupt. See Note [Closing escaped rule computations]. - asyncs <- atomicModifyIORef' ref $ \m -> (Nothing, fromMaybe [] m) - -- Cancel the asyncs concurrently. If teardown takes over 10 seconds, log - -- to stderr. - unless (null asyncs) $ do - let warnIfTakingTooLong = unmask $ forever $ do - sleep 10 - traceM "cleanupAsync: waiting for asyncs to finish" - withAsync warnIfTakingTooLong $ \_ -> - mapConcurrently_ cancel asyncs +cleanupAsync scope = uninterruptibleMask $ \unmask -> do + let warnIfTakingTooLong = unmask $ forever $ do + sleep 10 + traceM "cleanupAsync: waiting for asyncs to finish" + -- Armed before the close so a stall taking the lock is reported too. + withAsync warnIfTakingTooLong $ \_ -> do + asyncs <- closeScope scope + mapConcurrently_ cancel asyncs data Wait - = Wait {justWait :: !(IO ())} - | Spawn {justWait :: !(IO ())} + = Wait !(IO ()) + | Spawn !(IO ()) -waitOrSpawn :: MVar Bool -> Wait -> IO (Either (IO ()) (Async ())) -waitOrSpawn _mv (Wait io) = pure $ Left io -waitOrSpawn mv (Spawn io) = Right <$> runAsyncIfRegistered mv io +partitionWaits :: [Wait] -> ([IO ()], [IO ()]) +partitionWaits = partitionEithers . map toEither + where + toEither (Wait io) = Left io + toEither (Spawn io) = Right io waitConcurrently_ :: [Wait] -> AIO () waitConcurrently_ [] = pure () -waitConcurrently_ [one] = liftIO $ justWait one -waitConcurrently_ many = do - ref <- AIO ask - -- Mask so spawn + register stay atomic. - (asyncs, syncs, registered) <- liftIO $ uninterruptibleMask_ $ do - gate <- newEmptyMVar - waits <- liftIO $ traverse (waitOrSpawn gate) many - let (syncs, asyncs) = partitionEithers waits - registered <- liftIO $ registerAsyncs ref asyncs - putMVar gate registered - return (asyncs, syncs, registered) - -- A closed scope means our threads were cancelled, so abort. - if not registered - then liftIO $ throwIO AsyncCancelled - else do - -- work on the sync computations - liftIO $ sequence_ syncs - -- wait for the async computations before returning - liftIO $ traverse_ wait asyncs +waitConcurrently_ waits = do + scope <- AIO ask + let (syncs, spawns) = partitionWaits waits + waitAll <- liftIO $ case spawns of + [] -> pure $ pure () + [s] -> spawnInScope scope s + ss -> spawnInScope scope (mapConcurrently_ id ss) + liftIO $ sequence_ syncs + liftIO waitAll diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 34bed42391..b449718370 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -256,6 +256,16 @@ instance Exception StackException where toException this@(StackException (Stack stack _)) = toException $ GraphException (show$ last stack) (map show stack) this +-- | A rule computation was asked to start in a scope that had already closed. +-- Distinct from 'AsyncCancelled' so 'build' can retry a refusal in a fresh +-- scope instead of unwinding. +-- +-- See Note [Closing escaped rule computations]. +data ScopeClosed = ScopeClosed + deriving stock (Show) + +instance Exception ScopeClosed + addStack :: Key -> Stack -> Either StackException Stack addStack k (Stack ks is) | k `memberKeySet` is = Left $ StackException stack2 diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 06272ce385..2673265893 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -3,22 +3,21 @@ module ActionSpec where -import Control.Concurrent (MVar, newEmptyMVar, - readMVar) +import Control.Concurrent (MVar, readMVar) import qualified Control.Concurrent as C -import Control.Concurrent.Async (async, poll) +import Control.Concurrent.Async (AsyncCancelled (..)) import Control.Concurrent.STM import Control.Monad.IO.Class (MonadIO (..)) -import Data.IORef (newIORef, readIORef) -import Data.Maybe (isJust, isNothing) +import Data.IORef (newIORef, readIORef, + writeIORef) import Development.IDE.Graph (shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase, shakeRunDatabaseForKeys) import Development.IDE.Graph.Internal.Database (build, cleanupAsync, - incDatabase, - registerAsyncs, - runAsyncIfRegistered) + incDatabase, newScope, + scopeSize, + spawnInScope) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule @@ -138,21 +137,34 @@ spec = do resultDeps res `shouldBe` UnknownDeps describe "Closing escaped rule computations" $ do - it "tracks an async registered while the scope is open" $ do - scope <- newIORef (Just []) - gate <- newEmptyMVar - a <- runAsyncIfRegistered gate $ do C.threadDelay maxBound - registerAsyncs scope [a] `shouldReturn` True - -- Confirm registration so the parked thread proceeds to its computation. - C.putMVar gate True - -- The registered async runs and stays alive. - poll a >>= \res -> isJust res `shouldBe` False - it "refuses to register into a closed scope and cancels the late async" $ do - scope <- newIORef (Just []) + it "runs a spawned body and cancels it at teardown" $ do + scope <- newScope + started <- C.newEmptyMVar + waitForIt <- spawnInScope scope $ do + C.putMVar started () + C.threadDelay maxBound + scopeSize scope `shouldReturn` Just 1 + -- The signal only arrives if the body really started running. + C.takeMVar started cleanupAsync scope - readIORef scope >>= \m -> isNothing m `shouldBe` True - late <- async $ C.threadDelay maxBound - -- Registration fails rather than leaking the async past teardown. - registerAsyncs scope [late] `shouldReturn` False - -- The refused async was cancelled, not left running. - poll late >>= \res -> isJust res `shouldBe` True + scopeSize scope `shouldReturn` Nothing + waitForIt `shouldThrow` \(_ :: AsyncCancelled) -> True + it "spawns nothing into a closed scope" $ do + scope <- newScope + cleanupAsync scope + ran <- newIORef False + waitForIt <- spawnInScope scope $ writeIORef ran True + -- Still closed, so nothing was added behind teardown's back. + scopeSize scope `shouldReturn` Nothing + -- Nobody gets a result, and the body never ran. + waitForIt `shouldThrow` \ScopeClosed -> True + readIORef ran `shouldReturn` False + it "recomputes a key whose scope died before forcing it" $ do + (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions ruleCycleAfterVictim + -- The cycle tears down the inner scope while 'CycleRule 1' sits 'Running' + -- with a thunk that scope never forced. + build theDb emptyStack [CycleRule 0] `shouldThrow` \StackException{} -> True + -- Same step, so the stale entry is still visible and gets waited on rather + -- than respawned. + res <- build theDb emptyStack [CycleRule 1] + snd res `shouldBe` [1 :: Int] diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index c20ea79328..fc64279e90 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -5,6 +5,7 @@ module Example where import qualified Control.Concurrent as C +import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Development.IDE.Graph import Development.IDE.Graph.Classes @@ -72,3 +73,19 @@ ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do data CountRule = CountRule deriving (Eq, Generic, Hashable, NFData, Show) type instance RuleResult CountRule = Int + +data CycleRule = CycleRule Int + deriving (Eq, Generic, Hashable, NFData, Show) +type instance RuleResult CycleRule = Int + +-- | A rule where @CycleRule 0@ closes a cycle on itself, after @CycleRule 1@ has +-- already been listed in the same batch. +-- +-- 'builder' runs one transaction per key, so 1 is left 'Running' with a thunk its +-- scope never forced once 0 hits the stack and throws. +ruleCycleAfterVictim :: Rules () +ruleCycleAfterVictim = addRule $ \(CycleRule n) _old _mode -> do + when (n == 0) $ do + _ :: [Int] <- apply [CycleRule 1, CycleRule 0] + pure () + return $ RunResult ChangedRecomputeDiff "" n (return ()) From f837aeb3132821e1dd8e9d15d73faa22556bf5cc Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 10 Aug 2026 18:58:17 +0200 Subject: [PATCH 09/10] Avoid spawning threads when waiting on a single action --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index f779ebbfa7..5f9dd54f4a 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -462,8 +462,13 @@ partitionWaits = partitionEithers . map toEither toEither (Wait io) = Left io toEither (Spawn io) = Right io +justWait :: Wait -> IO () +justWait (Wait io) = io +justWait (Spawn io) = io + waitConcurrently_ :: [Wait] -> AIO () waitConcurrently_ [] = pure () +waitConcurrently_ [one] = liftIO $ justWait one -- Avoid spawning when only a single action waitConcurrently_ waits = do scope <- AIO ask let (syncs, spawns) = partitionWaits waits From f6d79a7c63fd4f5b547ecf3cd378d4436017f1d0 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Wed, 12 Aug 2026 18:31:24 +0200 Subject: [PATCH 10/10] Cancel rule threads at every scope teardown --- .../IDE/Graph/Internal/Database.hs | 64 ++++++++----------- 1 file changed, 26 insertions(+), 38 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 5f9dd54f4a..344ba2de19 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -345,27 +345,24 @@ newtype AIO a = AIO { unAIO :: ReaderT Scope IO a } -- | The threads a scope owns, or 'Nothing' once it has closed. -- See Note [Closing escaped rule computations]. -data Scope = Scope - { scopeClosing :: !(IORef Bool) - , scopeAsyncs :: !(MVar (Maybe [Async ()])) +newtype Scope = Scope + { scopeAsyncs :: MVar (Maybe [Async ()]) } newScope :: IO Scope -newScope = Scope <$> newIORef False <*> newMVar (Just []) +newScope = Scope <$> newMVar (Just []) -- | How many asyncs the scope owns, or 'Nothing' if it has closed. scopeSize :: Scope -> IO (Maybe Int) scopeSize = fmap (fmap length) . readMVar . scopeAsyncs --- | Run the monadic computation, cancelling all the spawned asyncs if an exception arises +-- | Run the monadic computation, cancelling whatever it leaves spawned at exit. runAIO :: AIO a -> IO a runAIO (AIO act) = do scope <- newScope - -- Close on every exit, so no later force can spawn into a scope that ended. - -- Cancel only on an exception, since a normal return has already waited on - -- everything it spawned. - (runReaderT act scope `onException` cleanupAsync scope) - `finally` void (closeScope scope) + -- A normal return has already waited on what it spawned, so anything left + -- escaped. See Note [Closing escaped rule computations]. + runReaderT act scope `finally` cleanupAsync scope {- Note [Closing escaped rule computations] @@ -375,7 +372,7 @@ parent to cancel it, so on a restart it escapes the step bump and leaks. See https://github.com/haskell/haskell-language-server/issues/4985. -How the thunk outlives its scope, all at one step S: +Example trace of a thunk escaping scope, all at one step S: 1. A build opens scope-1 and installs 'Running S' for the key. 2. That build throws before forcing the thunk, so scope-1 spawned nothing for the key and its teardown finds nothing to cancel. The 'Running S' entry @@ -383,34 +380,25 @@ How the thunk outlives its scope, all at one step S: 3. A second build at step S opens scope-2, sees that entry, waits on the thunk, and forces it on scope-2's thread. -'spawnInScope' decides whether to spawn while holding the scope open, -so a refused computation is never started and the forcing thread raises -'ScopeClosed'. +'scopeAsyncs' serialises spawning against teardown: + * Spawn wins the lock, it'll be registered and teardown cancels it. + * Teardown wins, so nothing starts and the thread raises 'ScopeClosed'. + +A refusal unwinds and retries: * 'repairRefusal' demotes the key to 'Dirty' before re-throwing. * 'build' retries once, so the demoted key recomputes in a live scope. * 'isAsyncException' classes it async, so it isn't swallowed. -} -- | Spawn one async into the scope, or refuse if the scope has closed. --- --- The wait is returned rather than run, so the lock is free before anyone --- blocks on a result. --- -- See Note [Closing escaped rule computations]. spawnInScope :: Scope -> IO a -> IO (IO a) -spawnInScope Scope{scopeClosing, scopeAsyncs} io = +spawnInScope Scope{scopeAsyncs} io = mask_ $ modifyMVar scopeAsyncs $ \case - Nothing -> pure (Nothing, refuse) + Nothing -> pure (Nothing, throwIO ScopeClosed) Just as -> do - closing <- readIORef scopeClosing - if closing - -- Teardown is on its way and will take this list. - then pure (Just as, refuse) - else do - a <- asyncWithUnmask $ \unmask -> unmask io - pure (Just (void a : as), wait a) - where - refuse = throwIO ScopeClosed + a <- asyncWithUnmask $ \unmask -> unmask io + pure (Just (void a : as), wait a) -- | Like 'async' but with built-in cancellation. -- Returns an IO action to wait on the result. @@ -437,20 +425,20 @@ withRunInIO k = do -- | Close the scope so no later force can spawn into it, handing back whatever -- asyncs it still owns. closeScope :: Scope -> IO [Async ()] -closeScope Scope{scopeClosing, scopeAsyncs} = do - writeIORef scopeClosing True +closeScope Scope{scopeAsyncs} = mask_ $ modifyMVar scopeAsyncs $ \m -> pure (Nothing, fromMaybe [] m) cleanupAsync :: Scope -> IO () -- mask to make sure we interrupt all the asyncs cleanupAsync scope = uninterruptibleMask $ \unmask -> do - let warnIfTakingTooLong = unmask $ forever $ do - sleep 10 - traceM "cleanupAsync: waiting for asyncs to finish" - -- Armed before the close so a stall taking the lock is reported too. - withAsync warnIfTakingTooLong $ \_ -> do - asyncs <- closeScope scope - mapConcurrently_ cancel asyncs + asyncs <- closeScope scope + -- Every scope tears down through here, so keep the empty case free. + unless (null asyncs) $ do + let warnIfTakingTooLong = unmask $ forever $ do + sleep 10 + traceM "cleanupAsync: waiting for asyncs to finish" + withAsync warnIfTakingTooLong $ \_ -> + mapConcurrently_ cancel asyncs data Wait = Wait !(IO ())