Skip to content

Commit fd36e18

Browse files
pepeiborrapepeiborra
committed
exclude certain keys from GC
exclude certain keys from GC
1 parent 0ef4e25 commit fd36e18

File tree

4 files changed

+56
-27
lines changed

4 files changed

+56
-27
lines changed

‎ghcide/src/Development/IDE/Core/Shake.hs

Lines changed: 42 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -549,14 +549,16 @@ shakeOpen lspEnv defaultConfig logger debouncer
549549
return ideState
550550

551551
startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ())
552-
startTelemetry db ShakeExtras{..}
552+
startTelemetry db extras@ShakeExtras{..}
553553
| userTracingEnabled = do
554554
countKeys <- mkValueObserver "cached keys count"
555555
countDirty <- mkValueObserver "dirty keys count"
556556
countBuilds <- mkValueObserver "builds count"
557+
IdeOptions{optCheckParents} <- getIdeOptionsIO extras
558+
checkParents <- optCheckParents
557559
regularly 1 $ do
558-
readVar state >>= observe countKeys . Prelude.length
559-
readIORef dirtyKeys >>= observe countDirty . Prelude.length
560+
readVar state >>= observe countKeys . countRelevantKeys checkParents . HMap.keys
561+
readIORef dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList
560562
shakeGetBuildStep db >>= observe countBuilds
561563

562564
| otherwise = async (pure ())
@@ -759,26 +761,28 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
759761
-- * exports map
760762
garbageCollectDirtyKeys :: Action [Key]
761763
garbageCollectDirtyKeys = do
762-
IdeOptions{optMaxDirtyAge} <- getIdeOptions
763-
garbageCollectDirtyKeysOlderThan optMaxDirtyAge
764+
IdeOptions{optCheckParents, optMaxDirtyAge} <- getIdeOptions
765+
checkParents <- liftIO optCheckParents
766+
garbageCollectDirtyKeysOlderThan optMaxDirtyAge checkParents
764767

765768
garbageCollectKeysNotVisited :: Action [Key]
766769
garbageCollectKeysNotVisited = do
767-
IdeOptions{optMaxDirtyAge} <- getIdeOptions
768-
garbageCollectKeysNotVisitedFor optMaxDirtyAge
770+
IdeOptions{optCheckParents, optMaxDirtyAge} <- getIdeOptions
771+
checkParents <- liftIO optCheckParents
772+
garbageCollectKeysNotVisitedFor optMaxDirtyAge checkParents
769773

770-
garbageCollectDirtyKeysOlderThan :: Int -> Action [Key]
771-
garbageCollectDirtyKeysOlderThan maxAge = otTracedGarbageCollection "dirty GC" $ do
774+
garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key]
775+
garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do
772776
dirtySet <- fromMaybe [] <$> getDirtySet
773-
garbageCollectKeys "dirty GC" maxAge dirtySet
777+
garbageCollectKeys "dirty GC" maxAge checkParents dirtySet
774778

775-
garbageCollectKeysNotVisitedFor :: Int -> Action [Key]
776-
garbageCollectKeysNotVisitedFor maxAge = otTracedGarbageCollection "not visited GC" $ do
779+
garbageCollectKeysNotVisitedFor :: Int -> CheckParents -> Action [Key]
780+
garbageCollectKeysNotVisitedFor maxAge checkParents = otTracedGarbageCollection "not visited GC" $ do
777781
keys <- getKeysAndVisitedAge
778-
garbageCollectKeys "not visited GC" maxAge keys
782+
garbageCollectKeys "not visited GC" maxAge checkParents keys
779783

