From e3458c7ccf503c002816d79cbc675cee7faa06d8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 17 May 2024 18:53:15 +0800 Subject: [PATCH 1/6] clarify dirty in hls-graph --- .../IDE/Graph/Internal/Database.hs | 22 ++++++++++++++----- .../Development/IDE/Graph/Internal/Types.hs | 1 - 2 files changed, 17 insertions(+), 6 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 7f2cee0a8c..25979a1cbf 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -133,6 +133,9 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do waitAll pure results + +-- | isDirty +-- only dirty when it build time is older than deps' changed time isDirty :: Foldable t => Result -> t (a, Result) -> Bool isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) @@ -179,14 +182,23 @@ compute db@Database{..} stack key mode result = do deps <- newIORef UnknownDeps (execution, RunResult{..}) <- duration $ runReaderT (fromAction act) $ SAction db deps stack - built <- readTVarIO databaseStep + curStep <- readTVarIO databaseStep deps <- readIORef deps - let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result - built' = if runChanged /= ChangedNothing then built else changed - -- only update the deps when the rule ran with changes + let lastChanged = maybe curStep resultChanged result + let lastBuild = maybe curStep resultBuilt result + -- changed time would be slower + -- build time would be faster + let (changed, built) = case runChanged of + -- some thing changed + ChangedRecomputeDiff -> (curStep, curStep) + -- recomputed is the same + ChangedRecomputeSame -> (lastChanged, curStep) + -- nothing changed + ChangedNothing -> (lastChanged, lastBuild) + let -- only update the deps when the rule ran with changes actualDeps = if runChanged /= ChangedNothing then deps else previousDeps previousDeps= maybe UnknownDeps resultDeps result - let res = Result runValue built' changed built actualDeps execution runStore + let res = Result runValue built changed curStep actualDeps execution runStore case getResultDepsDefault mempty actualDeps of deps | not (nullKeySet deps) && runChanged /= ChangedNothing diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 2283e3acde..3841951378 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -187,7 +187,6 @@ instance NFData RunMode where rnf x = x `seq` () -- | How the output of a rule has changed. data RunChanged = ChangedNothing -- ^ Nothing has changed. - | ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely). | ChangedRecomputeSame -- ^ I recomputed the value and it was the same. | ChangedRecomputeDiff -- ^ I recomputed the value and it was different. deriving (Eq,Show,Generic) From 717b5b3d79d8d6c03f09b5a4e3d944faad3fc1c7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 17 May 2024 18:58:30 +0800 Subject: [PATCH 2/6] fix comment --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 25979a1cbf..0971628770 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -135,7 +135,7 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do -- | isDirty --- only dirty when it build time is older than deps' changed time +-- only dirty when it's build time is older than the changed time of one of its dependencies isDirty :: Foldable t => Result -> t (a, Result) -> Bool isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) From cedea727069bc3f5704012c43aee59fa09da0868 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 17 May 2024 21:04:56 +0800 Subject: [PATCH 3/6] hls-graph add `compute` test --- .../IDE/Graph/Internal/Database.hs | 2 +- .../Development/IDE/Graph/Internal/Types.hs | 2 +- hls-graph/test/ActionSpec.hs | 25 ++++++++++++++++++- hls-graph/test/Example.hs | 6 +++++ 4 files changed, 32 insertions(+), 3 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 0971628770..3c75bbcea6 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -7,7 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where +module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where import Prelude hiding (unzip) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 3841951378..8f67b83a9c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -84,7 +84,7 @@ getDatabase = Action $ asks actionDatabase data ShakeDatabase = ShakeDatabase !Int [Action ()] Database newtype Step = Step Int - deriving newtype (Eq,Ord,Hashable) + deriving newtype (Eq,Ord,Hashable,Show) --------------------------------------------------------------------- -- Keys diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index eece9b03ca..4f91705e99 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -8,7 +8,8 @@ import Control.Concurrent.STM import Development.IDE.Graph (shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) -import Development.IDE.Graph.Internal.Database (build, incDatabase) +import Development.IDE.Graph.Internal.Database (build, compute, + incDatabase) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule @@ -18,6 +19,28 @@ import Test.Hspec spec :: Spec spec = do + describe "compute" $ do + it "build step and changed step updated correctly" $ do + (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + ruleStep + + let k = newKey $ Rule @() + -- ChangedRecomputeSame + r1@Result{resultChanged=rc1, resultBuilt=rb1} <- compute theDb emptyStack k RunDependenciesChanged Nothing + incDatabase theDb Nothing + -- ChangedRecomputeSame + r2@Result{resultChanged=rc2, resultBuilt=rb2} <- compute theDb emptyStack k RunDependenciesChanged (Just r1) + incDatabase theDb Nothing + -- changed Nothing + Result{resultChanged=rc3, resultBuilt=rb3} <- compute theDb emptyStack k RunDependenciesSame (Just r2) + rc1 `shouldBe` Step 0 + rc2 `shouldBe` Step 0 + rc3 `shouldBe` Step 0 + + rb1 `shouldBe` Step 0 + rb2 `shouldBe` Step 1 + rb3 `shouldBe` Step 1 + describe "apply1" $ do it "computes a rule with no dependencies" $ do db <- shakeNewDatabase shakeOptions $ do diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index a15cb5487f..965873fe90 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -20,6 +20,12 @@ instance Typeable a => Show (Rule a) where type instance RuleResult (Rule a) = a +ruleStep :: Rules () +ruleStep = addRule $ \(Rule :: Rule ()) _old mode -> do + case mode of + RunDependenciesChanged -> return $ RunResult ChangedRecomputeSame "" () (return ()) + RunDependenciesSame -> return $ RunResult ChangedNothing "" () (return ()) + ruleUnit :: Rules () ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do return $ RunResult ChangedRecomputeDiff "" () (return ()) From 3d7371e89aa946a8175ad96a7ba2c4c6af75d8fe Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 17 May 2024 21:29:56 +0800 Subject: [PATCH 4/6] move test to better place --- hls-graph/test/ActionSpec.hs | 25 +---------------------- hls-graph/test/DatabaseSpec.hs | 36 ++++++++++++++++++++++++++++------ 2 files changed, 31 insertions(+), 30 deletions(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 4f91705e99..eece9b03ca 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -8,8 +8,7 @@ import Control.Concurrent.STM import Development.IDE.Graph (shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) -import Development.IDE.Graph.Internal.Database (build, compute, - incDatabase) +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 @@ -19,28 +18,6 @@ import Test.Hspec spec :: Spec spec = do - describe "compute" $ do - it "build step and changed step updated correctly" $ do - (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do - ruleStep - - let k = newKey $ Rule @() - -- ChangedRecomputeSame - r1@Result{resultChanged=rc1, resultBuilt=rb1} <- compute theDb emptyStack k RunDependenciesChanged Nothing - incDatabase theDb Nothing - -- ChangedRecomputeSame - r2@Result{resultChanged=rc2, resultBuilt=rb2} <- compute theDb emptyStack k RunDependenciesChanged (Just r1) - incDatabase theDb Nothing - -- changed Nothing - Result{resultChanged=rc3, resultBuilt=rb3} <- compute theDb emptyStack k RunDependenciesSame (Just r2) - rc1 `shouldBe` Step 0 - rc2 `shouldBe` Step 0 - rc3 `shouldBe` Step 0 - - rb1 `shouldBe` Step 0 - rb2 `shouldBe` Step 1 - rb3 `shouldBe` Step 1 - describe "apply1" $ do it "computes a rule with no dependencies" $ do db <- shakeNewDatabase shakeOptions $ do diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 97a04d3007..9061bfa89d 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -2,16 +2,18 @@ module DatabaseSpec where -import Development.IDE.Graph (shakeOptions) -import Development.IDE.Graph.Database (shakeNewDatabase, - shakeRunDatabase) -import Development.IDE.Graph.Internal.Action (apply1) -import Development.IDE.Graph.Internal.Rules (addRule) +import Development.IDE.Graph (newKey, shakeOptions) +import Development.IDE.Graph.Database (shakeNewDatabase, + shakeRunDatabase) +import Development.IDE.Graph.Internal.Action (apply1) +import Development.IDE.Graph.Internal.Database (compute, incDatabase) +import Development.IDE.Graph.Internal.Rules (addRule) import Development.IDE.Graph.Internal.Types import Example -import System.Time.Extra (timeout) +import System.Time.Extra (timeout) import Test.Hspec + spec :: Spec spec = do describe "Evaluation" $ do @@ -23,3 +25,25 @@ spec = do return $ RunResult ChangedRecomputeDiff "" () (return ()) let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) timeout 1 res `shouldThrow` \StackException{} -> True + + describe "compute" $ do + it "build step and changed step updated correctly" $ do + (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + ruleStep + + let k = newKey $ Rule @() + -- ChangedRecomputeSame + r1@Result{resultChanged=rc1, resultBuilt=rb1} <- compute theDb emptyStack k RunDependenciesChanged Nothing + incDatabase theDb Nothing + -- ChangedRecomputeSame + r2@Result{resultChanged=rc2, resultBuilt=rb2} <- compute theDb emptyStack k RunDependenciesChanged (Just r1) + incDatabase theDb Nothing + -- changed Nothing + Result{resultChanged=rc3, resultBuilt=rb3} <- compute theDb emptyStack k RunDependenciesSame (Just r2) + rc1 `shouldBe` Step 0 + rc2 `shouldBe` Step 0 + rc3 `shouldBe` Step 0 + + rb1 `shouldBe` Step 0 + rb2 `shouldBe` Step 1 + rb3 `shouldBe` Step 1 From cfa9bc50df41553676740cc6224ffdc82b87a425 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 17 May 2024 23:36:42 +0800 Subject: [PATCH 5/6] add detailed test --- hls-graph/test/ActionSpec.hs | 85 +++++++++++++++++++++++++----------- hls-graph/test/Example.hs | 4 ++ 2 files changed, 63 insertions(+), 26 deletions(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index eece9b03ca..606d3521e1 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -3,11 +3,14 @@ module ActionSpec where +import Control.Concurrent (MVar, readMVar) import qualified Control.Concurrent as C import Control.Concurrent.STM +import Control.Monad.IO.Class (MonadIO (..)) import Development.IDE.Graph (shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, - shakeRunDatabase) + shakeRunDatabase, + shakeRunDatabaseForKeys) import Development.IDE.Graph.Internal.Database (build, incDatabase) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types @@ -16,15 +19,50 @@ import Example import qualified StmContainers.Map as STM import Test.Hspec + + spec :: Spec spec = do + describe "apply1" $ it "Buggy dirty mechanism in hls-graph #4237" $ do + let ruleStep1 :: MVar Int -> Rules () + ruleStep1 m = addRule $ \CountRule _old mode -> do + -- depends on ruleSubBranch, it always changed if dirty + _ :: Int <- apply1 SubBranchRule + let r = 1 + case mode of + -- it update the built step + RunDependenciesChanged -> do + _ <- liftIO $ C.modifyMVar m $ \x -> return (x+1, x) + return $ RunResult ChangedRecomputeSame "" r (return ()) + -- this won't update the built step + RunDependenciesSame -> + return $ RunResult ChangedNothing "" r (return ()) + count <- C.newMVar 0 + count1 <- C.newMVar 0 + db <- shakeNewDatabase shakeOptions $ do + ruleSubBranch count + ruleStep1 count1 + -- bootstrapping the database + _ <- shakeRunDatabase db $ pure $ apply1 CountRule -- count = 1 + let child = newKey SubBranchRule + let parent = newKey CountRule + -- instruct to RunDependenciesChanged then CountRule should be recomputed + -- result should be changed 0, build 1 + _res1 <- shakeRunDatabaseForKeys (Just [child]) db [apply1 CountRule] -- count = 2 + -- since child changed = parent build + -- instruct to RunDependenciesSame then CountRule should not be recomputed + -- result should be changed 0, build 1 + _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2 + -- invariant child changed = parent build should remains after RunDependenciesSame + -- this used to be a bug, with additional computation, see https://github.com/haskell/haskell-language-server/pull/4238 + _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2 + c1 <- readMVar count1 + c1 `shouldBe` 2 describe "apply1" $ do it "computes a rule with no dependencies" $ do - db <- shakeNewDatabase shakeOptions $ do - ruleUnit + db <- shakeNewDatabase shakeOptions ruleUnit res <- shakeRunDatabase db $ - pure $ do - apply1 (Rule @()) + pure $ apply1 (Rule @()) res `shouldBe` [()] it "computes a rule with one dependency" $ do db <- shakeNewDatabase shakeOptions $ do @@ -38,8 +76,7 @@ spec = do ruleBool let theKey = Rule @Bool res <- shakeRunDatabase db $ - pure $ do - apply1 theKey + pure $ apply1 theKey res `shouldBe` [True] Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())] @@ -49,14 +86,12 @@ spec = do ruleBool let theKey = Rule @Bool res <- shakeRunDatabase db $ - pure $ do - apply1 theKey + pure $ apply1 theKey res `shouldBe` [True] Just KeyDetails {..} <- atomically $ STM.lookup (newKey (Rule @())) databaseValues - keyReverseDeps `shouldBe` (singletonKeySet $ newKey theKey) + keyReverseDeps `shouldBe` singletonKeySet (newKey theKey) it "rethrows exceptions" $ do - db <- shakeNewDatabase shakeOptions $ do - addRule $ \(Rule :: Rule ()) _old _mode -> error "boom" + db <- shakeNewDatabase shakeOptions $ addRule $ \(Rule :: Rule ()) _old _mode -> error "boom" let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) res `shouldThrow` anyErrorCall it "computes a rule with branching dependencies does not invoke phantom dependencies #3423" $ do @@ -81,18 +116,16 @@ spec = do countRes <- build theDb emptyStack [SubBranchRule] snd countRes `shouldBe` [1 :: Int] - describe "applyWithoutDependency" $ do - it "does not track dependencies" $ do - db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do - ruleUnit - addRule $ \Rule _old _mode -> do - [()] <- applyWithoutDependency [Rule] - return $ RunResult ChangedRecomputeDiff "" True $ return () + describe "applyWithoutDependency" $ it "does not track dependencies" $ do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + ruleUnit + addRule $ \Rule _old _mode -> do + [()] <- applyWithoutDependency [Rule] + return $ RunResult ChangedRecomputeDiff "" True $ return () - let theKey = Rule @Bool - res <- shakeRunDatabase db $ - pure $ do - applyWithoutDependency [theKey] - res `shouldBe` [[True]] - Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb - resultDeps res `shouldBe` UnknownDeps + let theKey = Rule @Bool + res <- shakeRunDatabase db $ + pure $ applyWithoutDependency [theKey] + res `shouldBe` [[True]] + Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb + resultDeps res `shouldBe` UnknownDeps diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 965873fe90..c6a74e90a6 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -68,3 +68,7 @@ ruleSubBranch :: C.MVar Int -> Rules () ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do r <- liftIO $ C.modifyMVar mv $ \x -> return (x+1, x) return $ RunResult ChangedRecomputeDiff "" r (return ()) + +data CountRule = CountRule + deriving (Eq, Generic, Hashable, NFData, Show, Typeable) +type instance RuleResult CountRule = Int From 3fe97e0f6c70e7d9182d8c3ae649fd76dbf5d870 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 1 Jun 2024 15:23:31 +0800 Subject: [PATCH 6/6] fix comment --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 3 +-- hls-graph/test/ActionSpec.hs | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 3c75bbcea6..6729b9615d 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -186,8 +186,7 @@ compute db@Database{..} stack key mode result = do deps <- readIORef deps let lastChanged = maybe curStep resultChanged result let lastBuild = maybe curStep resultBuilt result - -- changed time would be slower - -- build time would be faster + -- changed time is always older than or equal to build time let (changed, built) = case runChanged of -- some thing changed ChangedRecomputeDiff -> (curStep, curStep) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 606d3521e1..97ab5555ac 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -23,7 +23,7 @@ import Test.Hspec spec :: Spec spec = do - describe "apply1" $ it "Buggy dirty mechanism in hls-graph #4237" $ do + describe "apply1" $ it "Test build update, Buggy dirty mechanism in hls-graph #4237" $ do let ruleStep1 :: MVar Int -> Rules () ruleStep1 m = addRule $ \CountRule _old mode -> do -- depends on ruleSubBranch, it always changed if dirty