Skip to content

Commit 348db7d

Browse files
pepeiborrapepeiborra
committed
Garbage collection of dirty keys (#2263)
1 parent b20c753 commit 348db7d

File tree

20 files changed

+443
-153
lines changed

20 files changed

+443
-153
lines changed

Diff for: ‎ghcide/.hlint.yaml

+1-1
Original file line numberDiff line numberDiff line change
@@ -133,7 +133,7 @@
133133
# Things that are unsafe in Haskell base library
134134
- {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]}
135135
- {name: unsafeDupablePerformIO, within: []}
136-
- {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code]}
136+
- {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code, Development.IDE.Types.Shake]}
137137
# Things that are a bit dangerous in the GHC API
138138
- {name: nameModule, within: []}
139139

Diff for: ‎ghcide/ghcide.cabal

+1-1
Original file line numberDiff line numberDiff line change
@@ -77,7 +77,7 @@ library
7777
rope-utf16-splay,
7878
safe,
7979
safe-exceptions,
80-
hls-graph ^>= 1.5,
80+
hls-graph ^>= 1.5.1,
8181
sorted-list,
8282
sqlite-simple,
8383
stm,

Diff for: ‎ghcide/src/Development/IDE/Core/FileStore.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -256,9 +256,9 @@ setFileModified state saved nfp = do
256256
ideOptions <- getIdeOptionsIO $ shakeExtras state
257257
doCheckParents <- optCheckParents ideOptions
258258
let checkParents = case doCheckParents of
259-
AlwaysCheck -> True
260-
CheckOnSaveAndClose -> saved
261-
_ -> False
259+
AlwaysCheck -> True
260+
CheckOnSave -> saved
261+
_ -> False
262262
VFSHandle{..} <- getIdeGlobalState state
263263
when (isJust setVirtualFileContents) $
264264
fail "setFileModified can't be called on this type of VFSHandle"

Diff for: ‎ghcide/src/Development/IDE/Core/OfInterest.hs

+15-1
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ module Development.IDE.Core.OfInterest(
1515
setFilesOfInterest,
1616
kick, FileOfInterestStatus(..),
1717
OfInterestVar(..)
18-
) where
18+
,scheduleGarbageCollection) where
1919

2020
import Control.Concurrent.Strict
2121
import Control.Monad
@@ -41,6 +41,7 @@ instance IsIdeGlobal OfInterestVar
4141
ofInterestRules :: Rules ()
4242
ofInterestRules = do
4343
addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)
44+
addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False)
4445
defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do
4546
alwaysRerun
4647
filesOfInterest <- getFilesOfInterestUntracked
@@ -54,6 +55,9 @@ ofInterestRules = do
5455
summarize (IsFOI (Modified False)) = BS.singleton 2
5556
summarize (IsFOI (Modified True)) = BS.singleton 3
5657

58+
------------------------------------------------------------
59+
newtype GarbageCollectVar = GarbageCollectVar (Var Bool)
60+
instance IsIdeGlobal GarbageCollectVar
5761

5862
------------------------------------------------------------
5963
-- Exposed API
@@ -93,6 +97,10 @@ deleteFileOfInterest state f = do
9397
recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
9498
logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
9599

100+
scheduleGarbageCollection :: IdeState -> IO ()
101+
scheduleGarbageCollection state = do
102+
GarbageCollectVar var <- getIdeGlobalState state
103+
writeVar var True
96104

97105
-- | Typecheck all the files of interest.
98106
-- Could be improved
@@ -109,3 +117,9 @@ kick = do
109117
void $ liftIO $ modifyVar' exportsMap (exportsMap' <>)
110118

111119
liftIO $ progressUpdate progress KickCompleted
120+
121+
GarbageCollectVar var <- getIdeGlobalAction
122+
garbageCollectionScheduled <- liftIO $ readVar var
123+
when garbageCollectionScheduled $ do
124+
void garbageCollectDirtyKeys
125+
liftIO $ writeVar var False