780-
garbageCollectKeys :: String -> Int -> [(Key, Int)] -> Action [Key]
781-
garbageCollectKeys label maxAge agedKeys = do
784+
garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
785+
garbageCollectKeys label maxAge checkParents agedKeys = do
782786
start <- liftIO offsetTime
783787
extras <- getShakeExtras
784788
(n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap ->
@@ -793,10 +797,33 @@ garbageCollectKeys label maxAge agedKeys = do
793797
where
794798
removeDirtyKey st@(vmap,(!counter, keys)) (k, age)
795799
| age > maxAge
800+
, fromKeyType k `notElem` preservedKeys checkParents
796801
, (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap
797802
= (vmap', (counter+1, k:keys))
798803
| otherwise = st
799804

805+
countRelevantKeys :: CheckParents -> [Key] -> Int
806+
countRelevantKeys checkParents =
807+
Prelude.length . filter ((`notElem` preservedKeys checkParents) . fromKeyType)
808+
809+
preservedKeys :: CheckParents -> [Maybe TypeRep]
810+
preservedKeys checkParents = map Just $
811+
-- always preserved
812+
[ typeOf GetFileExists
813+
, typeOf GetModificationTime
814+
, typeOf GhcSessionIO
815+
, typeOf GetClientSettings
816+
, typeOf AddWatchedFile
817+
]
818+
++ concat
819+
-- preserved if CheckParents is enabled since we need to rebuild the ModuleGraph
820+
[ [ typeOf GetModSummary
821+
, typeOf GetModSummaryWithoutTimestamps
822+
, typeOf GetLocatedImports
823+
]
824+
| checkParents /= NeverCheck
825+
]
826+
800827
-- | Define a new Rule without early cutoff
801828
define
802829
:: IdeRule k v

‎ghcide/src/Development/IDE/Plugin/Test.hs

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ import Development.IDE.Types.Action
3434
import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
3535
import Development.IDE.Types.Location (fromUri)
3636
import GHC.Generics (Generic)
37+
import Ide.Plugin.Config (CheckParents)
3738
import Ide.Types
3839
import qualified Language.LSP.Server as LSP
3940
import Language.LSP.Types
@@ -46,8 +47,8 @@ data TestRequest
4647
| GetShakeSessionQueueCount -- ^ :: Number
4748
| WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
4849
| WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult
49-
| GarbageCollectDirtyKeys Age -- ^ :: [String] (list of keys collected)
50-
| GarbageCollectNotVisitedKeys Age -- ^ :: [String]
50+
| GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected)
51+
| GarbageCollectNotVisitedKeys CheckParents Age -- ^ :: [String]
5152
| GetStoredKeys -- ^ :: [String] (list of keys in store)
5253
| GetFilesOfInterest -- ^ :: [FilePath]
5354
deriving Generic
@@ -96,11 +97,11 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do
9697
success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
9798
let res = WaitForIdeRuleResult <$> success
9899
return $ bimap mkResponseError toJSON res
99-
testRequestHandler s (GarbageCollectDirtyKeys age) = do
100-
res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age
100+
testRequestHandler s (GarbageCollectDirtyKeys parents age) = do
101+
res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents
101102
return $ Right $ toJSON $ map show res
102-
testRequestHandler s (GarbageCollectNotVisitedKeys age) = do
103-
res <- liftIO $ runAction "garbage collect not visited" s $ garbageCollectKeysNotVisitedFor age
103+
testRequestHandler s (GarbageCollectNotVisitedKeys parents age) = do
104+
res <- liftIO $ runAction "garbage collect not visited" s $ garbageCollectKeysNotVisitedFor age parents
104105
return $ Right $ toJSON $ map show res
105106
testRequestHandler s GetStoredKeys = do
106107
keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s)

‎ghcide/test/exe/Main.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -5846,8 +5846,8 @@ unitTests = do
58465846

58475847
garbageCollectionTests :: TestTree
58485848
garbageCollectionTests = testGroup "garbage collection"
5849-
[ testGroup "dirty keys" (sharedGCtests garbageCollectDirtyKeys)
5850-
, testGroup "unvisited keys" (sharedGCtests garbageCollectNotVisitedKeys)
5849+
[ testGroup "dirty keys" (sharedGCtests $ garbageCollectDirtyKeys CheckOnSaveAndClose)
5850+
, testGroup "unvisited keys" (sharedGCtests $ garbageCollectNotVisitedKeys CheckOnSaveAndClose)
58515851
]
58525852
where
58535853
sharedGCtests gc =

‎ghcide/test/src/Development/IDE/Test.hs

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ import Development.IDE.Plugin.Test (TestRequest (..),
4141
WaitForIdeRuleResult,
4242
ideResultSuccess)
4343
import Development.IDE.Test.Diagnostic
44+
import Ide.Plugin.Config (CheckParents)
4445
import Language.LSP.Test hiding (message)
4546
import qualified Language.LSP.Test as LspTest
4647
import Language.LSP.Types hiding
@@ -190,11 +191,11 @@ callTestPlugin cmd = do
190191
waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult
191192
waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri)
192193

193-
garbageCollectDirtyKeys :: Int -> Session [String]
194-
garbageCollectDirtyKeys age = callTestPlugin (GarbageCollectDirtyKeys age)
194+
garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String]
195+
garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age)
195196

196-
garbageCollectNotVisitedKeys :: Int -> Session [String]
197-
garbageCollectNotVisitedKeys age = callTestPlugin (GarbageCollectNotVisitedKeys age)
197+
garbageCollectNotVisitedKeys :: CheckParents -> Int -> Session [String]
198+
garbageCollectNotVisitedKeys parents age = callTestPlugin (GarbageCollectNotVisitedKeys parents age)
198199

199200
getStoredKeys :: Session [String]
200201
getStoredKeys = callTestPlugin GetStoredKeys

0 commit comments

Comments
 (0)