From ee9614b3b1b555426cc3829831db52ea92ed728f Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 23 Jun 2026 03:06:41 +0200 Subject: [PATCH 1/2] 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 42382e067787dd75d7d464eabf50c63630cf400a Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 23 Jun 2026 23:12:05 +0200 Subject: [PATCH 2/2] Discard rule results from runs superseded by a restart --- .../IDE/Graph/Internal/Database.hs | 51 +++++++++- .../Development/IDE/Graph/Internal/Types.hs | 2 +- hls-graph/test/ActionSpec.hs | 94 +++++++++++++++++++ 3 files changed, 143 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 359e5ceb6a..c2936f9504 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -17,7 +17,7 @@ import Control.Concurrent.Extra import Control.Concurrent.STM.Stats (STM, atomically, atomicallyNamed, modifyTVar', newTVarIO, - readTVarIO) + readTVar, readTVarIO) import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -180,10 +180,40 @@ refresh db stack key result = case (addStack key stack, result) of (Right stack, _) -> asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result +{- Note [Discard superseded computations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A restart cancels the running build with an async exception, but the computation +it spawned can outlive it and finish under a later build. 'compute' stamps the +result with whatever the step is *now*, so a value read from stale inputs is +recorded as freshly built and dependents skip recomputing it: + + step 1 build A starts rule R, reading its inputs at step 1 + step 2 a restart bumps the step to 2 and marks R dirty + ... A finally finishes and, unguarded, commits Clean@2, + a stale result, but its timestamp claims it is fresh + +Guard: 'compute' samples the step into 'startStep' before running and re-reads it +before storing. + + startStep == now : commit Clean, the normal path + startStep < now : R was superseded. Mark the key Dirty, keeping the prior + result as payload (as a restart does) so the next build + recomputes it and can still cut off. + +A newer build may already own the slot, so demoting blindly would drop its +in-flight result or dirty its fresh one into a duplicate run. Take care not to +clobber validly refreshed results: + + Running s : keep if s > startStep + Clean r : keep if resultVisited r > startStep +-} + -- | Compute a key. compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result -- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined compute db@Database{..} stack key mode result = do + -- See Note [Discard superseded computations] + startStep <- readTVarIO databaseStep let act = runRule databaseRules key (fmap resultData result) mode deps <- newIORef UnknownDeps (execution, RunResult{..}) <- @@ -218,8 +248,11 @@ compute db@Database{..} stack key mode result = do deps _ -> pure () atomicallyNamed "compute and run hook" $ do - runHook - SMap.focus (updateStatus $ Clean res) key databaseValues + -- See Note [Discard superseded computations] + stepNow <- readTVar databaseStep + if stepNow == startStep + then runHook >> SMap.focus (updateStatus $ Clean res) key databaseValues + else SMap.focus (demoteSuperseded startStep) key databaseValues pure res updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m () @@ -227,6 +260,18 @@ updateStatus res = Focus.alter (Just . maybe (KeyDetails res mempty) (\it -> it{keyStatus = res})) +-- | Demote a superseded key to Dirty unless a newer build already wrote a result. +-- See Note [Discard superseded computations]. +demoteSuperseded :: Monad m => Step -> Focus.Focus KeyDetails m () +demoteSuperseded startStep = Focus.adjust $ \kd -> + let st = keyStatus kd + in if newerOwns st then kd else kd{keyStatus = Dirty (getResult st)} + where + newerOwns (Running s _ _ _) = s > startStep + -- resultVisited, since `ChangedNothing` backdates `resultBuilt` time steps. + newerOwns (Clean r) = resultVisited r > startStep + newerOwns _ = False + -- | Returns the set of dirty keys annotated with their age (in # of builds) getDirtySet :: Database -> IO [(Key, Int)] getDirtySet db = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 34bed42391..2df08d5d32 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -152,7 +152,7 @@ data Result = Result { resultValue :: !Value, resultBuilt :: !Step, -- ^ the step when it was last recomputed resultChanged :: !Step, -- ^ the step when it last changed - resultVisited :: !Step, -- ^ the step when it was last looked up + resultVisited :: !Step, -- ^ the step when it was last looked up/produced the result. resultDeps :: !ResultDeps, resultExecution :: !Seconds, -- ^ How long it took, last time it ran resultData :: !BS.ByteString diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 97ab5555ac..0b885958c3 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -129,3 +129,97 @@ spec = do res `shouldBe` [[True]] Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb resultDeps res `shouldBe` UnknownDeps + + describe "Discard superseded computations" $ do + it "leaves a key dirty when a restart bumps the step mid-computation" $ do + started <- C.newEmptyMVar + proceed <- C.newEmptyMVar + done <- C.newEmptyMVar + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ + addRule $ \(Rule :: Rule ()) _old _mode -> do + liftIO $ C.putMVar started () + liftIO $ C.takeMVar proceed + return $ RunResult ChangedRecomputeDiff "" () (return ()) + -- Fork so a restart can bump the step while the rule is still computing. + _ <- C.forkIO $ shakeRunDatabase db [apply1 (Rule @())] >>= C.putMVar done + C.takeMVar started + -- Bumps the step without dirtying anything, so only the guard can leave + -- this key dirty. + incDatabase theDb (Just []) + C.putMVar proceed () + _ <- C.takeMVar done + Just status <- lookup (newKey (Rule @())) <$> getDatabaseValues theDb + case status of + Dirty{} -> pure () + Clean{} -> expectationFailure "superseded computation was committed clean" + Running{} -> expectationFailure "superseded computation left running" + it "commits clean when the step does not advance" $ do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ + addRule $ \(Rule :: Rule ()) _old _mode -> + return $ RunResult ChangedRecomputeDiff "" () (return ()) + _ <- shakeRunDatabase db [apply1 (Rule @())] + Just status <- lookup (newKey (Rule @())) <$> getDatabaseValues theDb + case status of + Clean{} -> pure () + _ -> expectationFailure "expected a clean commit" + it "leaves a newer build's Running intact instead of stomping it" $ + withSupersededRespawn $ \theDb proceedA doneA proceedB doneB -> do + -- A finishes while B is still Running{2}. Guard must keep B's Running. + C.putMVar proceedA () + _ <- C.takeMVar doneA + status <- lookup (newKey (Rule @())) <$> getDatabaseValues theDb + -- Release B before asserting so its thread finishes. + C.putMVar proceedB () + _ <- C.takeMVar doneB + case status of + Just Running{} -> pure () + Just Dirty{} -> expectationFailure "superseded build unnecessary marked dirty" + Just Clean{} -> expectationFailure "newer build committed too early" + Nothing -> expectationFailure "key missing from the database" + it "leaves a newer build's committed Clean intact instead of dirtying it" $ + withSupersededRespawn $ \theDb proceedA doneA proceedB doneB -> do + -- B commits Clean{2} before A demotes. Guard must keep B's Clean. + C.putMVar proceedB () + _ <- C.takeMVar doneB + C.putMVar proceedA () + _ <- C.takeMVar doneA + status <- lookup (newKey (Rule @())) <$> getDatabaseValues theDb + case status of + Just Clean{} -> pure () + Just Dirty{} -> expectationFailure "superseded build unnecessary marked dirty" + Just Running{} -> expectationFailure "newer build didn't commit" + Nothing -> expectationFailure "key missing from the database" + where + -- Two builds of the same key. + -- + -- 1. A, the superseded build, runs at step 1. + -- 2. B, the re-spawn, runs at step 2. B's shakeRunDatabase bumps the step + -- and re-dirties A's in-flight key, so the rule runs again and leaves B + -- Running{2}. + -- + -- Both are started and blocked before the continuation runs. The + -- continuation picks the release ordering that decides whether the guard + -- meets B as Running or as Clean. + withSupersededRespawn + :: (Database -> MVar () -> MVar () -> MVar () -> MVar () -> IO ()) + -> IO () + withSupersededRespawn k = do + calls <- newTVarIO (0 :: Int) + startedA <- C.newEmptyMVar + proceedA <- C.newEmptyMVar + startedB <- C.newEmptyMVar + proceedB <- C.newEmptyMVar + doneA <- C.newEmptyMVar + doneB <- C.newEmptyMVar + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ + addRule $ \(Rule :: Rule ()) _old _mode -> do + n <- liftIO $ atomically $ modifyTVar' calls (+1) >> readTVar calls + liftIO $ if n == 1 + then C.putMVar startedA () >> C.takeMVar proceedA + else C.putMVar startedB () >> C.takeMVar proceedB + return $ RunResult ChangedRecomputeDiff "" () (return ()) + _ <- C.forkIO $ shakeRunDatabase db [apply1 (Rule @())] >> C.putMVar doneA () + C.takeMVar startedA + _ <- C.forkIO $ shakeRunDatabase db [apply1 (Rule @())] >> C.putMVar doneB () + C.takeMVar startedB + k theDb proceedA doneA proceedB doneB