Skip to content

Commit 3d879a3

Browse files
pepeiborrapepeiborra
committed
schedule a GC on file close
1 parent 824b5fe commit 3d879a3

File tree

11 files changed

+98
-79
lines changed

11 files changed

+98
-79
lines changed

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

Lines changed: 3 additions & 3 deletions
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"

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

Lines changed: 14 additions & 5 deletions
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
@@ -33,7 +33,6 @@ import Development.IDE.Core.Shake
3333
import Development.IDE.Types.Exports
3434
import Development.IDE.Types.Location
3535
import Development.IDE.Types.Logger
36-
import System.Time.Extra (sleep)
3736

3837
newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
3938
instance IsIdeGlobal OfInterestVar
@@ -42,6 +41,7 @@ instance IsIdeGlobal OfInterestVar
4241
ofInterestRules :: Rules ()
4342
ofInterestRules = do
4443
addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)
44+
addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False)
4545
defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do
4646
alwaysRerun
4747
filesOfInterest <- getFilesOfInterestUntracked
@@ -55,6 +55,9 @@ ofInterestRules = do
5555
summarize (IsFOI (Modified False)) = BS.singleton 2
5656
summarize (IsFOI (Modified True)) = BS.singleton 3
5757

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

5962
------------------------------------------------------------
6063
-- Exposed API
@@ -94,6 +97,10 @@ deleteFileOfInterest state f = do
9497
recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
9598
logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
9699

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

98105
-- | Typecheck all the files of interest.
99106
-- Could be improved
@@ -111,6 +118,8 @@ kick = do
111118

112119
liftIO $ progressUpdate progress KickCompleted
113120

114-
-- if idle, perform garbage collection of dirty keys
115-
liftIO $ sleep 5
116-
void garbageCollectDirtyKeys
121+
GarbageCollectVar var <- getIdeGlobalAction
122+
garbageCollectionScheduled <- liftIO $ readVar var
123+
when garbageCollectionScheduled $ do
124+
void garbageCollectDirtyKeys
125+
liftIO $ writeVar var False

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

Lines changed: 13 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -148,7 +148,9 @@ import Language.LSP.Types.Capabilities
148148
import OpenTelemetry.Eventlog
149149

150150
import Control.Exception.Extra hiding (bracket_)
151+
import Data.Aeson (toJSON)
151152
import qualified Data.ByteString.Char8 as BS8
153+
import Data.Coerce (coerce)
152154
import Data.Default
153155
import Data.Foldable (toList)
154156
import Data.HashSet (HashSet)
@@ -761,9 +763,9 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
761763
-- * exports map
762764
garbageCollectDirtyKeys :: Action [Key]
763765
garbageCollectDirtyKeys = do
764-
IdeOptions{optCheckParents, optMaxDirtyAge} <- getIdeOptions
766+
IdeOptions{optCheckParents} <- getIdeOptions
765767
checkParents <- liftIO optCheckParents
766-
garbageCollectDirtyKeysOlderThan optMaxDirtyAge checkParents
768+
garbageCollectDirtyKeysOlderThan 0 checkParents
767769

768770
garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key]
769771
garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do
@@ -779,22 +781,27 @@ garbageCollectKeys label maxAge checkParents agedKeys = do
779781
liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x ->
780782
foldl' (flip HSet.insert) x garbage
781783
t <- liftIO start
782-
when (n>0) $ liftIO $ logDebug (logger extras) $ T.pack $
783-
label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"
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)
784790
return garbage
785791

786792
where
793+
showKey = show . Q
787794
removeDirtyKey st@(vmap,(!counter, keys)) (k, age)
788795
| age > maxAge
789-
, Just kt <- fromKeyType k
796+
, Just (kt,_) <- fromKeyType k
790797
, not(kt `HSet.member` preservedKeys checkParents)
791798
, (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap
792799
= (vmap', (counter+1, k:keys))
793800
| otherwise = st
794801

795802
countRelevantKeys :: CheckParents -> [Key] -> Int
796803
countRelevantKeys checkParents =
797-
Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents)) . fromKeyType)
804+
Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents) . fst) . fromKeyType)
798805