Diff for: ‎ghcide/src/Development/IDE/Core/Shake.hs

+108-47
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,6 @@ module Development.IDE.Core.Shake(
5353
GlobalIdeOptions(..),
5454
HLS.getClientConfig,
5555
getPluginConfig,
56-
garbageCollect,
5756
knownTargets,
5857
setPriority,
5958
ideLogger,
@@ -74,7 +73,9 @@ module Development.IDE.Core.Shake(
7473
HieDb,
7574
HieDbWriter(..),
7675
VFSHandle(..),
77-
addPersistentRule
76+
addPersistentRule,
77+
garbageCollectDirtyKeys,
78+
garbageCollectDirtyKeysOlderThan,
7879
) where
7980

8081
import Control.Concurrent.Async
@@ -94,7 +95,6 @@ import Data.List.Extra (foldl', partition,
9495
import Data.Map.Strict (Map)
9596
import qualified Data.Map.Strict as Map
9697
import Data.Maybe
97-
import qualified Data.Set as Set
9898
import qualified Data.SortedList as SL
9999
import qualified Data.Text as T
100100
import Data.Time
@@ -118,7 +118,11 @@ import Development.IDE.GHC.Compat (NameCache,
118118
import Development.IDE.GHC.Orphans ()
119119
import Development.IDE.Graph hiding (ShakeValue)
120120
import qualified Development.IDE.Graph as Shake
121-
import Development.IDE.Graph.Database
121+
import Development.IDE.Graph.Database (ShakeDatabase,
122+
shakeGetBuildStep,
123+
shakeOpenDatabase,
124+
shakeProfileDatabase,
125+
shakeRunDatabaseForKeys)
122126
import Development.IDE.Graph.Rule
123127
import Development.IDE.Types.Action
124128
import Development.IDE.Types.Diagnostics
@@ -144,7 +148,9 @@ import Language.LSP.Types.Capabilities
144148
import OpenTelemetry.Eventlog
145149

146150
import Control.Exception.Extra hiding (bracket_)
151+
import Data.Aeson (toJSON)
147152
import qualified Data.ByteString.Char8 as BS8
153+
import Data.Coerce (coerce)
148154
import Data.Default
149155
import Data.Foldable (toList)
150156
import Data.HashSet (HashSet)
@@ -153,6 +159,7 @@ import Data.IORef.Extra (atomicModifyIORef'_,
153159
atomicModifyIORef_)
154160
import Data.String (fromString)
155161
import Data.Text (pack)
162+
import Debug.Trace.Flags (userTracingEnabled)
156163
import qualified Development.IDE.Types.Exports as ExportsMap
157164
import HieDb.Types
158165
import Ide.Plugin.Config
@@ -327,10 +334,10 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
327334
MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
328335
case mv of
329336
Nothing -> do
330-
void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (file,Key k)
337+
void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (toKey k file)
331338
return Nothing
332339
Just (v,del,ver) -> do
333-
void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k)
340+
void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (toKey k file)
334341
return $ Just (v,addDelta del $ mappingForVersion allMappings file ver)
335342

336343
-- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics
@@ -341,7 +348,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
341348
-- Something already succeeded before, leave it alone
342349
_ -> old
343350

344-
case HMap.lookup (file,Key k) hm of
351+
case HMap.lookup (toKey k file) hm of
345352
Nothing -> readPersistent
346353
Just (ValueWithDiagnostics v _) -> case v of
347354
Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver))
@@ -356,12 +363,6 @@ lastValue key file = do
356363
s <- getShakeExtras
357364
liftIO $ lastValueIO s key file
358365

