From 9580a862ba46e944800b62bab003726ceb51aff4 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Wed, 22 Jul 2026 23:24:39 +0200 Subject: [PATCH 01/12] 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 3f7ca8f8b27e68b2469332ebbd9cf60fcc10635e Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Wed, 22 Jul 2026 23:24:39 +0200 Subject: [PATCH 02/12] 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 5a61b1937f57679b65919bdb46b825cb3edba87c Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Wed, 22 Jul 2026 23:42:07 +0200 Subject: [PATCH 03/12] 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 755387eaf5bf74ad4c4449cd705e68d24f9fd54a Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sat, 25 Jul 2026 17:19:55 +0200 Subject: [PATCH 04/12] 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 99bbf04d636a73b10227f25e218509173eed779f Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 26 Jul 2026 08:43:15 +0800 Subject: [PATCH 05/12] 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 d181bdee252617d94de8af59685ded43cd6e47d9 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 26 Jul 2026 08:59:38 +0800 Subject: [PATCH 06/12] 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 ea8a975dda8eaf2e08054a5b232db89884092d89 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sun, 26 Jul 2026 18:21:05 +0200 Subject: [PATCH 07/12] 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 357d0644f0955c71c2855857a42ad5e4910fad04 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 8 Aug 2026 18:19:19 +0800 Subject: [PATCH 08/12] Make AIO scope rejection single-owner --- .../IDE/Graph/Internal/Database.hs | 80 ++++++++++++------- hls-graph/test/ActionSpec.hs | 46 ++++++++--- 2 files changed, 85 insertions(+), 41 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 957a53facb..82a42e0447 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, runAsyncIfRegistered) where + registerAsyncs, cleanupAsync, runAsyncIfRegistered, waitForRegisteredAsync) where import Prelude hiding (unzip) @@ -317,32 +317,35 @@ runAIO (AIO act) = do {- 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. +'cleanupAsync' drains when the scope is cancelled. A force-runner may be spawned +while that scope is open but still be parked before registration when cleanup +closes the scope. Without an admission gate, that runner can execute a memoized +'splitIO' force after cleanup has already drained the registry. Once the build +step advances, 'viewDirty' prevents a new build from deliberately selecting the +old 'Running' force; the race is with a runner that was already spawned. + +The admission protocol gives every thread exactly one owner: + - A registered thread may execute its force or rule body, and is cancelled by + 'cleanupAsync'. + - A refused thread observes the closed admission, skips its body, and finishes + normally. It is never registered, so cleanup does not cancel it. + - A registered parent that observes a refused child waits at an interruptible + point for cleanup to cancel it. It does not cancel itself or the child. + +This prevents either a force or rule body from escaping teardown. See +https://github.com/haskell/haskell-language-server/issues/4985. -} --- | Register threads into a scope, or, if the scope has already closed, cancel --- them and report failure. +-- | Register threads into a scope and report whether they were admitted. +-- Refused threads are not owned by the scope; their admission gates must be +-- released with 'False' so they can finish without executing their bodies. -- -- See Note [Closing escaped rule computations]. registerAsyncs :: IORef (Maybe [Async ()]) -> [Async ()] -> IO Bool -registerAsyncs st as = do - registered <- atomicModifyIORef' st $ \case +registerAsyncs st as = + 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. @@ -353,23 +356,37 @@ 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 + 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 + return a + return $ waitForRegisteredAsync a -runAsyncIfRegistered :: MVar Bool -> IO a -> IO (Async a) +-- | Spawn a parked thread. An admitted thread runs the body and returns its +-- result in 'Just'; a refused thread skips the body and finishes with 'Nothing'. +runAsyncIfRegistered :: MVar Bool -> IO a -> IO (Async (Maybe 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 + if registered then Just <$> io else pure Nothing + +-- | Wait for a child's admission result. A refused child has finished without +-- doing work, while its already-admitted parent remains owned by cleanup and +-- must wait for that external cancellation rather than cancelling itself. +waitForRegisteredAsync :: Async (Maybe a) -> IO a +waitForRegisteredAsync a = wait a >>= maybe waitForScopeCancellation pure + +-- This loop is deliberately interruptible. In the rejected-child path the +-- current thread is already registered, so cleanup is its sole canceller. +waitForScopeCancellation :: IO a +waitForScopeCancellation = forever $ do + allowInterrupt + sleep 3600 unliftAIO :: AIO a -> AIO (IO a) unliftAIO act = do @@ -402,7 +419,7 @@ data Wait = Wait {justWait :: !(IO ())} | Spawn {justWait :: !(IO ())} -waitOrSpawn :: MVar Bool -> Wait -> IO (Either (IO ()) (Async ())) +waitOrSpawn :: MVar Bool -> Wait -> IO (Either (IO ()) (Async (Maybe ()))) waitOrSpawn _mv (Wait io) = pure $ Left io waitOrSpawn mv (Spawn io) = Right <$> runAsyncIfRegistered mv io @@ -416,14 +433,15 @@ waitConcurrently_ many = do gate <- newEmptyMVar waits <- liftIO $ traverse (waitOrSpawn gate) many let (syncs, asyncs) = partitionEithers waits - registered <- liftIO $ registerAsyncs ref asyncs + registered <- liftIO $ registerAsyncs ref (map void asyncs) putMVar gate registered return (asyncs, syncs, registered) - -- A closed scope means our threads were cancelled, so abort. + -- Refused children finish without running their forces. This parent was + -- already admitted, so cleanup remains its sole canceller. if not registered - then liftIO $ throwIO AsyncCancelled + then liftIO $ traverse_ wait asyncs >> waitForScopeCancellation else do -- work on the sync computations liftIO $ sequence_ syncs -- wait for the async computations before returning - liftIO $ traverse_ wait asyncs + liftIO $ traverse_ waitForRegisteredAsync asyncs diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 06272ce385..ce31bfc3ac 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -6,8 +6,9 @@ module ActionSpec where import Control.Concurrent (MVar, newEmptyMVar, readMVar) import qualified Control.Concurrent as C -import Control.Concurrent.Async (async, poll) +import Control.Concurrent.Async (async, poll, wait) import Control.Concurrent.STM +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) import Data.IORef (newIORef, readIORef) import Data.Maybe (isJust, isNothing) @@ -18,7 +19,8 @@ import Development.IDE.Graph.Database (shakeNewDatabase, import Development.IDE.Graph.Internal.Database (build, cleanupAsync, incDatabase, registerAsyncs, - runAsyncIfRegistered) + runAsyncIfRegistered, + waitForRegisteredAsync) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule @@ -138,21 +140,45 @@ spec = do resultDeps res `shouldBe` UnknownDeps describe "Closing escaped rule computations" $ do - it "tracks an async registered while the scope is open" $ do + it "admits a child before its body runs and cleanup owns its cancellation" $ do scope <- newIORef (Just []) gate <- newEmptyMVar - a <- runAsyncIfRegistered gate $ do C.threadDelay maxBound - registerAsyncs scope [a] `shouldReturn` True + started <- newEmptyMVar + a <- runAsyncIfRegistered gate $ do + C.putMVar started () + C.threadDelay maxBound + registerAsyncs scope [void a] `shouldReturn` True -- Confirm registration so the parked thread proceeds to its computation. C.putMVar gate True + C.takeMVar started -- 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 + cleanupAsync scope + -- Cleanup, rather than the test, cancelled the registered child. + poll a >>= \res -> isJust res `shouldBe` True + it "refuses a late child, which skips its body and finishes normally" $ 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. + gate <- newEmptyMVar + bodyRan <- newEmptyMVar + late <- runAsyncIfRegistered gate $ C.putMVar bodyRan () + registerAsyncs scope [void late] `shouldReturn` False + C.putMVar gate False + -- A refused async terminates without an injected exception or body work. + wait late `shouldReturn` Nothing + C.tryReadMVar bodyRan `shouldReturn` Nothing poll late >>= \res -> isJust res `shouldBe` True + it "leaves an admitted parent waiting for external scope cancellation" $ do + scope <- newIORef (Just []) + refused <- async $ pure (Nothing :: Maybe ()) + wait refused `shouldReturn` Nothing + parentGate <- newEmptyMVar + parent <- runAsyncIfRegistered parentGate $ waitForRegisteredAsync refused + registerAsyncs scope [void parent] `shouldReturn` True + C.putMVar parentGate True + C.yield + -- The parent neither returns nor cancels itself after child refusal. + poll parent >>= \res -> isJust res `shouldBe` False + cleanupAsync scope + poll parent >>= \res -> isJust res `shouldBe` True From de12593213c3bf77500489576b051eda75fe36b5 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 9 Aug 2026 00:15:53 +0800 Subject: [PATCH 09/12] Test the escaped-force interleaving --- ghcide-test/exe/DiagnosticTests.hs | 17 +-- .../IDE/Graph/Internal/Database.hs | 4 +- hls-graph/test/ActionSpec.hs | 100 +++++++++--------- 3 files changed, 50 insertions(+), 71 deletions(-) diff --git a/ghcide-test/exe/DiagnosticTests.hs b/ghcide-test/exe/DiagnosticTests.hs index f70c6d58d5..99f2191f3b 100644 --- a/ghcide-test/exe/DiagnosticTests.hs +++ b/ghcide-test/exe/DiagnosticTests.hs @@ -15,8 +15,7 @@ import Development.IDE.Test (diagnostic, expectDiagnostics, expectDiagnosticsWithTags, expectNoMoreDiagnostics, - flushMessages, waitForAction, - waitForBuildQueue) + flushMessages, waitForAction) import Development.IDE.Types.Location import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -55,20 +54,6 @@ 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 diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 82a42e0447..b1b806023c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,9 +8,7 @@ {-# 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, waitForRegisteredAsync) where +module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where import Prelude hiding (unzip) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index ce31bfc3ac..7d3b82e123 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -6,29 +6,36 @@ module ActionSpec where import Control.Concurrent (MVar, newEmptyMVar, readMVar) import qualified Control.Concurrent as C -import Control.Concurrent.Async (async, poll, wait) +import Control.Concurrent.Async (cancel, wait, + withAsync) import Control.Concurrent.STM -import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) -import Data.IORef (newIORef, readIORef) -import Data.Maybe (isJust, isNothing) +import Data.IORef (modifyIORef', + newIORef, readIORef) import Development.IDE.Graph (shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase, shakeRunDatabaseForKeys) -import Development.IDE.Graph.Internal.Database (build, cleanupAsync, - incDatabase, - registerAsyncs, - runAsyncIfRegistered, - waitForRegisteredAsync) +import Development.IDE.Graph.Internal.Database (build, incDatabase) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule import Example import qualified StmContainers.Map as STM +import System.IO.Unsafe (unsafePerformIO) +import System.Timeout (timeout) import Test.Hspec +-- Park traversal after the preceding key has been handled. The test releases +-- this key normally; cancellation never crosses this unsafe test-only barrier. +{-# NOINLINE blockSecondKey #-} +blockSecondKey :: MVar () -> MVar () -> Rule () +blockSecondKey reached release = unsafePerformIO $ do + C.putMVar reached () + C.takeMVar release + pure Rule + spec :: Spec spec = do @@ -139,46 +146,35 @@ spec = do Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb resultDeps res `shouldBe` UnknownDeps - describe "Closing escaped rule computations" $ do - it "admits a child before its body runs and cleanup owns its cancellation" $ do - scope <- newIORef (Just []) - gate <- newEmptyMVar - started <- newEmptyMVar - a <- runAsyncIfRegistered gate $ do - C.putMVar started () - C.threadDelay maxBound - registerAsyncs scope [void a] `shouldReturn` True - -- Confirm registration so the parked thread proceeds to its computation. - C.putMVar gate True - C.takeMVar started - -- The registered async runs and stays alive. - poll a >>= \res -> isJust res `shouldBe` False - cleanupAsync scope - -- Cleanup, rather than the test, cancelled the registered child. - poll a >>= \res -> isJust res `shouldBe` True - it "refuses a late child, which skips its body and finishes normally" $ do - scope <- newIORef (Just []) - cleanupAsync scope - readIORef scope >>= \m -> isNothing m `shouldBe` True - gate <- newEmptyMVar - bodyRan <- newEmptyMVar - late <- runAsyncIfRegistered gate $ C.putMVar bodyRan () - registerAsyncs scope [void late] `shouldReturn` False - C.putMVar gate False - -- A refused async terminates without an injected exception or body work. - wait late `shouldReturn` Nothing - C.tryReadMVar bodyRan `shouldReturn` Nothing - poll late >>= \res -> isJust res `shouldBe` True - it "leaves an admitted parent waiting for external scope cancellation" $ do - scope <- newIORef (Just []) - refused <- async $ pure (Nothing :: Maybe ()) - wait refused `shouldReturn` Nothing - parentGate <- newEmptyMVar - parent <- runAsyncIfRegistered parentGate $ waitForRegisteredAsync refused - registerAsyncs scope [void parent] `shouldReturn` True - C.putMVar parentGate True - C.yield - -- The parent neither returns nor cancels itself after child refusal. - poll parent >>= \res -> isJust res `shouldBe` False - cleanupAsync scope - poll parent >>= \res -> isJust res `shouldBe` True + describe "Closing escaped rule computations" $ + it "does not execute a force selected before its AIO scope closes" $ do + ruleRuns <- newIORef (0 :: Int) + ShakeDatabase _ _ theDb@Database{..} <- shakeNewDatabase shakeOptions $ + addRule $ \(Rule :: Rule ()) _old _mode -> do + liftIO $ modifyIORef' ruleRuns (+ 1) + pure $ RunResult ChangedRecomputeDiff "" () (pure ()) + + -- The first build publishes a lazy 'Running' force but cannot reach its + -- forcing phase while traversing this infinite list. + withAsync (build theDb emptyStack $ repeat (Rule @())) $ \firstBuild -> do + atomically $ do + details <- STM.lookup (newKey (Rule @())) databaseValues + case details of + Just KeyDetails{keyStatus = Running{}} -> pure () + _ -> retry + + -- A concurrent build selects that Running force, then parks while the + -- first build still owns an open AIO scope. + reachedSecondKey <- newEmptyMVar + releaseSecondKey <- newEmptyMVar + withAsync + (build theDb emptyStack + [Rule @(), blockSecondKey reachedSecondKey releaseSecondKey]) $ \secondBuild -> do + C.takeMVar reachedSecondKey + -- Close the force's original scope before the already-running + -- second build proceeds to force what it selected. + cancel firstBuild + C.putMVar releaseSecondKey () + timeout 1000000 (() <$ wait secondBuild) `shouldReturn` Nothing + + readIORef ruleRuns `shouldReturn` 0 From 48f297100360281fa97d1f9220b23bf76589c85d Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 9 Aug 2026 01:07:06 +0800 Subject: [PATCH 10/12] Assert late asyncs do not outlive their scope --- hls-graph/test/ActionSpec.hs | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 7d3b82e123..37524ff566 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -6,12 +6,11 @@ module ActionSpec where import Control.Concurrent (MVar, newEmptyMVar, readMVar) import qualified Control.Concurrent as C -import Control.Concurrent.Async (cancel, wait, - withAsync) +import Control.Concurrent.Async (cancel, withAsync) import Control.Concurrent.STM +import Control.Exception (finally) import Control.Monad.IO.Class (MonadIO (..)) -import Data.IORef (modifyIORef', - newIORef, readIORef) +import Data.Maybe (isJust, isNothing) import Development.IDE.Graph (shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase, @@ -147,11 +146,15 @@ spec = do resultDeps res `shouldBe` UnknownDeps describe "Closing escaped rule computations" $ - it "does not execute a force selected before its AIO scope closes" $ do - ruleRuns <- newIORef (0 :: Int) + it "does not leave a late async alive outside its closed AIO scope" $ do + bodyStarted <- newEmptyMVar + releaseBody <- newEmptyMVar + bodyFinished <- newEmptyMVar ShakeDatabase _ _ theDb@Database{..} <- shakeNewDatabase shakeOptions $ addRule $ \(Rule :: Rule ()) _old _mode -> do - liftIO $ modifyIORef' ruleRuns (+ 1) + liftIO $ + (C.putMVar bodyStarted () >> C.takeMVar releaseBody) + `finally` C.putMVar bodyFinished () pure $ RunResult ChangedRecomputeDiff "" () (pure ()) -- The first build publishes a lazy 'Running' force but cannot reach its @@ -175,6 +178,17 @@ spec = do -- second build proceeds to force what it selected. cancel firstBuild C.putMVar releaseSecondKey () - timeout 1000000 (() <$ wait secondBuild) `shouldReturn` Nothing - - readIORef ruleRuns `shouldReturn` 0 + started <- timeout 1000000 $ C.takeMVar bodyStarted + -- Cancelling the waiter must not reveal a child that survived + -- teardown in the already-closed first scope. + cancel secondBuild + finished <- C.tryReadMVar bodyFinished + let outOfScopeAlive = isJust started && isNothing finished + -- Let an upstream orphan finish before reporting RED, so the + -- regression test itself never leaks a thread. + case (started, finished) of + (Just (), Nothing) -> do + C.putMVar releaseBody () + C.takeMVar bodyFinished + _ -> pure () + outOfScopeAlive `shouldBe` False From f5bcb50baed0da2d704bd0ad678be3f2f2f56697 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 11 Aug 2026 16:21:44 +0800 Subject: [PATCH 11/12] Run refresh work in the existing force runner --- .../IDE/Graph/Internal/Database.hs | 28 ++----------------- 1 file changed, 2 insertions(+), 26 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index b1b806023c..fa661b133f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -176,9 +176,9 @@ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e - (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> asyncWithCleanUp $ refreshDeps mempty db stack key me (reverse deps) + (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> fmap return $ refreshDeps mempty db stack key me (reverse deps) (Right stack, _) -> - asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result + fmap return $ liftIO $ compute db stack key RunDependenciesChanged result -- | Compute a key. compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result @@ -345,25 +345,6 @@ registerAsyncs st as = Nothing -> (Nothing, False) Just xs -> (Just (as ++ xs), True) --- | 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 - io <- unliftAIO act - -- mask so the spawn and registration can't be split by interrupt - 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 a - return $ waitForRegisteredAsync a - -- | Spawn a parked thread. An admitted thread runs the body and returns its -- result in 'Just'; a refused thread skips the body and finishes with 'Nothing'. runAsyncIfRegistered :: MVar Bool -> IO a -> IO (Async (Maybe a)) @@ -386,11 +367,6 @@ waitForScopeCancellation = forever $ do allowInterrupt sleep 3600 -unliftAIO :: AIO a -> AIO (IO a) -unliftAIO act = do - st <- AIO ask - return $ runReaderT (unAIO act) st - newtype RunInIO = RunInIO (forall a. AIO a -> IO a) withRunInIO :: (RunInIO -> AIO b) -> AIO b From 2248dddfc6459353bcdd7973cfe091626a262847 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 11 Aug 2026 16:25:58 +0800 Subject: [PATCH 12/12] Refactor refresh function to simplify return type and improve clarity --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 8 ++++---- 1 file changed, 4 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 fa661b133f..2f3757c09e 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -124,7 +124,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 act SMap.focus (updateStatus $ Running current force val s) id databaseValues modifyTVar' toForce (Spawn force:) pure val @@ -172,13 +172,13 @@ refreshDeps visited db stack key result = \case else refreshDeps newVisited db stack key result deps -- | Refresh a key: -refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) +refresh :: Database -> Stack -> Key -> Maybe Result -> AIO Result -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e - (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> fmap return $ refreshDeps mempty db stack key me (reverse deps) + (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps) (Right stack, _) -> - fmap return $ liftIO $ compute db stack key RunDependenciesChanged result + liftIO $ compute db stack key RunDependenciesChanged result -- | Compute a key. compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result