799806
preservedKeys :: CheckParents -> HashSet TypeRep
800807
preservedKeys checkParents = HSet.fromList $

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -187,7 +187,7 @@ performMeasurement logger stateRef instrumentFor = do
187187
-- TODO restore
188188
: [ kty
189189
| k <- HMap.keys values
190-
, Just kty <- [fromKeyType k]
190+
, Just (kty,_) <- [fromKeyType k]
191191
-- do GhcSessionIO last since it closes over stateRef itself
192192
, kty /= typeOf GhcSession
193193
, kty /= typeOf GhcSessionDeps
@@ -265,7 +265,7 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory"
265265
let !groupedValues =
266266
[ [ (show ty, vv)
267267
| ty <- groupKeys
268-
, let vv = [ v | (fromKeyType -> Just kty, ValueWithDiagnostics v _) <- HMap.toList values
268+
, let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- HMap.toList values
269269
, kty == ty]
270270
]
271271
| groupKeys <- groups

‎ghcide/src/Development/IDE/LSP/Notifications.hs‎

Lines changed: 12 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -14,30 +14,25 @@ module Development.IDE.LSP.Notifications
1414
import Language.LSP.Types
1515
import qualified Language.LSP.Types as LSP
1616

17-
import Development.IDE.Core.IdeConfiguration
18-
import Development.IDE.Core.Service
19-
import Development.IDE.Core.Shake
20-
import Development.IDE.Types.Location
21-
import Development.IDE.Types.Logger
22-
import Development.IDE.Types.Options
23-
2417
import Control.Monad.Extra
25-
import qualified Data.HashSet as S
26-
import qualified Data.Text as Text
27-
2818
import Control.Monad.IO.Class
2919
import qualified Data.HashMap.Strict as HM
20+
import qualified Data.HashSet as S
21+
import qualified Data.Text as Text
3022
import Development.IDE.Core.FileExists (modifyFileExists,
3123
watchedGlobs)
3224
import Development.IDE.Core.FileStore (registerFileWatches,
3325
resetFileStore,
3426
setFileModified,
35-
setSomethingModified,
36-
typecheckParents)
27+
setSomethingModified)
28+
import Development.IDE.Core.IdeConfiguration
3729
import Development.IDE.Core.OfInterest
3830
import Development.IDE.Core.RuleTypes (GetClientSettings (..))
31+
import Development.IDE.Core.Service
32+
import Development.IDE.Core.Shake
33+
import Development.IDE.Types.Location
34+
import Development.IDE.Types.Logger
3935
import Development.IDE.Types.Shake (toKey)
40-
import Ide.Plugin.Config (CheckParents (CheckOnClose))
4136
import Ide.Types
4237

4338
whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
@@ -74,10 +69,10 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers =
7469
\ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do
7570
whenUriFile _uri $ \file -> do
7671
deleteFileOfInterest ide file
77-
-- Refresh all the files that depended on this
78-
checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide)
79-
when (checkParents >= CheckOnClose) $ typecheckParents ide file
80-
logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri
72+
let msg = "Closed text document: " <> getUri _uri
73+
scheduleGarbageCollection ide
74+
setSomethingModified ide [] $ Text.unpack msg
75+
logDebug (ideLogger ide) msg
8176

8277
, mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $
8378
\ide _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do