359-
valueVersion :: Value v -> Maybe TextDocumentVersion
360-
valueVersion = \case
361-
Succeeded ver _ -> Just ver
362-
Stale _ ver _ -> Just ver
363-
Failed _ -> Nothing
364-
365366
mappingForVersion
366367
:: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
367368
-> NormalizedFilePath
@@ -419,7 +420,7 @@ setValues :: IdeRule k v
419420
-> Vector FileDiagnostic
420421
-> IO ()
421422
setValues state key file val diags =
422-
void $ modifyVar' state $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags)
423+
void $ modifyVar' state $ HMap.insert (toKey key file) (ValueWithDiagnostics (fmap toDyn val) diags)
423424

424425

425426
-- | Delete the value stored for a given ide build key
@@ -430,7 +431,7 @@ deleteValue
430431
-> NormalizedFilePath
431432
-> IO ()
432433
deleteValue ShakeExtras{dirtyKeys, state} key file = do
433-
void $ modifyVar' state $ HMap.delete (file, Key key)
434+
void $ modifyVar' state $ HMap.delete (toKey key file)
434435
atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file)
435436

436437
recordDirtyKeys
@@ -454,7 +455,7 @@ getValues ::
454455
IO (Maybe (Value v, Vector FileDiagnostic))
455456
getValues state key file = do
456457
vs <- readVar state
457-
case HMap.lookup (file, Key key) vs of
458+
case HMap.lookup (toKey key file) vs of
458459
Nothing -> pure Nothing
459460
Just (ValueWithDiagnostics v diagsV) -> do
460461
let r = fmap (fromJust . fromDynamic @v) v
@@ -543,10 +544,31 @@ shakeOpen lspEnv defaultConfig logger debouncer
543544
{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled
544545
, optProgressStyle
545546
} <- getIdeOptionsIO shakeExtras
546-
startTelemetry otProfilingEnabled logger $ state shakeExtras
547+
548+
void $ startTelemetry shakeDb shakeExtras
549+
startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras
547550

548551
return ideState
549552

553+
startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ())
554+
startTelemetry db extras@ShakeExtras{..}
555+
| userTracingEnabled = do
556+
countKeys <- mkValueObserver "cached keys count"
557+
countDirty <- mkValueObserver "dirty keys count"
558+
countBuilds <- mkValueObserver "builds count"
559+
IdeOptions{optCheckParents} <- getIdeOptionsIO extras
560+
checkParents <- optCheckParents
561+
regularly 1 $ do
562+
readVar state >>= observe countKeys . countRelevantKeys checkParents . HMap.keys
563+
readIORef dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList
564+
shakeGetBuildStep db >>= observe countBuilds
565+
566+
| otherwise = async (pure ())
567+
where
568+
regularly :: Seconds -> IO () -> IO (Async ())
569+
regularly delay act = async $ forever (act >> sleep delay)
570+
571+
550572
-- | Must be called in the 'Initialized' handler and only once
551573
shakeSessionInit :: IdeState -> IO ()
552574
shakeSessionInit IdeState{..} = do
@@ -733,20 +755,73 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
733755
val <- readVar hiddenDiagnostics
734756
return $ getAllDiagnostics val
735757

