diff --git a/bench/config.yaml b/bench/config.yaml index 76fbfc3617..a7d0365667 100644 --- a/bench/config.yaml +++ b/bench/config.yaml @@ -94,6 +94,7 @@ experiments: - "edit-header" - "edit" - "hover" + - "semanticTokens" - "hover after edit" # - "hover after cradle edit" - "getDefinition" @@ -194,6 +195,7 @@ configurations: - qualifyImportedNames - rename - stylish-haskell + - semanticTokens # - alternateNumberFormat # - callHierarchy # - changeTypeSignature diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 8805b05434..12ec18a910 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -26,7 +26,8 @@ import Control.Applicative.Combinators (skipManyTill) import Control.Concurrent.Async (withAsync) import Control.Exception.Safe (IOException, handleAny, try) -import Control.Lens (_Just, (&), (.~), (^.)) +import Control.Lens (_Just, (&), (.~), (^.), + (^?)) import Control.Lens.Extras (is) import Control.Monad.Extra (allM, forM, forM_, forever, unless, void, when, @@ -100,7 +101,19 @@ allWithIdentifierPos f docs = case applicableDocs of experiments :: HasConfig => [Bench] experiments = - [ --------------------------------------------------------------------------------------- + [ + bench "semanticTokens" $ \docs -> do + liftIO $ putStrLn "Starting semanticTokens" + r <- forM docs $ \DocumentPositions{..} -> do + changeDoc doc [charEdit stringLiteralP] + waitForProgressStart + waitForProgressDone + tks <- getSemanticTokens doc + case tks ^? LSP._L of + Just _ -> return True + Nothing -> return False + return $ and r, + --------------------------------------------------------------------------------------- bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- @@ -316,7 +329,7 @@ versionP = maybeReader $ extract . readP_to_S parseVersion extract parses = listToMaybe [ res | (res,"") <- parses] output :: (MonadIO m, HasConfig) => String -> m () -output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn +output = if quiet ?config then (\_ -> pure ()) else liftIO . putStrLn --------------------------------------------------------------------------------------- @@ -670,7 +683,7 @@ setup = do whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True - let cleanUp = case exampleDetails(example ?config) of + let cleanUp = case exampleDetails (example ?config) of ExampleHackage _ -> removeDirectoryRecursive examplesPath ExampleScript _ _ -> removeDirectoryRecursive examplesPath ExamplePath _ -> return () diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index bd8601cd16..6eb67bacc2 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -12,6 +12,7 @@ module Development.IDE.Graph.Database( ,shakeGetBuildEdges) where import Control.Concurrent.STM.Stats (readTVarIO) import Data.Dynamic +import Data.Foldable (fold) import Data.Maybe import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 14d8f38b2c..6c26e9c024 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -18,6 +18,7 @@ module Development.IDE.Graph.Internal.Action ) where import Control.Concurrent.Async +import Control.DeepSeq (force) import Control.Exception import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -38,7 +39,7 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) alwaysRerun :: Action () alwaysRerun = do ref <- Action $ asks actionDeps - liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>) + liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>) -- No-op for now reschedule :: Double -> Action () @@ -120,7 +121,8 @@ apply ks = do stack <- Action $ asks actionStack (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps - liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>) + let !ks = force $ fromListKeySet $ toList is + liftIO $ modifyIORef' ref (ResultDeps [ks] <>) pure vs -- | Evaluate a list of keys without recording any dependencies. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index d8fc096639..76004c0e7f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -3,9 +3,9 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where @@ -25,7 +25,7 @@ import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Strict as State import Data.Dynamic import Data.Either -import Data.Foldable (for_, traverse_) +import Data.Foldable (fold, for_, traverse_) import Data.IORef.Extra import Data.List.NonEmpty (unzip) import Data.Maybe @@ -133,26 +133,41 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do waitAll pure results +isDirty :: Foldable t => Result -> t (a, Result) -> Bool +isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) + +-- | Refresh dependencies for a key and compute the key: +-- The refresh the deps linearly(last computed order of the deps for the key). +-- If any of the deps is dirty in the process, we jump to the actual computation of the key +-- and shortcut the refreshing of the rest of the deps. +-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. +-- This assumes that the implementation will be a lookup +-- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself +refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result) +refreshDeps visited db stack key result = \case + -- no more deps to refresh + [] -> pure $ compute db stack key RunDependenciesSame (Just result) + (dep:deps) -> do + let newVisited = dep <> visited + res <- builder db stack (toListKeySet (dep `differenceKeySet` visited)) + case res of + Left res -> if isDirty result res + -- restart the computation if any of the deps are dirty + then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged (Just result) + -- else kick the rest of the deps + else refreshDeps newVisited db stack key result deps + Right iores -> asyncWithCleanUp $ liftIO $ do + res <- iores + if isDirty result res + then compute db stack key RunDependenciesChanged (Just result) + else join $ runAIO $ refreshDeps newVisited db stack key result deps + -- | Refresh a key: --- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. --- This assumes that the implementation will be a lookup --- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself 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 (toListKeySet -> deps)}) -> do - res <- builder db stack deps - let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) - case res of - Left res -> - if isDirty res - then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result - else pure $ compute db stack key RunDependenciesSame result - Right iores -> asyncWithCleanUp $ liftIO $ do - res <- iores - let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame - compute db stack key mode result + (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps) (Right stack, _) -> asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result @@ -173,7 +188,7 @@ compute db@Database{..} stack key mode result = do previousDeps= maybe UnknownDeps resultDeps result let res = Result runValue built' changed built actualDeps execution runStore case getResultDepsDefault mempty actualDeps of - deps | not(nullKeySet deps) + deps | not (nullKeySet deps) && runChanged /= ChangedNothing -> do -- IMPORTANT: record the reverse deps **before** marking the key Clean. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs index 1d9010d53b..ba303cdb99 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -101,7 +101,7 @@ renderKey :: Key -> Text renderKey (lookupKeyValue -> KeyValue _ t) = t newtype KeySet = KeySet IntSet - deriving newtype (Eq, Ord, Semigroup, Monoid) + deriving newtype (Eq, Ord, Semigroup, Monoid, NFData) instance Show KeySet where showsPrec p (KeySet is)= showParen (p > 10) $ diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 408e3d2f12..01a6d803fc 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -12,6 +12,7 @@ import Data.Bifunctor import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char import Data.Dynamic (toDyn) +import Data.Foldable (fold) import qualified Data.HashMap.Strict as Map import Data.List (dropWhileEnd, foldl', intercalate, diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index d780b5c921..02b5ccd4b0 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -12,6 +12,7 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Bifunctor (second) import qualified Data.ByteString as BS import Data.Dynamic +import Data.Foldable (fold) import qualified Data.HashMap.Strict as Map import Data.IORef import Data.List (intercalate) @@ -144,16 +145,20 @@ data Result = Result { resultData :: !BS.ByteString } -data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet +-- Notice, invariant to maintain: +-- the ![KeySet] in ResultDeps need to be stored in reverse order, +-- so that we can append to it efficiently, and we need the ordering +-- so we can do a linear dependency refreshing in refreshDeps. +data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps ![KeySet] deriving (Eq, Show) getResultDepsDefault :: KeySet -> ResultDeps -> KeySet -getResultDepsDefault _ (ResultDeps ids) = ids +getResultDepsDefault _ (ResultDeps ids) = fold ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids getResultDepsDefault def UnknownDeps = def mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps -mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids +mapResultDeps f (ResultDeps ids) = ResultDeps $ fmap f ids mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids mapResultDeps _ UnknownDeps = UnknownDeps diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index cfa7a5eeef..ffb319c614 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -3,15 +3,17 @@ module ActionSpec where +import qualified Control.Concurrent as C import Control.Concurrent.STM -import Development.IDE.Graph (shakeOptions) -import Development.IDE.Graph.Database (shakeNewDatabase, - shakeRunDatabase) +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.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule import Example -import qualified StmContainers.Map as STM +import qualified StmContainers.Map as STM import Test.Hspec spec :: Spec @@ -40,7 +42,7 @@ spec = do apply1 theKey res `shouldBe` [True] Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb - resultDeps res `shouldBe` ResultDeps (singletonKeySet $ newKey (Rule @())) + resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())] it "tracks reverse dependencies" $ do db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do ruleUnit @@ -57,6 +59,28 @@ spec = do 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 + cond <- C.newMVar True + count <- C.newMVar 0 + (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + ruleUnit + ruleCond cond + ruleSubBranch count + ruleWithCond + -- build the one with the condition True + -- This should call the SubBranchRule once + -- cond rule would return different results each time + res0 <- build theDb emptyStack [BranchedRule] + snd res0 `shouldBe` [1 :: Int] + incDatabase theDb Nothing + -- build the one with the condition False + -- This should not call the SubBranchRule + res1 <- build theDb emptyStack [BranchedRule] + snd res1 `shouldBe` [2 :: Int] + -- SubBranchRule should be recomputed once before this (when the condition was True) + 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 diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 1a897fc174..2845b60e6c 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -4,6 +4,8 @@ {-# LANGUAGE TypeFamilies #-} module Example where +import qualified Control.Concurrent as C +import Control.Monad.IO.Class (liftIO) import Development.IDE.Graph import Development.IDE.Graph.Classes import Development.IDE.Graph.Rule @@ -27,3 +29,36 @@ ruleBool :: Rules () ruleBool = addRule $ \Rule _old _mode -> do () <- apply1 Rule return $ RunResult ChangedRecomputeDiff "" True + + +data CondRule = CondRule + deriving (Eq, Generic, Hashable, NFData, Show, Typeable) +type instance RuleResult CondRule = Bool + + +ruleCond :: C.MVar Bool -> Rules () +ruleCond mv = addRule $ \CondRule _old _mode -> do + r <- liftIO $ C.modifyMVar mv $ \x -> return (not x, x) + return $ RunResult ChangedRecomputeDiff "" r + +data BranchedRule = BranchedRule + deriving (Eq, Generic, Hashable, NFData, Show, Typeable) +type instance RuleResult BranchedRule = Int + +ruleWithCond :: Rules () +ruleWithCond = addRule $ \BranchedRule _old _mode -> do + r <- apply1 CondRule + if r then do + _ <- apply1 SubBranchRule + return $ RunResult ChangedRecomputeDiff "" (1 :: Int) + else + return $ RunResult ChangedRecomputeDiff "" (2 :: Int) + +data SubBranchRule = SubBranchRule + deriving (Eq, Generic, Hashable, NFData, Show, Typeable) +type instance RuleResult SubBranchRule = Int + +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