‎ghcide/src/Development/IDE/Main.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -379,7 +379,7 @@ defaultMain Arguments{..} = do
379379
nub $
380380
typeOf GhcSession :
381381
typeOf GhcSessionDeps :
382-
[kty | (fromKeyType -> Just kty) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++
382+
[kty | (fromKeyType -> Just (kty,_)) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++
383383
[typeOf GhcSessionIO]
384384
measureMemory logger [keys] consoleObserver valuesRef
385385

‎ghcide/src/Development/IDE/Types/Options.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -139,7 +139,7 @@ defaultIdeOptions session = IdeOptions
139139
,optDefer = IdeDefer True
140140
,optTesting = IdeTesting False
141141
,optCheckProject = pure True
142-
,optCheckParents = pure CheckOnSaveAndClose
142+
,optCheckParents = pure CheckOnSave
143143
,optHaddockParse = HaddockParse
144144
,optModifyDynFlags = mempty
145145
,optSkipProgress = defaultSkipProgress

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

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ import Type.Reflection (SomeTypeRep (SomeTypeRep)
3535
pattern App, pattern Con,
3636
typeOf, typeRep,
3737
typeRepTyCon)
38+
import Unsafe.Coerce (unsafeCoerce)
3839

3940
data Value v
4041
= Succeeded TextDocumentVersion v
@@ -75,11 +76,12 @@ fromKey (Key k)
7576
| Just (Q (k', f)) <- cast k = Just (k', f)
7677
| otherwise = Nothing
7778

78-
-- | fromKeyType (Q a) = typeOf a
79-
fromKeyType :: Key -> Maybe SomeTypeRep
79+
-- | fromKeyType (Q (k,f)) = (typeOf k, f)
80+
fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath)
8081
fromKeyType (Key k) = case typeOf k of
8182
App (Con tc) a | tc == typeRepTyCon (typeRep @Q)
82-
-> Just $ SomeTypeRep a
83+
-> case unsafeCoerce k of
84+
Q (_ :: (), f) -> Just (SomeTypeRep a, f)
8385
_ -> Nothing
8486

8587
toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key

‎ghcide/test/exe/Main.hs‎

Lines changed: 27 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -52,11 +52,9 @@ import Development.IDE.Test (Cursor,
5252
standardizeQuotes,
5353
getInterfaceFilesDir
5454
waitForAction,
55-
garbageCollectDirtyKeys,
5655
getStoredKeys,
5756
waitForTypecheck,
58-
getFilesOfInterest,
59-
waitForBuildQueue)
57+
getFilesOfInterest, waitForGC)
6058
import Development.IDE.Test.Runfiles
6159
import qualified Development.IDE.Types.Diagnostics as Diagnostics
6260
import Development.IDE.Types.Location
@@ -5841,83 +5839,75 @@ unitTests = do
58415839

58425840
garbageCollectionTests :: TestTree
58435841
garbageCollectionTests = testGroup "garbage collection"
5844-
[ testGroup "dirty keys" (sharedGCtests $ garbageCollectDirtyKeys CheckOnSaveAndClose)
5845-
]
5846-
where
5847-
sharedGCtests gc =
5842+
[ testGroup "dirty keys"
58485843
[ testSession' "are collected" $ \dir -> do
58495844
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
5850-
void $ generateGarbage "A" dir
5851-
garbage <- gc 0
5845+
doc <- generateGarbage "A" dir
5846+
closeDoc doc
5847+
garbage <- waitForGC
58525848
liftIO $ assertBool "no garbage was found" $ not $ null garbage
58535849

58545850
, testSession' "are deleted from the state" $ \dir -> do
58555851
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
5856-
void $ generateGarbage "A" dir
5852+
docA <- generateGarbage "A" dir
58575853
keys0 <- getStoredKeys
5858-
garbage <- gc 0
5854+
closeDoc docA
5855+
garbage <- waitForGC
58595856
liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage
58605857
keys1 <- getStoredKeys
58615858
liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)
58625859

58635860
, testSession' "are not regenerated unless needed" $ \dir -> do
58645861
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"
5865-
void $ generateGarbage "A" dir
5862+
docA <- generateGarbage "A" dir
5863+
_docB <- generateGarbage "B" dir
58665864

5867-
reopenB <- generateGarbage "B" dir
58685865
-- garbage collect A keys
58695866
keysBeforeGC <- getStoredKeys
5870-
garbage <- gc 2
5867+
closeDoc docA
5868+
garbage <- waitForGC
58715869
liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage
58725870
keysAfterGC <- getStoredKeys
5873-
liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" (length keysAfterGC < length keysBeforeGC)
5874-
ff <- getFilesOfInterest
5875-
liftIO $ assertBool ("something is wrong with this test - files of interest is " <> show ff) (null ff)
5876-
5877-
-- typecheck B again
5878-
doc <- reopenB
5879-
void $ waitForTypecheck doc
5871+
liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state"
5872+
(length keysAfterGC < length keysBeforeGC)
58805873

5881-
-- review the keys in store now to validate that A keys have not been regenerated
5882-
keysB' <- getStoredKeys
5874+
-- re-typecheck B and check that the keys for A have not materialized back
5875+
_docB <- generateGarbage "B" dir
5876+
keysB <- getStoredKeys
58835877
let regeneratedKeys = Set.filter (not . isExpected) $
5884-
Set.intersection (Set.fromList garbage) (Set.fromList keysB')
5878+
Set.intersection (Set.fromList garbage) (Set.fromList keysB)
58855879
liftIO $ regeneratedKeys @?= mempty
58865880

58875881
, testSession' "regenerate successfully" $ \dir -> do
58885882
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
5889-
reopenA <- generateGarbage "A" dir
5890-
garbage <- gc 0
5883+
docA <- generateGarbage "A" dir
5884+
closeDoc docA
5885+
garbage <- waitForGC
58915886
liftIO $ assertBool "no garbage was found" $ not $ null garbage
58925887
let edit = T.unlines
58935888
[ "module A where"
58945889
, "a :: Bool"
58955890
, "a = ()"
58965891
]
5897-
doc <- reopenA
5892+
doc <- generateGarbage "A" dir
58985893
changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit]
58995894
builds <- waitForTypecheck doc
59005895
liftIO $ assertBool "it still builds" builds
59015896
expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")]
59025897
]
5898+
]
5899+
where
5900+
isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"]
59035901

5904-
isExpected k = any (`isPrefixOf` k) ["GhcSessionIO"]
5905-
5906-
generateGarbage :: String -> FilePath -> Session(Session TextDocumentIdentifier)
5902+
generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier
59075903
generateGarbage modName dir = do
59085904
let fp = modName <> ".hs"
59095905
body = printf "module %s where" modName
59105906
doc <- createDoc fp "haskell" (T.pack body)
59115907
liftIO $ writeFile (dir </> fp) body
59125908
builds <- waitForTypecheck doc
59135909
liftIO $ assertBool "something is wrong with this test" builds
5914-
closeDoc doc
5915-
waitForBuildQueue
5916-
-- dirty the garbage
5917-
sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
5918-
List [FileEvent (filePathToUri $ dir </> modName <> ".hs") FcChanged ]
5919-
5920-
return $ openDoc (modName <> ".hs") "haskell"
5910+
return doc
59215911

59225912
findResolution_us :: Int -> IO Int
59235913
findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"

0 commit comments

Comments
 (0)