736-
-- | Clear the results for all files that do not match the given predicate.
737-
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
738-
garbageCollect keep = do
739-
ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
740-
liftIO $
741-
do newState <- modifyVar' state $ HMap.filterWithKey (\(file, _) _ -> keep file)
742-
void $ modifyVar' diagnostics $ filterDiagnostics keep
743-
void $ modifyVar' hiddenDiagnostics $ filterDiagnostics keep
744-
void $ modifyVar' publishedDiagnostics $ HMap.filterWithKey (\uri _ -> keep (fromUri uri))
745-
let versionsForFile =
746-
HMap.fromListWith Set.union $
747-
mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
748-
HMap.toList newState
749-
void $ modifyVar' positionMapping $ filterVersionMap versionsForFile
758+
-- | Find and release old keys from the state Hashmap
759+
-- For the record, there are other state sources that this process does not release:
760+
-- * diagnostics store (normal, hidden and published)
761+
-- * position mapping store
762+
-- * indexing queue
763+
-- * exports map
764+
garbageCollectDirtyKeys :: Action [Key]
765+
garbageCollectDirtyKeys = do
766+
IdeOptions{optCheckParents} <- getIdeOptions
767+
checkParents <- liftIO optCheckParents
768+
garbageCollectDirtyKeysOlderThan 0 checkParents
769+
770+
garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key]
771+
garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do
772+
dirtySet <- getDirtySet
773+
garbageCollectKeys "dirty GC" maxAge checkParents dirtySet
774+
775+
garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
776+
garbageCollectKeys label maxAge checkParents agedKeys = do
777+
start <- liftIO offsetTime
778+
extras <- getShakeExtras
779+
(n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap ->
780+
evaluate $ foldl' removeDirtyKey (vmap, (0,[])) agedKeys
781+
liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x ->
782+
foldl' (flip HSet.insert) x garbage
783+
t <- liftIO start
784+
when (n>0) $ liftIO $ do
785+
logDebug (logger extras) $ T.pack $
786+
label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"
787+
when (coerce $ ideTesting extras) $ liftIO $ mRunLspT (lspEnv extras) $
788+
LSP.sendNotification (SCustomMethod "ghcide/GC")
789+
(toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)
790+
return garbage
791+
792+
where
793+
showKey = show . Q
794+
removeDirtyKey st@(vmap,(!counter, keys)) (k, age)
795+
| age > maxAge
796+
, Just (kt,_) <- fromKeyType k
797+
, not(kt `HSet.member` preservedKeys checkParents)
798+
, (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap
799+
= (vmap', (counter+1, k:keys))
800+
| otherwise = st
801+
802+
countRelevantKeys :: CheckParents -> [Key] -> Int
803+
countRelevantKeys checkParents =
804+
Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents) . fst) . fromKeyType)
805+
806+
preservedKeys :: CheckParents -> HashSet TypeRep
807+
preservedKeys checkParents = HSet.fromList $
808+
-- always preserved
809+
[ typeOf GetFileExists
810+
, typeOf GetModificationTime
811+
, typeOf IsFileOfInterest
812+
, typeOf GhcSessionIO
813+
, typeOf GetClientSettings
814+
, typeOf AddWatchedFile
815+
, typeOf GetKnownTargets
816+
]
817+
++ concat
818+
-- preserved if CheckParents is enabled since we need to rebuild the ModuleGraph
819+
[ [ typeOf GetModSummary
820+
, typeOf GetModSummaryWithoutTimestamps
821+
, typeOf GetLocatedImports
822+
]
823+
| checkParents /= NeverCheck
824+
]
750825

751826
-- | Define a new Rule without early cutoff
752827
define
@@ -921,8 +996,8 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
921996
v <- liftIO $ getValues state key file
922997
case v of
923998
-- No changes in the dependencies and we have
924-
-- an existing result.
925-
Just (v, diags) -> do
999+
-- an existing successful result.
1000+
Just (v@Succeeded{}, diags) -> do
9261001
when doDiagnostics $
9271002
updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags
9281003
return $ Just $ RunResult ChangedNothing old $ A v
@@ -1128,20 +1203,6 @@ getUriDiagnostics uri ds =
11281203
maybe [] getDiagnosticsFromStore $
11291204
HMap.lookup uri ds
11301205

1131-
filterDiagnostics ::
1132-
(NormalizedFilePath -> Bool) ->
1133-
DiagnosticStore ->
1134-
DiagnosticStore
1135-
filterDiagnostics keep =
1136-
HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)
1137-
1138-
filterVersionMap
1139-
:: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
1140-
-> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
1141-
-> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
1142-
filterVersionMap =
1143-
HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
1144-
11451206
updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
11461207
updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
11471208
modifyVar_ positionMapping $ \allMappings -> do

0 commit comments

Comments
 (0)