From fa4b225e5019ee7c8a6be2b7450fe673ec7a29dd Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 23 Oct 2021 13:12:38 +0100 Subject: [PATCH 01/18] Expose getDirtySet --- hls-graph/src/Development/IDE/Graph.hs | 2 ++ hls-graph/src/Development/IDE/Graph/Database.hs | 6 ++++++ hls-graph/src/Development/IDE/Graph/Internal/Action.hs | 7 +++++++ hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 2 ++ 4 files changed, 17 insertions(+) diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 6bd49e66f1..b1c549f3cc 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -17,6 +17,8 @@ module Development.IDE.Graph( alwaysRerun, -- * Batching reschedule, + -- * Dirty keys + getDirtySet, ) where import Development.IDE.Graph.Database diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 5a4d083e7b..7fc663a309 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -8,6 +8,7 @@ module Development.IDE.Graph.Database( shakeRunDatabase, shakeRunDatabaseForKeys, shakeProfileDatabase, + shakeGetDirtySet, shakeLastBuildKeys ) where @@ -41,6 +42,11 @@ shakeNewDatabase opts rules = do shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) shakeRunDatabase = shakeRunDatabaseForKeys Nothing +-- | Returns the set of dirty keys annotated with their age (in # of builds) +shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] +shakeGetDirtySet (ShakeDatabase _ _ db) = + fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + -- Only valid if we never pull on the results, which we don't unvoid :: Functor m => m () -> m a unvoid = fmap undefined diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index ef1168685b..f0c5105758 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -15,6 +15,7 @@ module Development.IDE.Graph.Internal.Action , parallel , reschedule , runActions +, Development.IDE.Graph.Internal.Action.getDirtySet ) where import Control.Concurrent.Async @@ -123,3 +124,9 @@ runActions :: Database -> [Action a] -> IO [a] runActions db xs = do deps <- newIORef mempty runReaderT (fromAction $ parallel xs) $ SAction db deps + +-- | Returns the set of dirty keys annotated with their age (in # of builds) +getDirtySet :: Action [(Key, Int)] +getDirtySet = do + db <- getDatabase + liftIO $ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 3adc0698d5..1bc0ced3a2 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -58,6 +58,8 @@ data SAction = SAction { actionDeps :: !(IORef ResultDeps) } +getDatabase :: Action Database +getDatabase = Action $ asks actionDatabase --------------------------------------------------------------------- -- DATABASE From b9924ae04f96cab1c49d84890e0005c25499d41e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 11:38:54 +0100 Subject: [PATCH 02/18] shakeGetBuildStep --- hls-graph/hls-graph.cabal | 2 +- hls-graph/src/Development/IDE/Graph/Database.hs | 10 ++++++++-- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 60d7e182b3..b0f296a37a 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-graph -version: 1.5.0.0 +version: 1.5.1.0 synopsis: Haskell Language Server internal graph API description: Please see the README on GitHub at diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 7fc663a309..d59dfb6870 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -8,12 +8,12 @@ module Development.IDE.Graph.Database( shakeRunDatabase, shakeRunDatabaseForKeys, shakeProfileDatabase, + shakeGetBuildStep, shakeGetDirtySet, shakeLastBuildKeys ) where - import Data.Dynamic -import Data.IORef +import Data.IORef (readIORef) import Data.Maybe import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action @@ -47,6 +47,12 @@ shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] shakeGetDirtySet (ShakeDatabase _ _ db) = fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db +-- | Returns the build number +shakeGetBuildStep :: ShakeDatabase -> IO Int +shakeGetBuildStep (ShakeDatabase _ _ db) = do + Step s <- readIORef $ databaseStep db + return s + -- Only valid if we never pull on the results, which we don't unvoid :: Functor m => m () -> m a unvoid = fmap undefined From c2981c005088a4c9e9b735f9ba0d27100320ea84 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 12 Oct 2021 06:55:44 +0100 Subject: [PATCH 03/18] shakeGetDatabaseKeys --- hls-graph/src/Development/IDE/Graph/Database.hs | 6 ++++++ .../src/Development/IDE/Graph/Internal/Action.hs | 6 ++++++ .../src/Development/IDE/Graph/Internal/Database.hs | 12 +++++++++++- 3 files changed, 23 insertions(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index d59dfb6870..96481a6f31 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -9,6 +9,7 @@ module Development.IDE.Graph.Database( shakeRunDatabaseForKeys, shakeProfileDatabase, shakeGetBuildStep, + shakeGetDatabaseKeys, shakeGetDirtySet, shakeLastBuildKeys ) where @@ -47,6 +48,11 @@ shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] shakeGetDirtySet (ShakeDatabase _ _ db) = fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db +-- | Returns ann approximation of the database keys, +-- annotated with how long ago (in # builds) they were visited +shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)] +shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db + -- | Returns the build number shakeGetBuildStep :: ShakeDatabase -> IO Int shakeGetBuildStep (ShakeDatabase _ _ db) = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index f0c5105758..ad895c17c3 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -16,6 +16,7 @@ module Development.IDE.Graph.Internal.Action , reschedule , runActions , Development.IDE.Graph.Internal.Action.getDirtySet +, getKeysAndVisitedAge ) where import Control.Concurrent.Async @@ -130,3 +131,8 @@ getDirtySet :: Action [(Key, Int)] getDirtySet = do db <- getDatabase liftIO $ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + +getKeysAndVisitedAge :: Action [(Key, Int)] +getKeysAndVisitedAge = do + db <- getDatabase + liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 5717831c7b..4b8a1d985c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet) where +module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where import Control.Concurrent.Async import Control.Concurrent.Extra @@ -188,6 +188,16 @@ getDirtySet db = do calcAgeStatus (Dirty x)=calcAge <$> x calcAgeStatus _ = Nothing return $ mapMaybe ((secondM.secondM) calcAgeStatus) dbContents + +-- | Returns ann approximation of the database keys, +-- annotated with how long ago (in # builds) they were visited +getKeysAndVisitAge :: Database -> IO [(Key, Int)] +getKeysAndVisitAge db = do + values <- Ids.elems (databaseValues db) + Step curr <- readIORef (databaseStep db) + let keysWithVisitAge = mapMaybe (secondM (fmap getAge . getResult)) values + getAge Result{resultVisited = Step s} = curr - s + return keysWithVisitAge -------------------------------------------------------------------------------- -- Lazy IO trick From ad9112dca7f750a3dab7f703ea29b12098255805 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 12 Oct 2021 07:00:56 +0100 Subject: [PATCH 04/18] garbage collection of dirty keys --- ghcide/src/Development/IDE/Core/OfInterest.hs | 5 ++ ghcide/src/Development/IDE/Core/Shake.hs | 75 ++++++++----------- ghcide/src/Development/IDE/Core/Tracing.hs | 17 +++-- ghcide/src/Development/IDE/Main.hs | 5 +- ghcide/src/Development/IDE/Types/Options.hs | 3 + ghcide/src/Development/IDE/Types/Shake.hs | 2 +- 6 files changed, 53 insertions(+), 54 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 880d9f456d..82eef9fb74 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -33,6 +33,7 @@ import Development.IDE.Core.Shake import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Logger +import System.Time.Extra (sleep) newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar @@ -109,3 +110,7 @@ kick = do void $ liftIO $ modifyVar' exportsMap (exportsMap' <>) liftIO $ progressUpdate progress KickCompleted + + -- if idle, perform garbage collection + liftIO $ sleep 5 + garbageCollectDirtyKeys diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 60b7c34fe3..f177ae00bb 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -53,7 +53,6 @@ module Development.IDE.Core.Shake( GlobalIdeOptions(..), HLS.getClientConfig, getPluginConfig, - garbageCollect, knownTargets, setPriority, ideLogger, @@ -75,7 +74,7 @@ module Development.IDE.Core.Shake( HieDbWriter(..), VFSHandle(..), addPersistentRule - ) where + ,garbageCollectDirtyKeys) where import Control.Concurrent.Async import Control.Concurrent.STM @@ -94,7 +93,6 @@ import Data.List.Extra (foldl', partition, import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.Set as Set import qualified Data.SortedList as SL import qualified Data.Text as T import Data.Time @@ -118,7 +116,10 @@ import Development.IDE.GHC.Compat (NameCache, import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake -import Development.IDE.Graph.Database +import Development.IDE.Graph.Database (ShakeDatabase, + shakeOpenDatabase, + shakeProfileDatabase, + shakeRunDatabaseForKeys) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics @@ -327,10 +328,10 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of Nothing -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (file,Key k) + void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (toKey k file) return Nothing Just (v,del,ver) -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k) + void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (toKey k file) return $ Just (v,addDelta del $ mappingForVersion allMappings file ver) -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics @@ -341,7 +342,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do -- Something already succeeded before, leave it alone _ -> old - case HMap.lookup (file,Key k) hm of + case HMap.lookup (toKey k file) hm of Nothing -> readPersistent Just (ValueWithDiagnostics v _) -> case v of Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver)) @@ -356,12 +357,6 @@ lastValue key file = do s <- getShakeExtras liftIO $ lastValueIO s key file -valueVersion :: Value v -> Maybe TextDocumentVersion -valueVersion = \case - Succeeded ver _ -> Just ver - Stale _ ver _ -> Just ver - Failed _ -> Nothing - mappingForVersion :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) -> NormalizedFilePath @@ -419,7 +414,7 @@ setValues :: IdeRule k v -> Vector FileDiagnostic -> IO () setValues state key file val diags = - void $ modifyVar' state $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags) + void $ modifyVar' state $ HMap.insert (toKey key file) (ValueWithDiagnostics (fmap toDyn val) diags) -- | Delete the value stored for a given ide build key @@ -430,7 +425,7 @@ deleteValue -> NormalizedFilePath -> IO () deleteValue ShakeExtras{dirtyKeys, state} key file = do - void $ modifyVar' state $ HMap.delete (file, Key key) + void $ modifyVar' state $ HMap.delete (toKey key file) atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file) recordDirtyKeys @@ -454,7 +449,7 @@ getValues :: IO (Maybe (Value v, Vector FileDiagnostic)) getValues state key file = do vs <- readVar state - case HMap.lookup (file, Key key) vs of + case HMap.lookup (toKey key file) vs of Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do let r = fmap (fromJust . fromDynamic @v) v @@ -733,20 +728,26 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do val <- readVar hiddenDiagnostics return $ getAllDiagnostics val --- | Clear the results for all files that do not match the given predicate. -garbageCollect :: (NormalizedFilePath -> Bool) -> Action () -garbageCollect keep = do - ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras - liftIO $ - do newState <- modifyVar' state $ HMap.filterWithKey (\(file, _) _ -> keep file) - void $ modifyVar' diagnostics $ filterDiagnostics keep - void $ modifyVar' hiddenDiagnostics $ filterDiagnostics keep - void $ modifyVar' publishedDiagnostics $ HMap.filterWithKey (\uri _ -> keep (fromUri uri)) - let versionsForFile = - HMap.fromListWith Set.union $ - mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $ - HMap.toList newState - void $ modifyVar' positionMapping $ filterVersionMap versionsForFile +garbageCollectDirtyKeys :: Action () +garbageCollectDirtyKeys = do + start <- liftIO offsetTime + dirtySet <- getDirtySet + extras <- getShakeExtras + IdeOptions{optMaxDirtyAge} <- getIdeOptions + + (n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap -> + evaluate $ foldl' (removeDirtyKey optMaxDirtyAge) (vmap, (0,[])) dirtySet + liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x -> + foldl' (flip HSet.insert) x garbage + t <- liftIO start + when (n>0) $ liftIO $ logDebug (logger extras) $ T.pack $ + "Garbage collected " <> show n <> " keys (took " <> showDuration t <> ")" + where + removeDirtyKey garbageAge st@(vmap,(!counter, keys)) (k, age) + | age > garbageAge + , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap + = (vmap', (counter+1, k:keys)) + | otherwise = st -- | Define a new Rule without early cutoff define @@ -1128,20 +1129,6 @@ getUriDiagnostics uri ds = maybe [] getDiagnosticsFromStore $ HMap.lookup uri ds -filterDiagnostics :: - (NormalizedFilePath -> Bool) -> - DiagnosticStore -> - DiagnosticStore -filterDiagnostics keep = - HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri) - -filterVersionMap - :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion) - -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) - -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) -filterVersionMap = - HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep - updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do modifyVar_ positionMapping $ \allMappings -> do diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 0c24c8996c..5abaa8c34d 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoApplicativeDo #-} +{-# HLINT ignore #-} module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction @@ -170,12 +171,14 @@ performMeasurement logger stateRef instrumentFor mapCountInstrument = do values <- readVar stateRef let keys = Key GhcSession : Key GhcSessionDeps - : [ k | (_,k) <- HMap.keys values - -- do GhcSessionIO last since it closes over stateRef itself - , k /= Key GhcSession - , k /= Key GhcSessionDeps - , k /= Key GhcSessionIO - ] ++ [Key GhcSessionIO] + -- TODO restore + -- : [ k | (_,k) <- HMap.keys values + -- -- do GhcSessionIO last since it closes over stateRef itself + -- , k /= Key GhcSession + -- , k /= Key GhcSessionDeps + -- , k /= Key GhcSessionIO + -- ] + : [Key GhcSessionIO] groupedForSharing <- evaluate (keys `using` seqList r0) measureMemory logger [groupedForSharing] instrumentFor stateRef `catch` \(e::SomeException) -> @@ -247,7 +250,7 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" let !groupedValues = [ [ (k, vv) | k <- groupKeys - , let vv = [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k'] + , let vv = [] -- [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k'] ] | groupKeys <- groups ] diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 5f1defb027..1a71d54af7 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -378,8 +378,9 @@ defaultMain Arguments{..} = do nub $ Key GhcSession : Key GhcSessionDeps : - [k | (_, k) <- HashMap.keys values, k /= Key GhcSessionIO] - ++ [Key GhcSessionIO] + -- TODO restore + -- [fromKey k | k <- HashMap.keys values, k /= Key GhcSessionIO] ++ + [Key GhcSessionIO] measureMemory logger [keys] consoleObserver valuesRef unless (null failed) (exitWith $ ExitFailure (length failed)) diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 1a8ca906a9..95b15ae18a 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -50,6 +50,8 @@ data IdeOptions = IdeOptions -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants , optReportProgress :: IdeReportProgress -- ^ Whether to report progress during long operations. + , optMaxDirtyAge :: Int + -- ^ Age (in # builds) at which we collect dirty keys , optLanguageSyntax :: String -- ^ the ```language to use , optNewColonConvention :: Bool @@ -143,6 +145,7 @@ defaultIdeOptions session = IdeOptions ,optSkipProgress = defaultSkipProgress ,optProgressStyle = Explicit ,optRunSubset = True + ,optMaxDirtyAge = 100 } defaultSkipProgress :: Typeable a => a -> Bool diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 750dbcdd11..b141a9c240 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -49,7 +49,7 @@ data ValueWithDiagnostics = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) -- | The state of the all values and diagnostics -type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics +type Values = HashMap Key ValueWithDiagnostics -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency -- which short-circuits the rest of the action From 7dd575be7d553e50cb51630a1507d5076dd1c6cc Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 9 Oct 2021 22:41:13 +0100 Subject: [PATCH 05/18] telemetry memory measurements typecheck now --- ghcide/src/Development/IDE/Core/Tracing.hs | 41 ++++++++++++---------- ghcide/src/Development/IDE/Main.hs | 12 +++---- ghcide/src/Development/IDE/Types/Shake.hs | 20 ++++++++++- 3 files changed, 47 insertions(+), 26 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 5abaa8c34d..2a49dc2cc0 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -41,9 +41,9 @@ import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule import Development.IDE.Types.Location (Uri (..)) import Development.IDE.Types.Logger (Logger, logDebug, logInfo) -import Development.IDE.Types.Shake (Key (..), Value, +import Development.IDE.Types.Shake (Value, ValueWithDiagnostics (..), - Values) + Values, fromKeyType) import Foreign.Storable (Storable (sizeOf)) import HeapSize (recursiveSize, runHeapsize) import Ide.PluginUtils (installSigUsr1Handler) @@ -169,16 +169,18 @@ performMeasurement logger stateRef instrumentFor mapCountInstrument = do withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length values <- readVar stateRef - let keys = Key GhcSession - : Key GhcSessionDeps + let keys = typeOf GhcSession + : typeOf GhcSessionDeps -- TODO restore - -- : [ k | (_,k) <- HMap.keys values - -- -- do GhcSessionIO last since it closes over stateRef itself - -- , k /= Key GhcSession - -- , k /= Key GhcSessionDeps - -- , k /= Key GhcSessionIO - -- ] - : [Key GhcSessionIO] + : [ kty + | k <- HMap.keys values + , Just kty <- [fromKeyType k] + -- do GhcSessionIO last since it closes over stateRef itself + , kty /= typeOf GhcSession + , kty /= typeOf GhcSessionDeps + , kty /= typeOf GhcSessionIO + ] + ++ [typeOf GhcSessionIO] groupedForSharing <- evaluate (keys `using` seqList r0) measureMemory logger [groupedForSharing] instrumentFor stateRef `catch` \(e::SomeException) -> @@ -187,7 +189,7 @@ performMeasurement logger stateRef instrumentFor mapCountInstrument = do type OurValueObserver = Int -> IO () -getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver) +getInstrumentCached :: IO (Maybe String -> IO OurValueObserver) getInstrumentCached = do instrumentMap <- newVar HMap.empty mapBytesInstrument <- mkValueObserver "value map size_bytes" @@ -209,8 +211,8 @@ whenNothing act mb = mb >>= f measureMemory :: Logger - -> [[Key]] -- ^ Grouping of keys for the sharing-aware analysis - -> (Maybe Key -> IO OurValueObserver) + -> [[TypeRep]] -- ^ Grouping of keys for the sharing-aware analysis + -> (Maybe String -> IO OurValueObserver) -> Var Values -> IO () measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do @@ -225,7 +227,7 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" repeatUntilJust 3 $ do -- logDebug logger (fromString $ show $ map fst groupedValues) runHeapsize 25000000 $ - forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do + forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> fromString k) $ \sp -> do acc <- liftIO $ newIORef 0 observe <- liftIO $ instrumentFor $ Just k mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v @@ -245,12 +247,13 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" where - groupValues :: Values -> [ [(Key, [Value Dynamic])] ] + groupValues :: Values -> [ [(String, [Value Dynamic])] ] groupValues values = let !groupedValues = - [ [ (k, vv) - | k <- groupKeys - , let vv = [] -- [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k'] + [ [ (show ty, vv) + | ty <- groupKeys + , let vv = [ v | (fromKeyType -> Just kty, ValueWithDiagnostics v _) <- HMap.toList values + , kty == ty] ] | groupKeys <- groups ] diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 1a71d54af7..c9d19a92cc 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -29,6 +29,7 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as T import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as LT +import Data.Typeable (typeOf) import Data.Word (Word16) import Development.IDE (Action, GhcVersion (..), Priority (Debug), Rules, @@ -79,7 +80,7 @@ import Development.IDE.Types.Options (IdeGhcSession, defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (Key (Key)) +import Development.IDE.Types.Shake (fromKeyType) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) @@ -376,11 +377,10 @@ defaultMain Arguments{..} = do printf "# Shake value store contents(%d):\n" (length values) let keys = nub $ - Key GhcSession : - Key GhcSessionDeps : - -- TODO restore - -- [fromKey k | k <- HashMap.keys values, k /= Key GhcSessionIO] ++ - [Key GhcSessionIO] + typeOf GhcSession : + typeOf GhcSessionDeps : + [kty | (fromKeyType -> Just kty) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++ + [typeOf GhcSessionIO] measureMemory logger [keys] consoleObserver valuesRef unless (null failed) (exitWith $ ExitFailure (length failed)) diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index b141a9c240..b76f5639ad 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Types.Shake ( Q (..), @@ -12,7 +13,7 @@ module Development.IDE.Types.Shake ShakeValue(..), currentValue, isBadDependency, - toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey) + toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType) where import Control.DeepSeq @@ -21,6 +22,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Dynamic import Data.HashMap.Strict import Data.Hashable +import Data.Typeable (cast) import Data.Vector (Vector) import Development.IDE.Core.PositionMapping import Development.IDE.Graph (Key (..), RuleResult) @@ -29,6 +31,10 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics import Language.LSP.Types +import Type.Reflection (SomeTypeRep (SomeTypeRep), + pattern App, pattern Con, + typeOf, typeRep, + typeRepTyCon) data Value v = Succeeded TextDocumentVersion v @@ -64,6 +70,18 @@ isBadDependency x toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key toKey = (Key.) . curry Q +fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath) +fromKey (Key k) + | Just (Q (k', f)) <- cast k = Just (k', f) + | otherwise = Nothing + +-- | fromKeyType (Q a) = typeOf a +fromKeyType :: Key -> Maybe SomeTypeRep +fromKeyType (Key k) = case typeOf k of + App (Con tc) a | tc == typeRepTyCon (typeRep @Q) + -> Just $ SomeTypeRep a + _ -> Nothing + toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key toNoFileKey k = Key $ Q (k, emptyFilePath) From 48e7befe7dec7514e3868f7fb2a088992156d73d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 9 Oct 2021 22:42:12 +0100 Subject: [PATCH 06/18] added garbage collection to telemetry --- ghcide/ghcide.cabal | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 27 ++++++++++++-- ghcide/src/Development/IDE/Core/Tracing.hs | 42 ++++++++++++++-------- 3 files changed, 54 insertions(+), 17 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0ff9eb5adc..ccd1b0aa7d 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -77,7 +77,7 @@ library rope-utf16-splay, safe, safe-exceptions, - hls-graph ^>= 1.5, + hls-graph ^>= 1.5.1, sorted-list, sqlite-simple, stm, diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f177ae00bb..08fb749744 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -154,6 +154,8 @@ import Data.IORef.Extra (atomicModifyIORef'_, atomicModifyIORef_) import Data.String (fromString) import Data.Text (pack) +import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Graph.Database (shakeGetBuildStep) import qualified Development.IDE.Types.Exports as ExportsMap import HieDb.Types import Ide.Plugin.Config @@ -538,10 +540,29 @@ shakeOpen lspEnv defaultConfig logger debouncer { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled , optProgressStyle } <- getIdeOptionsIO shakeExtras - startTelemetry otProfilingEnabled logger $ state shakeExtras + + void $ startTelemetry shakeDb shakeExtras + startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras return ideState +startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ()) +startTelemetry db ShakeExtras{..} + | userTracingEnabled = do + countKeys <- mkValueObserver "cached keys count" + countDirty <- mkValueObserver "dirty keys count" + countBuilds <- mkValueObserver "builds count" + regularly 1 $ do + readVar state >>= observe countKeys . Prelude.length + readIORef dirtyKeys >>= observe countDirty . Prelude.length + shakeGetBuildStep db >>= observe countBuilds + + | otherwise = async (pure ()) + where + regularly :: Seconds -> IO () -> IO (Async ()) + regularly delay act = async $ forever (act >> sleep delay) + + -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () shakeSessionInit IdeState{..} = do @@ -729,7 +750,7 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do return $ getAllDiagnostics val garbageCollectDirtyKeys :: Action () -garbageCollectDirtyKeys = do +garbageCollectDirtyKeys = otTracedGarbageCollection $ do start <- liftIO offsetTime dirtySet <- getDirtySet extras <- getShakeExtras @@ -742,6 +763,8 @@ garbageCollectDirtyKeys = do t <- liftIO start when (n>0) $ liftIO $ logDebug (logger extras) $ T.pack $ "Garbage collected " <> show n <> " keys (took " <> showDuration t <> ")" + return garbage + where removeDirtyKey garbageAge st@(vmap,(!counter, keys)) (k, age) | age > garbageAge diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 2a49dc2cc0..416bb5c483 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -4,13 +4,15 @@ module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction - , startTelemetry + , startProfilingTelemetry , measureMemory , getInstrumentCached , otTracedProvider , otSetUri + , otTracedGarbageCollection , withTrace - ,withEventTrace) + , withEventTrace + ) where import Control.Concurrent.Async (Async, async) @@ -33,6 +35,7 @@ import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.String (IsString (fromString)) import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (TypeRep, typeOf) import Debug.Trace.Flags (userTracingEnabled) import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), GhcSessionDeps (GhcSessionDeps), @@ -51,9 +54,8 @@ import Ide.Types (PluginId (..)) import Language.LSP.Types (NormalizedFilePath, fromNormalizedFilePath) import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (Instrument, SpanInFlight (..), - Synchronicity (Asynchronous), - addEvent, beginSpan, endSpan, +import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, + beginSpan, endSpan, mkValueObserver, observe, setTag, withSpan, withSpan_) @@ -128,6 +130,20 @@ otTracedAction key file mode result act (const act) | otherwise = act +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => f [a] -> f () +otTracedGarbageCollection act + | userTracingEnabled = void $ + generalBracket + (beginSpan "GC") + (\sp ec -> do + case ec of + ExitCaseAbort -> setTag sp "aborted" "1" + ExitCaseException e -> setTag sp "exception" (pack $ show e) + ExitCaseSuccess res -> setTag sp "keys" (pack $ unlines $ map show res) + endSpan sp) + (const act) + | otherwise = void act + #if MIN_VERSION_ghc(8,8,0) otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a #else @@ -141,17 +157,17 @@ otTracedProvider (PluginId pluginName) provider act runInIO act | otherwise = act -startTelemetry :: Bool -> Logger -> Var Values -> IO () -startTelemetry allTheTime logger stateRef = do + +startProfilingTelemetry :: Bool -> Logger -> Var Values -> IO () +startProfilingTelemetry allTheTime logger stateRef = do instrumentFor <- getInstrumentCached - mapCountInstrument <- mkValueObserver "values map count" installSigUsr1Handler $ do logInfo logger "SIGUSR1 received: performing memory measurement" - performMeasurement logger stateRef instrumentFor mapCountInstrument + performMeasurement logger stateRef instrumentFor when allTheTime $ void $ regularly (1 * seconds) $ - performMeasurement logger stateRef instrumentFor mapCountInstrument + performMeasurement logger stateRef instrumentFor where seconds = 1000000 @@ -162,11 +178,9 @@ startTelemetry allTheTime logger stateRef = do performMeasurement :: Logger -> Var Values -> - (Maybe Key -> IO OurValueObserver) -> - Instrument 'Asynchronous a m' -> + (Maybe String -> IO OurValueObserver) -> IO () -performMeasurement logger stateRef instrumentFor mapCountInstrument = do - withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length +performMeasurement logger stateRef instrumentFor = do values <- readVar stateRef let keys = typeOf GhcSession From bf19f819c1535e9166ddae2886af2027a5667c6f Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 12:07:11 +0100 Subject: [PATCH 07/18] Test command to trigger GC of dirty keys --- ghcide/src/Development/IDE/Core/OfInterest.hs | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 28 +++++++++++++------ ghcide/src/Development/IDE/Core/Tracing.hs | 6 ++-- ghcide/src/Development/IDE/Plugin/Test.hs | 5 ++++ 4 files changed, 29 insertions(+), 12 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 82eef9fb74..7591adc17c 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -113,4 +113,4 @@ kick = do -- if idle, perform garbage collection liftIO $ sleep 5 - garbageCollectDirtyKeys + void garbageCollectDirtyKeys diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 08fb749744..15717a9971 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -73,8 +73,10 @@ module Development.IDE.Core.Shake( HieDb, HieDbWriter(..), VFSHandle(..), - addPersistentRule - ,garbageCollectDirtyKeys) where + addPersistentRule, + garbageCollectDirtyKeys, + garbageCollectDirtyKeysOlderThan, + ) where import Control.Concurrent.Async import Control.Concurrent.STM @@ -749,15 +751,25 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do val <- readVar hiddenDiagnostics return $ getAllDiagnostics val -garbageCollectDirtyKeys :: Action () -garbageCollectDirtyKeys = otTracedGarbageCollection $ do +-- | Find and release old keys from the state Hashmap +-- For the record, there are other state sources that this process does not release: +-- * diagnostics store (normal, hidden and published) +-- * position mapping store +-- * indexing queue +-- * exports map +garbageCollectDirtyKeys :: Action [Key] +garbageCollectDirtyKeys = do + IdeOptions{optMaxDirtyAge} <- getIdeOptions + garbageCollectDirtyKeysOlderThan optMaxDirtyAge + +garbageCollectDirtyKeysOlderThan :: Int -> Action [Key] +garbageCollectDirtyKeysOlderThan maxAge = otTracedGarbageCollection $ do start <- liftIO offsetTime dirtySet <- getDirtySet extras <- getShakeExtras - IdeOptions{optMaxDirtyAge} <- getIdeOptions (n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap -> - evaluate $ foldl' (removeDirtyKey optMaxDirtyAge) (vmap, (0,[])) dirtySet + evaluate $ foldl' removeDirtyKey (vmap, (0,[])) dirtySet liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x -> foldl' (flip HSet.insert) x garbage t <- liftIO start @@ -766,8 +778,8 @@ garbageCollectDirtyKeys = otTracedGarbageCollection $ do return garbage where - removeDirtyKey garbageAge st@(vmap,(!counter, keys)) (k, age) - | age > garbageAge + removeDirtyKey st@(vmap,(!counter, keys)) (k, age) + | age > maxAge , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap = (vmap', (counter+1, k:keys)) | otherwise = st diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 416bb5c483..36cb3c7fbc 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -130,9 +130,9 @@ otTracedAction key file mode result act (const act) | otherwise = act -otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => f [a] -> f () +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => f [a] -> f [a] otTracedGarbageCollection act - | userTracingEnabled = void $ + | userTracingEnabled = fst <$> generalBracket (beginSpan "GC") (\sp ec -> do @@ -142,7 +142,7 @@ otTracedGarbageCollection act ExitCaseSuccess res -> setTag sp "keys" (pack $ unlines $ map show res) endSpan sp) (const act) - | otherwise = void act + | otherwise = act #if MIN_VERSION_ghc(8,8,0) otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 965c05c27e..76cd6ef4c8 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -37,6 +37,7 @@ import qualified Language.LSP.Server as LSP import Language.LSP.Types import System.Time.Extra +type Age = Int data TestRequest = BlockSeconds Seconds -- ^ :: Null | GetInterfaceFilesDir Uri -- ^ :: String @@ -44,6 +45,7 @@ data TestRequest | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult | GetLastBuildKeys -- ^ :: [String] + | GarbageCollectDirtyKeys Age -- ^ :: [String] (list of keys collected) deriving Generic deriving anyclass (FromJSON, ToJSON) @@ -93,6 +95,9 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do testRequestHandler s GetLastBuildKeys = liftIO $ do keys <- shakeLastBuildKeys $ shakeDb s return $ Right $ toJSON $ map show keys +testRequestHandler s (GarbageCollectDirtyKeys age) = do + res <- liftIO $ runAction "garbage collect" s $ garbageCollectDirtyKeysOlderThan age + return $ Right $ toJSON $ map show res mkResponseError :: Text -> ResponseError mkResponseError msg = ResponseError InvalidRequest msg Nothing From ea8698cfbfa1abc9d4260f830fccea0cee4164b3 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 21:23:35 +0100 Subject: [PATCH 08/18] garbage collection of unused keys --- ghcide/src/Development/IDE/Core/OfInterest.hs | 3 +++ ghcide/src/Development/IDE/Core/Shake.hs | 25 +++++++++++++++---- ghcide/src/Development/IDE/Core/Tracing.hs | 6 ++--- hls-graph/src/Development/IDE/Graph.hs | 3 ++- 4 files changed, 28 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 7591adc17c..8d38d3e5bc 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -114,3 +114,6 @@ kick = do -- if idle, perform garbage collection liftIO $ sleep 5 void garbageCollectDirtyKeys + + -- if still idle, collect unpopular keys + void garbageCollectKeysNotVisited diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 15717a9971..6cd18dd559 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -76,6 +76,8 @@ module Development.IDE.Core.Shake( addPersistentRule, garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, + garbageCollectKeysNotVisited, + garbageCollectKeysNotVisitedFor ) where import Control.Concurrent.Async @@ -762,19 +764,32 @@ garbageCollectDirtyKeys = do IdeOptions{optMaxDirtyAge} <- getIdeOptions garbageCollectDirtyKeysOlderThan optMaxDirtyAge +garbageCollectKeysNotVisited :: Action [Key] +garbageCollectKeysNotVisited = do + IdeOptions{optMaxDirtyAge} <- getIdeOptions + garbageCollectKeysNotVisitedFor optMaxDirtyAge + garbageCollectDirtyKeysOlderThan :: Int -> Action [Key] -garbageCollectDirtyKeysOlderThan maxAge = otTracedGarbageCollection $ do - start <- liftIO offsetTime +garbageCollectDirtyKeysOlderThan maxAge = otTracedGarbageCollection "dirty GC" $ do dirtySet <- getDirtySet - extras <- getShakeExtras + garbageCollectKeys "dirty GC" maxAge dirtySet +garbageCollectKeysNotVisitedFor :: Int -> Action [Key] +garbageCollectKeysNotVisitedFor maxAge = otTracedGarbageCollection "not visited GC" $ do + keys <- getKeysAndVisitedAge + garbageCollectKeys "not visited GC" maxAge keys + +garbageCollectKeys :: String -> Int -> [(Key, Int)] -> Action [Key] +garbageCollectKeys label maxAge agedKeys = do + start <- liftIO offsetTime + extras <- getShakeExtras (n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap -> - evaluate $ foldl' removeDirtyKey (vmap, (0,[])) dirtySet + evaluate $ foldl' removeDirtyKey (vmap, (0,[])) agedKeys liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x -> foldl' (flip HSet.insert) x garbage t <- liftIO start when (n>0) $ liftIO $ logDebug (logger extras) $ T.pack $ - "Garbage collected " <> show n <> " keys (took " <> showDuration t <> ")" + label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" return garbage where diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 36cb3c7fbc..3de16fc157 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -130,11 +130,11 @@ otTracedAction key file mode result act (const act) | otherwise = act -otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => f [a] -> f [a] -otTracedGarbageCollection act +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] +otTracedGarbageCollection label act | userTracingEnabled = fst <$> generalBracket - (beginSpan "GC") + (beginSpan label) (\sp ec -> do case ec of ExitCaseAbort -> setTag sp "aborted" "1" diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index b1c549f3cc..1561abc35b 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -17,8 +17,9 @@ module Development.IDE.Graph( alwaysRerun, -- * Batching reschedule, - -- * Dirty keys + -- * Actions for inspecting the keys in the database getDirtySet, + getKeysAndVisitedAge, ) where import Development.IDE.Graph.Database From be1c740df492fb26be4659a390006dec3fa37d31 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Oct 2021 13:03:58 +0100 Subject: [PATCH 09/18] garbage collection tests --- ghcide/src/Development/IDE/Plugin/Test.hs | 33 +++++-- ghcide/test/exe/Main.hs | 102 ++++++++++++++++++++-- ghcide/test/src/Development/IDE/Test.hs | 27 +++++- 3 files changed, 145 insertions(+), 17 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 76cd6ef4c8..e7b3d71fdf 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -11,17 +11,20 @@ module Development.IDE.Plugin.Test , blockCommandId ) where -import Control.Concurrent (threadDelay) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Extra (readVar) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM import Data.Aeson import Data.Aeson.Types import Data.Bifunctor -import Data.CaseInsensitive (CI, original) -import Data.Maybe (isJust) +import Data.CaseInsensitive (CI, original) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (isJust) import Data.String -import Data.Text (Text, pack) +import Data.Text (Text, pack) +import Development.IDE.Core.OfInterest (getFilesOfInterest) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake @@ -29,11 +32,11 @@ import Development.IDE.GHC.Compat import Development.IDE.Graph (Action) import Development.IDE.Graph.Database (shakeLastBuildKeys) import Development.IDE.Types.Action -import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) -import Development.IDE.Types.Location (fromUri) -import GHC.Generics (Generic) +import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) +import Development.IDE.Types.Location (fromUri) +import GHC.Generics (Generic) import Ide.Types -import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Server as LSP import Language.LSP.Types import System.Time.Extra @@ -46,6 +49,9 @@ data TestRequest | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult | GetLastBuildKeys -- ^ :: [String] | GarbageCollectDirtyKeys Age -- ^ :: [String] (list of keys collected) + | GarbageCollectNotVisitedKeys Age -- ^ :: [String] + | GetStoredKeys -- ^ :: [String] (list of keys in store) + | GetFilesOfInterest -- ^ :: [FilePath] deriving Generic deriving anyclass (FromJSON, ToJSON) @@ -96,8 +102,17 @@ testRequestHandler s GetLastBuildKeys = liftIO $ do keys <- shakeLastBuildKeys $ shakeDb s return $ Right $ toJSON $ map show keys testRequestHandler s (GarbageCollectDirtyKeys age) = do - res <- liftIO $ runAction "garbage collect" s $ garbageCollectDirtyKeysOlderThan age + res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age return $ Right $ toJSON $ map show res +testRequestHandler s (GarbageCollectNotVisitedKeys age) = do + res <- liftIO $ runAction "garbage collect not visited" s $ garbageCollectKeysNotVisitedFor age + return $ Right $ toJSON $ map show res +testRequestHandler s GetStoredKeys = do + keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s) + return $ Right $ toJSON $ map show keys +testRequestHandler s GetFilesOfInterest = do + ff <- liftIO $ getFilesOfInterest s + return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff mkResponseError :: Text -> ResponseError mkResponseError msg = ResponseError InvalidRequest msg Nothing diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index ad54f5d6be..e53e6bce3d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -50,7 +50,14 @@ import Development.IDE.Test (Cursor, expectNoMoreDiagnostics, flushMessages, standardizeQuotes, - waitForAction, getInterfaceFilesDir) + getInterfaceFilesDir + waitForAction, + garbageCollectDirtyKeys, + getStoredKeys, + waitForTypecheck, + getFilesOfInterest, + waitForBuildQueue, + garbageCollectNotVisitedKeys) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location @@ -172,6 +179,7 @@ main = do , clientSettingsTest , codeActionHelperFunctionTests , referenceTests + , garbageCollectionTests ] initializeResponseTests :: TestTree @@ -718,7 +726,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r -- Now we edit the document and wait for the given key (if any) changeDoc doc [edit] whenJust mbKey $ \(key, expectedResult) -> do - Right WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc + WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc liftIO $ ideResultSuccess @?= expectedResult -- The 2nd edit cancels the active session and unbreaks the file @@ -732,7 +740,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s typeCheck doc = do - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ assertBool "The file should typecheck" ideResultSuccess -- wait for the debouncer to publish diagnostics if the rule runs liftIO $ sleep 0.2 @@ -5035,7 +5043,7 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do liftIO $ writeFile hiePath hieContents let aPath = dir "A.hs" doc <- createDoc aPath "haskell" "main = return ()" - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess -- Fix the cradle and typecheck again @@ -5044,7 +5052,7 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess @@ -5123,11 +5131,11 @@ simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraF bPath = dir "b/B.hs" aSource <- liftIO $ readFileUtf8 aPath adoc <- createDoc aPath "haskell" aSource - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc liftIO $ assertBool "A should typecheck" ideResultSuccess bSource <- liftIO $ readFileUtf8 bPath bdoc <- createDoc bPath "haskell" bSource - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc liftIO $ assertBool "B should typecheck" ideResultSuccess locs <- getDefinitions bdoc (Position 2 7) let fooL = mkL (adoc ^. L.uri) 2 0 2 3 @@ -5832,6 +5840,86 @@ unitTests = do , Progress.tests ] +garbageCollectionTests :: TestTree +garbageCollectionTests = testGroup "garbage collection" + [ testGroup "dirty keys" (sharedGCtests garbageCollectDirtyKeys) + , testGroup "unvisited keys" (sharedGCtests garbageCollectNotVisitedKeys) + ] + where + sharedGCtests gc = + [ testSession' "are collected" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + void $ generateGarbage "A" dir + garbage <- gc 0 + liftIO $ assertBool "no garbage was found" $ not $ null garbage + + , testSession' "are deleted from the state" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + void $ generateGarbage "A" dir + keys0 <- getStoredKeys + garbage <- gc 0 + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keys1 <- getStoredKeys + liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) + + , testSession' "are not regenerated unless needed" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" + void $ generateGarbage "A" dir + + keysA <- getStoredKeys + + reopenB <- generateGarbage "B" dir + -- garbage collect A keys + garbage <- gc 1 + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keysB <- getStoredKeys + liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" (length keysB < length keysA) + ff <- getFilesOfInterest + liftIO $ assertBool ("something is wrong with this test - files of interest is " <> show ff) (null ff) + + -- typecheck B again + _ <- reopenB + + -- review the keys in store now to validate that A keys have not been regenerated + keysB' <- getStoredKeys + let regeneratedKeys = Set.filter (not . isExpected) $ + Set.intersection (Set.fromList garbage) (Set.fromList keysB') + liftIO $ regeneratedKeys @?= mempty + + , testSession' "regenerate successfully" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + reopenA <- generateGarbage "A" dir + garbage <- gc 0 + liftIO $ assertBool "no garbage was found" $ not $ null garbage + let edit = T.unlines + [ "module A where" + , "a :: Bool" + , "a = ()" + ] + doc <- reopenA + changeDoc doc ([TextDocumentContentChangeEvent Nothing Nothing edit]) + builds <- waitForTypecheck doc + liftIO $ assertBool "it still builds" builds + expectCurrentDiagnostics doc ([(DsError, (2,4), "Couldn't match expected type")]) + ] + + isExpected k = any (`isPrefixOf` k) ["GhcSessionIO"] + + generateGarbage :: String -> FilePath -> Session(Session TextDocumentIdentifier) + generateGarbage modName dir = do + let fp = modName <> ".hs" + body = printf "module %s where" modName + doc <- createDoc fp "haskell" (T.pack body) + liftIO $ writeFile (dir fp) body + builds <- waitForTypecheck doc + liftIO $ assertBool "something is wrong with this test" builds + closeDoc doc + waitForBuildQueue + -- dirty the garbage + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [FileEvent (filePathToUri $ dir modName <> ".hs") FcChanged ] + return $ openDoc (modName <> ".hs") "haskell" + findResolution_us :: Int -> IO Int findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 35ae059500..600c23d6e4 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -22,6 +22,12 @@ module Development.IDE.Test , waitForAction , getLastBuildKeys , getInterfaceFilesDir + , garbageCollectDirtyKeys + , getFilesOfInterest + , waitForTypecheck + , waitForBuildQueue + , getStoredKeys + , garbageCollectNotVisitedKeys ) where import Control.Applicative.Combinators @@ -34,7 +40,8 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), - WaitForIdeRuleResult) + WaitForIdeRuleResult, + ideResultSuccess) import Development.IDE.Test.Diagnostic import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest @@ -191,3 +198,21 @@ getLastBuildKeys = callTestPlugin GetLastBuildKeys getInterfaceFilesDir :: TextDocumentIdentifier -> Session (Either ResponseError FilePath) getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) + +garbageCollectDirtyKeys :: Int -> Session [String] +garbageCollectDirtyKeys age = callTestPlugin (GarbageCollectDirtyKeys age) + +garbageCollectNotVisitedKeys :: Int -> Session [String] +garbageCollectNotVisitedKeys age = callTestPlugin (GarbageCollectNotVisitedKeys age) + +getStoredKeys :: Session [String] +getStoredKeys = callTestPlugin GetStoredKeys + +waitForTypecheck :: TextDocumentIdentifier -> Session Bool +waitForTypecheck tid = ideResultSuccess <$> waitForAction "typecheck" tid + +waitForBuildQueue :: Session () +waitForBuildQueue = callTestPlugin WaitForShakeQueue + +getFilesOfInterest :: Session [FilePath] +getFilesOfInterest = callTestPlugin GetFilesOfInterest From 126b864b97ebcb0411174e981067074066dbb870 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 13 Oct 2021 13:28:17 +0100 Subject: [PATCH 10/18] exclude certain keys from GC --- ghcide/src/Development/IDE/Core/Shake.hs | 59 +++++++++++++++++------ ghcide/src/Development/IDE/Plugin/Test.hs | 13 ++--- ghcide/test/exe/Main.hs | 4 +- ghcide/test/src/Development/IDE/Test.hs | 9 ++-- 4 files changed, 58 insertions(+), 27 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6cd18dd559..8eac2b3a33 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -551,14 +551,16 @@ shakeOpen lspEnv defaultConfig logger debouncer return ideState startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ()) -startTelemetry db ShakeExtras{..} +startTelemetry db extras@ShakeExtras{..} | userTracingEnabled = do countKeys <- mkValueObserver "cached keys count" countDirty <- mkValueObserver "dirty keys count" countBuilds <- mkValueObserver "builds count" + IdeOptions{optCheckParents} <- getIdeOptionsIO extras + checkParents <- optCheckParents regularly 1 $ do - readVar state >>= observe countKeys . Prelude.length - readIORef dirtyKeys >>= observe countDirty . Prelude.length + readVar state >>= observe countKeys . countRelevantKeys checkParents . HMap.keys + readIORef dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList shakeGetBuildStep db >>= observe countBuilds | otherwise = async (pure ()) @@ -761,26 +763,28 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do -- * exports map garbageCollectDirtyKeys :: Action [Key] garbageCollectDirtyKeys = do - IdeOptions{optMaxDirtyAge} <- getIdeOptions - garbageCollectDirtyKeysOlderThan optMaxDirtyAge + IdeOptions{optCheckParents, optMaxDirtyAge} <- getIdeOptions + checkParents <- liftIO optCheckParents + garbageCollectDirtyKeysOlderThan optMaxDirtyAge checkParents garbageCollectKeysNotVisited :: Action [Key] garbageCollectKeysNotVisited = do - IdeOptions{optMaxDirtyAge} <- getIdeOptions - garbageCollectKeysNotVisitedFor optMaxDirtyAge + IdeOptions{optCheckParents, optMaxDirtyAge} <- getIdeOptions + checkParents <- liftIO optCheckParents + garbageCollectKeysNotVisitedFor optMaxDirtyAge checkParents -garbageCollectDirtyKeysOlderThan :: Int -> Action [Key] -garbageCollectDirtyKeysOlderThan maxAge = otTracedGarbageCollection "dirty GC" $ do +garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key] +garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do dirtySet <- getDirtySet - garbageCollectKeys "dirty GC" maxAge dirtySet + garbageCollectKeys "dirty GC" maxAge checkParents dirtySet -garbageCollectKeysNotVisitedFor :: Int -> Action [Key] -garbageCollectKeysNotVisitedFor maxAge = otTracedGarbageCollection "not visited GC" $ do +garbageCollectKeysNotVisitedFor :: Int -> CheckParents -> Action [Key] +garbageCollectKeysNotVisitedFor maxAge checkParents = otTracedGarbageCollection "not visited GC" $ do keys <- getKeysAndVisitedAge - garbageCollectKeys "not visited GC" maxAge keys + garbageCollectKeys "not visited GC" maxAge checkParents keys -garbageCollectKeys :: String -> Int -> [(Key, Int)] -> Action [Key] -garbageCollectKeys label maxAge agedKeys = do +garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] +garbageCollectKeys label maxAge checkParents agedKeys = do start <- liftIO offsetTime extras <- getShakeExtras (n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap -> @@ -795,10 +799,35 @@ garbageCollectKeys label maxAge agedKeys = do where removeDirtyKey st@(vmap,(!counter, keys)) (k, age) | age > maxAge + , fromKeyType k `notElem` preservedKeys checkParents , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap = (vmap', (counter+1, k:keys)) | otherwise = st +countRelevantKeys :: CheckParents -> [Key] -> Int +countRelevantKeys checkParents = + Prelude.length . filter ((`notElem` preservedKeys checkParents) . fromKeyType) + +preservedKeys :: CheckParents -> [Maybe TypeRep] +preservedKeys checkParents = map Just $ + -- always preserved + [ typeOf GetFileExists + , typeOf GetModificationTime + , typeOf IsFileOfInterest + , typeOf GhcSessionIO + , typeOf GetClientSettings + , typeOf AddWatchedFile + , typeOf GetKnownTargets + ] + ++ concat + -- preserved if CheckParents is enabled since we need to rebuild the ModuleGraph + [ [ typeOf GetModSummary + , typeOf GetModSummaryWithoutTimestamps + , typeOf GetLocatedImports + ] + | checkParents /= NeverCheck + ] + -- | Define a new Rule without early cutoff define :: IdeRule k v diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index e7b3d71fdf..871cd887da 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -35,6 +35,7 @@ import Development.IDE.Types.Action import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic) +import Ide.Plugin.Config (CheckParents) import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types @@ -48,8 +49,8 @@ data TestRequest | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult | GetLastBuildKeys -- ^ :: [String] - | GarbageCollectDirtyKeys Age -- ^ :: [String] (list of keys collected) - | GarbageCollectNotVisitedKeys Age -- ^ :: [String] + | GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected) + | GarbageCollectNotVisitedKeys CheckParents Age -- ^ :: [String] | GetStoredKeys -- ^ :: [String] (list of keys in store) | GetFilesOfInterest -- ^ :: [FilePath] deriving Generic @@ -101,11 +102,11 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do testRequestHandler s GetLastBuildKeys = liftIO $ do keys <- shakeLastBuildKeys $ shakeDb s return $ Right $ toJSON $ map show keys -testRequestHandler s (GarbageCollectDirtyKeys age) = do - res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age +testRequestHandler s (GarbageCollectDirtyKeys parents age) = do + res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents return $ Right $ toJSON $ map show res -testRequestHandler s (GarbageCollectNotVisitedKeys age) = do - res <- liftIO $ runAction "garbage collect not visited" s $ garbageCollectKeysNotVisitedFor age +testRequestHandler s (GarbageCollectNotVisitedKeys parents age) = do + res <- liftIO $ runAction "garbage collect not visited" s $ garbageCollectKeysNotVisitedFor age parents return $ Right $ toJSON $ map show res testRequestHandler s GetStoredKeys = do keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index e53e6bce3d..68614df27e 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5842,8 +5842,8 @@ unitTests = do garbageCollectionTests :: TestTree garbageCollectionTests = testGroup "garbage collection" - [ testGroup "dirty keys" (sharedGCtests garbageCollectDirtyKeys) - , testGroup "unvisited keys" (sharedGCtests garbageCollectNotVisitedKeys) + [ testGroup "dirty keys" (sharedGCtests $ garbageCollectDirtyKeys CheckOnSaveAndClose) + , testGroup "unvisited keys" (sharedGCtests $ garbageCollectNotVisitedKeys CheckOnSaveAndClose) ] where sharedGCtests gc = diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 600c23d6e4..f6a7282985 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -43,6 +43,7 @@ import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult, ideResultSuccess) import Development.IDE.Test.Diagnostic +import Ide.Plugin.Config (CheckParents) import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest import Language.LSP.Types hiding @@ -199,11 +200,11 @@ getLastBuildKeys = callTestPlugin GetLastBuildKeys getInterfaceFilesDir :: TextDocumentIdentifier -> Session (Either ResponseError FilePath) getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) -garbageCollectDirtyKeys :: Int -> Session [String] -garbageCollectDirtyKeys age = callTestPlugin (GarbageCollectDirtyKeys age) +garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String] +garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age) -garbageCollectNotVisitedKeys :: Int -> Session [String] -garbageCollectNotVisitedKeys age = callTestPlugin (GarbageCollectNotVisitedKeys age) +garbageCollectNotVisitedKeys :: CheckParents -> Int -> Session [String] +garbageCollectNotVisitedKeys parents age = callTestPlugin (GarbageCollectNotVisitedKeys parents age) getStoredKeys :: Session [String] getStoredKeys = callTestPlugin GetStoredKeys From 8ae079814c8399e087feaef8e605c3c295ce180d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 13 Oct 2021 15:12:42 +0100 Subject: [PATCH 11/18] hlints --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- ghcide/test/exe/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 8eac2b3a33..3412e66046 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -121,6 +121,7 @@ import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, + shakeGetBuildStep, shakeOpenDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys) @@ -159,7 +160,6 @@ import Data.IORef.Extra (atomicModifyIORef'_, import Data.String (fromString) import Data.Text (pack) import Debug.Trace.Flags (userTracingEnabled) -import Development.IDE.Graph.Database (shakeGetBuildStep) import qualified Development.IDE.Types.Exports as ExportsMap import HieDb.Types import Ide.Plugin.Config diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 68614df27e..197886296f 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5897,10 +5897,10 @@ garbageCollectionTests = testGroup "garbage collection" , "a = ()" ] doc <- reopenA - changeDoc doc ([TextDocumentContentChangeEvent Nothing Nothing edit]) + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit] builds <- waitForTypecheck doc liftIO $ assertBool "it still builds" builds - expectCurrentDiagnostics doc ([(DsError, (2,4), "Couldn't match expected type")]) + expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")] ] isExpected k = any (`isPrefixOf` k) ["GhcSessionIO"] From aa725bf3dcbc0309fa199c1ca30a7f7f3e9b0c74 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 16 Oct 2021 09:01:00 +0100 Subject: [PATCH 12/18] fix 8.6 build --- ghcide/src/Development/IDE/Core/Tracing.hs | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 3de16fc157..542cd31a4f 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -59,6 +59,16 @@ import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, mkValueObserver, observe, setTag, withSpan, withSpan_) +#if MIN_VERSION_ghc(8,8,0) +otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a +#else +otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a] +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a +#endif + withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a withTrace name act @@ -68,11 +78,6 @@ withTrace name act act setSpan' | otherwise = act (\_ _ -> pure ()) -#if MIN_VERSION_ghc(8,8,0) -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a -#else -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a -#endif withEventTrace name act | userTracingEnabled = withSpan (fromString name) $ \sp -> do @@ -130,7 +135,6 @@ otTracedAction key file mode result act (const act) | otherwise = act -otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] otTracedGarbageCollection label act | userTracingEnabled = fst <$> generalBracket @@ -144,11 +148,6 @@ otTracedGarbageCollection label act (const act) | otherwise = act -#if MIN_VERSION_ghc(8,8,0) -otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a -#else -otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a -#endif otTracedProvider (PluginId pluginName) provider act | userTracingEnabled = do runInIO <- askRunInIO From eba476310da592dd1431ce0e5a818bccbb6478ae Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 17 Oct 2021 23:30:15 +0100 Subject: [PATCH 13/18] reuse only Successful values from the store --- ghcide/src/Development/IDE/Core/Shake.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 3412e66046..94ae3c0e4c 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1001,8 +1001,8 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do v <- liftIO $ getValues state key file case v of -- No changes in the dependencies and we have - -- an existing result. - Just (v, diags) -> do + -- an existing successful result. + Just (v@Succeeded{}, diags) -> do when doDiagnostics $ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags return $ Just $ RunResult ChangedNothing old $ A v From 463c47a4ce5819e1e4c68df69e0b2b8d5fdbadd2 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 17 Oct 2021 23:34:38 +0100 Subject: [PATCH 14/18] remove garbage collection of not visited keys The "visited age" metric is not accurate in hls-graph because of reverse-dependencies-guided work avoidance --- ghcide/src/Development/IDE/Core/OfInterest.hs | 5 +---- ghcide/src/Development/IDE/Core/Shake.hs | 13 ------------- ghcide/src/Development/IDE/Plugin/Test.hs | 4 ---- ghcide/test/exe/Main.hs | 17 ++++++++--------- ghcide/test/src/Development/IDE/Test.hs | 4 ---- 5 files changed, 9 insertions(+), 34 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 8d38d3e5bc..2c3e68d5c7 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -111,9 +111,6 @@ kick = do liftIO $ progressUpdate progress KickCompleted - -- if idle, perform garbage collection + -- if idle, perform garbage collection of dirty keys liftIO $ sleep 5 void garbageCollectDirtyKeys - - -- if still idle, collect unpopular keys - void garbageCollectKeysNotVisited diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 94ae3c0e4c..c8f48e00b3 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -76,8 +76,6 @@ module Development.IDE.Core.Shake( addPersistentRule, garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, - garbageCollectKeysNotVisited, - garbageCollectKeysNotVisitedFor ) where import Control.Concurrent.Async @@ -767,22 +765,11 @@ garbageCollectDirtyKeys = do checkParents <- liftIO optCheckParents garbageCollectDirtyKeysOlderThan optMaxDirtyAge checkParents -garbageCollectKeysNotVisited :: Action [Key] -garbageCollectKeysNotVisited = do - IdeOptions{optCheckParents, optMaxDirtyAge} <- getIdeOptions - checkParents <- liftIO optCheckParents - garbageCollectKeysNotVisitedFor optMaxDirtyAge checkParents - garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key] garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do dirtySet <- getDirtySet garbageCollectKeys "dirty GC" maxAge checkParents dirtySet -garbageCollectKeysNotVisitedFor :: Int -> CheckParents -> Action [Key] -garbageCollectKeysNotVisitedFor maxAge checkParents = otTracedGarbageCollection "not visited GC" $ do - keys <- getKeysAndVisitedAge - garbageCollectKeys "not visited GC" maxAge checkParents keys - garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] garbageCollectKeys label maxAge checkParents agedKeys = do start <- liftIO offsetTime diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 871cd887da..b611b049a9 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -50,7 +50,6 @@ data TestRequest | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult | GetLastBuildKeys -- ^ :: [String] | GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected) - | GarbageCollectNotVisitedKeys CheckParents Age -- ^ :: [String] | GetStoredKeys -- ^ :: [String] (list of keys in store) | GetFilesOfInterest -- ^ :: [FilePath] deriving Generic @@ -105,9 +104,6 @@ testRequestHandler s GetLastBuildKeys = liftIO $ do testRequestHandler s (GarbageCollectDirtyKeys parents age) = do res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents return $ Right $ toJSON $ map show res -testRequestHandler s (GarbageCollectNotVisitedKeys parents age) = do - res <- liftIO $ runAction "garbage collect not visited" s $ garbageCollectKeysNotVisitedFor age parents - return $ Right $ toJSON $ map show res testRequestHandler s GetStoredKeys = do keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s) return $ Right $ toJSON $ map show keys diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 197886296f..bdc944682d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -56,8 +56,7 @@ import Development.IDE.Test (Cursor, getStoredKeys, waitForTypecheck, getFilesOfInterest, - waitForBuildQueue, - garbageCollectNotVisitedKeys) + waitForBuildQueue) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location @@ -5843,7 +5842,6 @@ unitTests = do garbageCollectionTests :: TestTree garbageCollectionTests = testGroup "garbage collection" [ testGroup "dirty keys" (sharedGCtests $ garbageCollectDirtyKeys CheckOnSaveAndClose) - , testGroup "unvisited keys" (sharedGCtests $ garbageCollectNotVisitedKeys CheckOnSaveAndClose) ] where sharedGCtests gc = @@ -5866,19 +5864,19 @@ garbageCollectionTests = testGroup "garbage collection" liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" void $ generateGarbage "A" dir - keysA <- getStoredKeys - reopenB <- generateGarbage "B" dir -- garbage collect A keys - garbage <- gc 1 + keysBeforeGC <- getStoredKeys + garbage <- gc 2 liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage - keysB <- getStoredKeys - liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" (length keysB < length keysA) + keysAfterGC <- getStoredKeys + liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" (length keysAfterGC < length keysBeforeGC) ff <- getFilesOfInterest liftIO $ assertBool ("something is wrong with this test - files of interest is " <> show ff) (null ff) -- typecheck B again - _ <- reopenB + doc <- reopenB + void $ waitForTypecheck doc -- review the keys in store now to validate that A keys have not been regenerated keysB' <- getStoredKeys @@ -5918,6 +5916,7 @@ garbageCollectionTests = testGroup "garbage collection" -- dirty the garbage sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [FileEvent (filePathToUri $ dir modName <> ".hs") FcChanged ] + return $ openDoc (modName <> ".hs") "haskell" findResolution_us :: Int -> IO Int diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index f6a7282985..47435c80e6 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -27,7 +27,6 @@ module Development.IDE.Test , waitForTypecheck , waitForBuildQueue , getStoredKeys - , garbageCollectNotVisitedKeys ) where import Control.Applicative.Combinators @@ -203,9 +202,6 @@ getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterface garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String] garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age) -garbageCollectNotVisitedKeys :: CheckParents -> Int -> Session [String] -garbageCollectNotVisitedKeys parents age = callTestPlugin (GarbageCollectNotVisitedKeys parents age) - getStoredKeys :: Session [String] getStoredKeys = callTestPlugin GetStoredKeys From 824b5fec2550a381f129a6afebc5e227c34a0fc3 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 18 Oct 2021 09:10:19 +0100 Subject: [PATCH 15/18] use a set for the preserved keys --- ghcide/src/Development/IDE/Core/Shake.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index c8f48e00b3..20634b921f 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -786,17 +786,18 @@ garbageCollectKeys label maxAge checkParents agedKeys = do where removeDirtyKey st@(vmap,(!counter, keys)) (k, age) | age > maxAge - , fromKeyType k `notElem` preservedKeys checkParents + , Just kt <- fromKeyType k + , not(kt `HSet.member` preservedKeys checkParents) , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap = (vmap', (counter+1, k:keys)) | otherwise = st countRelevantKeys :: CheckParents -> [Key] -> Int countRelevantKeys checkParents = - Prelude.length . filter ((`notElem` preservedKeys checkParents) . fromKeyType) + Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents)) . fromKeyType) -preservedKeys :: CheckParents -> [Maybe TypeRep] -preservedKeys checkParents = map Just $ +preservedKeys :: CheckParents -> HashSet TypeRep +preservedKeys checkParents = HSet.fromList $ -- always preserved [ typeOf GetFileExists , typeOf GetModificationTime From 3d879a3b73f0caa011003f2d2750f2f540791d04 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 23 Oct 2021 09:57:28 +0100 Subject: [PATCH 16/18] schedule a GC on file close --- ghcide/src/Development/IDE/Core/FileStore.hs | 6 +- ghcide/src/Development/IDE/Core/OfInterest.hs | 19 ++++-- ghcide/src/Development/IDE/Core/Shake.hs | 19 ++++-- ghcide/src/Development/IDE/Core/Tracing.hs | 4 +- .../src/Development/IDE/LSP/Notifications.hs | 29 ++++----- ghcide/src/Development/IDE/Main.hs | 2 +- ghcide/src/Development/IDE/Types/Options.hs | 2 +- ghcide/src/Development/IDE/Types/Shake.hs | 8 ++- ghcide/test/exe/Main.hs | 64 ++++++++----------- ghcide/test/src/Development/IDE/Test.hs | 19 +++++- hls-plugin-api/src/Ide/Plugin/Config.hs | 5 +- 11 files changed, 98 insertions(+), 79 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 2cc9d1c7f1..fe52b65975 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -256,9 +256,9 @@ setFileModified state saved nfp = do ideOptions <- getIdeOptionsIO $ shakeExtras state doCheckParents <- optCheckParents ideOptions let checkParents = case doCheckParents of - AlwaysCheck -> True - CheckOnSaveAndClose -> saved - _ -> False + AlwaysCheck -> True + CheckOnSave -> saved + _ -> False VFSHandle{..} <- getIdeGlobalState state when (isJust setVirtualFileContents) $ fail "setFileModified can't be called on this type of VFSHandle" diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 2c3e68d5c7..bc53fba870 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -15,7 +15,7 @@ module Development.IDE.Core.OfInterest( setFilesOfInterest, kick, FileOfInterestStatus(..), OfInterestVar(..) - ) where + ,scheduleGarbageCollection) where import Control.Concurrent.Strict import Control.Monad @@ -33,7 +33,6 @@ import Development.IDE.Core.Shake import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Logger -import System.Time.Extra (sleep) newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar @@ -42,6 +41,7 @@ instance IsIdeGlobal OfInterestVar ofInterestRules :: Rules () ofInterestRules = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) + addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False) defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked @@ -55,6 +55,9 @@ ofInterestRules = do summarize (IsFOI (Modified False)) = BS.singleton 2 summarize (IsFOI (Modified True)) = BS.singleton 3 +------------------------------------------------------------ +newtype GarbageCollectVar = GarbageCollectVar (Var Bool) +instance IsIdeGlobal GarbageCollectVar ------------------------------------------------------------ -- Exposed API @@ -94,6 +97,10 @@ deleteFileOfInterest state f = do recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files) +scheduleGarbageCollection :: IdeState -> IO () +scheduleGarbageCollection state = do + GarbageCollectVar var <- getIdeGlobalState state + writeVar var True -- | Typecheck all the files of interest. -- Could be improved @@ -111,6 +118,8 @@ kick = do liftIO $ progressUpdate progress KickCompleted - -- if idle, perform garbage collection of dirty keys - liftIO $ sleep 5 - void garbageCollectDirtyKeys + GarbageCollectVar var <- getIdeGlobalAction + garbageCollectionScheduled <- liftIO $ readVar var + when garbageCollectionScheduled $ do + void garbageCollectDirtyKeys + liftIO $ writeVar var False diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 20634b921f..5670cb540b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -148,7 +148,9 @@ import Language.LSP.Types.Capabilities import OpenTelemetry.Eventlog import Control.Exception.Extra hiding (bracket_) +import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS8 +import Data.Coerce (coerce) import Data.Default import Data.Foldable (toList) import Data.HashSet (HashSet) @@ -761,9 +763,9 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do -- * exports map garbageCollectDirtyKeys :: Action [Key] garbageCollectDirtyKeys = do - IdeOptions{optCheckParents, optMaxDirtyAge} <- getIdeOptions + IdeOptions{optCheckParents} <- getIdeOptions checkParents <- liftIO optCheckParents - garbageCollectDirtyKeysOlderThan optMaxDirtyAge checkParents + garbageCollectDirtyKeysOlderThan 0 checkParents garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key] garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do @@ -779,14 +781,19 @@ garbageCollectKeys label maxAge checkParents agedKeys = do liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x -> foldl' (flip HSet.insert) x garbage t <- liftIO start - when (n>0) $ liftIO $ logDebug (logger extras) $ T.pack $ - label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" + when (n>0) $ liftIO $ do + logDebug (logger extras) $ T.pack $ + label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" + when (coerce $ ideTesting extras) $ liftIO $ mRunLspT (lspEnv extras) $ + LSP.sendNotification (SCustomMethod "ghcide/GC") + (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) return garbage where + showKey = show . Q removeDirtyKey st@(vmap,(!counter, keys)) (k, age) | age > maxAge - , Just kt <- fromKeyType k + , Just (kt,_) <- fromKeyType k , not(kt `HSet.member` preservedKeys checkParents) , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap = (vmap', (counter+1, k:keys)) @@ -794,7 +801,7 @@ garbageCollectKeys label maxAge checkParents agedKeys = do countRelevantKeys :: CheckParents -> [Key] -> Int countRelevantKeys checkParents = - Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents)) . fromKeyType) + Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents) . fst) . fromKeyType) preservedKeys :: CheckParents -> HashSet TypeRep preservedKeys checkParents = HSet.fromList $ diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 542cd31a4f..d81c90d883 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -187,7 +187,7 @@ performMeasurement logger stateRef instrumentFor = do -- TODO restore : [ kty | k <- HMap.keys values - , Just kty <- [fromKeyType k] + , Just (kty,_) <- [fromKeyType k] -- do GhcSessionIO last since it closes over stateRef itself , kty /= typeOf GhcSession , kty /= typeOf GhcSessionDeps @@ -265,7 +265,7 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" let !groupedValues = [ [ (show ty, vv) | ty <- groupKeys - , let vv = [ v | (fromKeyType -> Just kty, ValueWithDiagnostics v _) <- HMap.toList values + , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- HMap.toList values , kty == ty] ] | groupKeys <- groups diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index b2901bf32c..0c7ba6236e 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -14,30 +14,25 @@ module Development.IDE.LSP.Notifications import Language.LSP.Types import qualified Language.LSP.Types as LSP -import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Service -import Development.IDE.Core.Shake -import Development.IDE.Types.Location -import Development.IDE.Types.Logger -import Development.IDE.Types.Options - import Control.Monad.Extra -import qualified Data.HashSet as S -import qualified Data.Text as Text - import Control.Monad.IO.Class import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as S +import qualified Data.Text as Text import Development.IDE.Core.FileExists (modifyFileExists, watchedGlobs) import Development.IDE.Core.FileStore (registerFileWatches, resetFileStore, setFileModified, - setSomethingModified, - typecheckParents) + setSomethingModified) +import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest import Development.IDE.Core.RuleTypes (GetClientSettings (..)) +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.Types.Location +import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) -import Ide.Plugin.Config (CheckParents (CheckOnClose)) import Ide.Types whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () @@ -74,10 +69,10 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = \ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do deleteFileOfInterest ide file - -- Refresh all the files that depended on this - checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide) - when (checkParents >= CheckOnClose) $ typecheckParents ide file - logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri + let msg = "Closed text document: " <> getUri _uri + scheduleGarbageCollection ide + setSomethingModified ide [] $ Text.unpack msg + logDebug (ideLogger ide) msg , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ \ide _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index c9d19a92cc..cb084ef11f 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -379,7 +379,7 @@ defaultMain Arguments{..} = do nub $ typeOf GhcSession : typeOf GhcSessionDeps : - [kty | (fromKeyType -> Just kty) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++ + [kty | (fromKeyType -> Just (kty,_)) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++ [typeOf GhcSessionIO] measureMemory logger [keys] consoleObserver valuesRef diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 95b15ae18a..bfd11413fc 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -139,7 +139,7 @@ defaultIdeOptions session = IdeOptions ,optDefer = IdeDefer True ,optTesting = IdeTesting False ,optCheckProject = pure True - ,optCheckParents = pure CheckOnSaveAndClose + ,optCheckParents = pure CheckOnSave ,optHaddockParse = HaddockParse ,optModifyDynFlags = mempty ,optSkipProgress = defaultSkipProgress diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index b76f5639ad..8d30b59801 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -35,6 +35,7 @@ import Type.Reflection (SomeTypeRep (SomeTypeRep) pattern App, pattern Con, typeOf, typeRep, typeRepTyCon) +import Unsafe.Coerce (unsafeCoerce) data Value v = Succeeded TextDocumentVersion v @@ -75,11 +76,12 @@ fromKey (Key k) | Just (Q (k', f)) <- cast k = Just (k', f) | otherwise = Nothing --- | fromKeyType (Q a) = typeOf a -fromKeyType :: Key -> Maybe SomeTypeRep +-- | fromKeyType (Q (k,f)) = (typeOf k, f) +fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath) fromKeyType (Key k) = case typeOf k of App (Con tc) a | tc == typeRepTyCon (typeRep @Q) - -> Just $ SomeTypeRep a + -> case unsafeCoerce k of + Q (_ :: (), f) -> Just (SomeTypeRep a, f) _ -> Nothing toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index bdc944682d..58ac5c3b36 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -52,11 +52,9 @@ import Development.IDE.Test (Cursor, standardizeQuotes, getInterfaceFilesDir waitForAction, - garbageCollectDirtyKeys, getStoredKeys, waitForTypecheck, - getFilesOfInterest, - waitForBuildQueue) + getFilesOfInterest, waitForGC) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location @@ -5841,69 +5839,67 @@ unitTests = do garbageCollectionTests :: TestTree garbageCollectionTests = testGroup "garbage collection" - [ testGroup "dirty keys" (sharedGCtests $ garbageCollectDirtyKeys CheckOnSaveAndClose) - ] - where - sharedGCtests gc = + [ testGroup "dirty keys" [ testSession' "are collected" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - void $ generateGarbage "A" dir - garbage <- gc 0 + doc <- generateGarbage "A" dir + closeDoc doc + garbage <- waitForGC liftIO $ assertBool "no garbage was found" $ not $ null garbage , testSession' "are deleted from the state" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - void $ generateGarbage "A" dir + docA <- generateGarbage "A" dir keys0 <- getStoredKeys - garbage <- gc 0 + closeDoc docA + garbage <- waitForGC liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage keys1 <- getStoredKeys liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) , testSession' "are not regenerated unless needed" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" - void $ generateGarbage "A" dir + docA <- generateGarbage "A" dir + _docB <- generateGarbage "B" dir - reopenB <- generateGarbage "B" dir -- garbage collect A keys keysBeforeGC <- getStoredKeys - garbage <- gc 2 + closeDoc docA + garbage <- waitForGC liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage keysAfterGC <- getStoredKeys - liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" (length keysAfterGC < length keysBeforeGC) - ff <- getFilesOfInterest - liftIO $ assertBool ("something is wrong with this test - files of interest is " <> show ff) (null ff) - - -- typecheck B again - doc <- reopenB - void $ waitForTypecheck doc + liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" + (length keysAfterGC < length keysBeforeGC) - -- review the keys in store now to validate that A keys have not been regenerated - keysB' <- getStoredKeys + -- re-typecheck B and check that the keys for A have not materialized back + _docB <- generateGarbage "B" dir + keysB <- getStoredKeys let regeneratedKeys = Set.filter (not . isExpected) $ - Set.intersection (Set.fromList garbage) (Set.fromList keysB') + Set.intersection (Set.fromList garbage) (Set.fromList keysB) liftIO $ regeneratedKeys @?= mempty , testSession' "regenerate successfully" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - reopenA <- generateGarbage "A" dir - garbage <- gc 0 + docA <- generateGarbage "A" dir + closeDoc docA + garbage <- waitForGC liftIO $ assertBool "no garbage was found" $ not $ null garbage let edit = T.unlines [ "module A where" , "a :: Bool" , "a = ()" ] - doc <- reopenA + doc <- generateGarbage "A" dir changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit] builds <- waitForTypecheck doc liftIO $ assertBool "it still builds" builds expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")] ] + ] + where + isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"] - isExpected k = any (`isPrefixOf` k) ["GhcSessionIO"] - - generateGarbage :: String -> FilePath -> Session(Session TextDocumentIdentifier) + generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier generateGarbage modName dir = do let fp = modName <> ".hs" body = printf "module %s where" modName @@ -5911,13 +5907,7 @@ garbageCollectionTests = testGroup "garbage collection" liftIO $ writeFile (dir fp) body builds <- waitForTypecheck doc liftIO $ assertBool "something is wrong with this test" builds - closeDoc doc - waitForBuildQueue - -- dirty the garbage - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ dir modName <> ".hs") FcChanged ] - - return $ openDoc (modName <> ".hs") "haskell" + return doc findResolution_us :: Int -> IO Int findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 47435c80e6..9a4c265509 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} module Development.IDE.Test @@ -27,6 +28,8 @@ module Development.IDE.Test , waitForTypecheck , waitForBuildQueue , getStoredKeys + , waitForCustomMessage + , waitForGC ) where import Control.Applicative.Combinators @@ -37,6 +40,7 @@ import qualified Data.Aeson as A import Data.Bifunctor (second) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) +import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult, @@ -202,7 +206,7 @@ getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterface garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String] garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age) -getStoredKeys :: Session [String] +getStoredKeys :: Session [Text] getStoredKeys = callTestPlugin GetStoredKeys waitForTypecheck :: TextDocumentIdentifier -> Session Bool @@ -213,3 +217,16 @@ waitForBuildQueue = callTestPlugin WaitForShakeQueue getFilesOfInterest :: Session [FilePath] getFilesOfInterest = callTestPlugin GetFilesOfInterest + +waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res +waitForCustomMessage msg pred = + skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess (SCustomMethod lbl) (NotMess NotificationMessage{_params = value}) + | lbl == msg -> pred value + _ -> Nothing + +waitForGC :: Session [T.Text] +waitForGC = waitForCustomMessage "ghcide/GC" $ \v -> + case A.fromJSON v of + A.Success x -> Just x + _ -> Nothing diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index dce08c6e24..6a286a5191 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -37,8 +37,7 @@ data CheckParents -- Note that ordering of constructors is meaningful and must be monotonically -- increasing in the scenarios where parents are checked = NeverCheck - | CheckOnClose - | CheckOnSaveAndClose + | CheckOnSave | AlwaysCheck deriving stock (Eq, Ord, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -61,7 +60,7 @@ data Config = instance Default Config where def = Config - { checkParents = CheckOnSaveAndClose + { checkParents = CheckOnSave , checkProject = True , hlintOn = True , diagnosticsOnChange = True From bd194e7fa3b6f2d09b453f256ab3f9ec83ce69d4 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Oct 2021 20:47:38 +0100 Subject: [PATCH 17/18] hlint unsafeCoerce --- ghcide/.hlint.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 725604f7df..01f035184a 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -133,7 +133,7 @@ # Things that are unsafe in Haskell base library - {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]} - {name: unsafeDupablePerformIO, within: []} - - {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code]} + - {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code, Development.IDE.Types.Shake]} # Things that are a bit dangerous in the GHC API - {name: nameModule, within: []} From f8d11d30bfee0218b74eeee09a6c27cd2f39519f Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 25 Oct 2021 20:08:44 +0100 Subject: [PATCH 18/18] post-merge fixes --- ghcide/test/exe/Main.hs | 7 +++---- ghcide/test/src/Development/IDE/Test.hs | 18 +++++++++--------- 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 58ac5c3b36..2dd58490b4 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -50,11 +50,10 @@ import Development.IDE.Test (Cursor, expectNoMoreDiagnostics, flushMessages, standardizeQuotes, - getInterfaceFilesDir + getInterfaceFilesDir, waitForAction, getStoredKeys, - waitForTypecheck, - getFilesOfInterest, waitForGC) + waitForTypecheck, waitForGC) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location @@ -5254,7 +5253,7 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d -- Check that we wrote the interfaces for B when we saved - Right hidir <- getInterfaceFilesDir bdoc + hidir <- getInterfaceFilesDir bdoc hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 9a4c265509..48fd9fa5bc 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -182,25 +182,25 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) diagnostic = LspTest.message STextDocumentPublishDiagnostics -callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b callTestPlugin cmd = do let cm = SCustomMethod "test" waitId <- sendRequest cm (A.toJSON cmd) ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId - return $ do - e <- _result - case A.fromJSON e of - A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing - A.Success a -> pure a + return $ case _result of + Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err + Right json -> case A.fromJSON json of + A.Success a -> a + A.Error e -> error e -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri) -getLastBuildKeys :: Session (Either ResponseError [T.Text]) +getLastBuildKeys :: Session [T.Text] getLastBuildKeys = callTestPlugin GetLastBuildKeys -getInterfaceFilesDir :: TextDocumentIdentifier -> Session (Either ResponseError FilePath) +getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String]