Skip to content

Commit 78ca34b

Browse files
pepeiborrapepeiborra
committed
schedule a GC on file close
1 parent e185bbc commit 78ca34b

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
@@ -375,7 +375,7 @@ defaultMain Arguments{..} = do
375375
nub $
376376
typeOf GhcSession :
377377
typeOf GhcSessionDeps :
378-
[kty | (fromKeyType -> Just kty) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++
378+
[kty | (fromKeyType -> Just (kty,_)) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++
379379
[typeOf GhcSessionIO]
380380
measureMemory logger [keys] consoleObserver valuesRef
381381

‎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
@@ -51,11 +51,9 @@ import Development.IDE.Test (Cursor,
5151
flushMessages,
5252
standardizeQuotes,
5353
waitForAction,
54-
garbageCollectDirtyKeys,
5554
getStoredKeys,
5655
waitForTypecheck,
57-
getFilesOfInterest,
58-
waitForBuildQueue)
56+
getFilesOfInterest, waitForGC)
5957
import Development.IDE.Test.Runfiles
6058
import qualified Development.IDE.Types.Diagnostics as Diagnostics
6159
import Development.IDE.Types.Location
@@ -5845,83 +5843,75 @@ unitTests = do
58455843

58465844
garbageCollectionTests :: TestTree
58475845
garbageCollectionTests = testGroup "garbage collection"
5848-
[ testGroup "dirty keys" (sharedGCtests $ garbageCollectDirtyKeys CheckOnSaveAndClose)
5849-
]
5850-
where
5851-
sharedGCtests gc =
5846+
[ testGroup "dirty keys"
58525847
[ testSession' "are collected" $ \dir -> do
58535848
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
5854-
void $ generateGarbage "A" dir
5855-
garbage <- gc 0
5849+
doc <- generateGarbage "A" dir
5850+
closeDoc doc
5851+
garbage <- waitForGC
58565852
liftIO $ assertBool "no garbage was found" $ not $ null garbage
58575853

58585854
, testSession' "are deleted from the state" $ \dir -> do
58595855
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
5860-
void $ generateGarbage "A" dir
5856+
docA <- generateGarbage "A" dir
58615857
keys0 <- getStoredKeys
5862-
garbage <- gc 0
5858+
closeDoc docA
5859+
garbage <- waitForGC
58635860
liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage
58645861
keys1 <- getStoredKeys
58655862
liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)
58665863

58675864
, testSession' "are not regenerated unless needed" $ \dir -> do
58685865
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"
5869-
void $ generateGarbage "A" dir
5866+
docA <- generateGarbage "A" dir
5867+
_docB <- generateGarbage "B" dir
58705868

5871-
reopenB <- generateGarbage "B" dir
58725869
-- garbage collect A keys
58735870
keysBeforeGC <- getStoredKeys
5874-
garbage <- gc 2
5871+
closeDoc docA
5872+
garbage <- waitForGC
58755873
liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage
58765874
keysAfterGC <- getStoredKeys
5877-
liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" (length keysAfterGC < length keysBeforeGC)
5878-
ff <- getFilesOfInterest
5879-
liftIO $ assertBool ("something is wrong with this test - files of interest is " <> show ff) (null ff)
5880-
5881-
-- typecheck B again
5882-
doc <- reopenB
5883-
void $ waitForTypecheck doc
5875+
liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state"
5876+
(length keysAfterGC < length keysBeforeGC)
58845877

5885-
-- review the keys in store now to validate that A keys have not been regenerated
5886-
keysB' <- getStoredKeys
5878+
-- re-typecheck B and check that the keys for A have not materialized back
5879+
_docB <- generateGarbage "B" dir
5880+
keysB <- getStoredKeys
58875881
let regeneratedKeys = Set.filter (not . isExpected) $
5888-
Set.intersection (Set.fromList garbage) (Set.fromList keysB')
5882+
Set.intersection (Set.fromList garbage) (Set.fromList keysB)
58895883
liftIO $ regeneratedKeys @?= mempty
58905884

58915885
, testSession' "regenerate successfully" $ \dir -> do
58925886
liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
5893-
reopenA <- generateGarbage "A" dir
5894-
garbage <- gc 0
5887+
docA <- generateGarbage "A" dir
5888+
closeDoc docA
5889+
garbage <- waitForGC
58955890
liftIO $ assertBool "no garbage was found" $ not $ null garbage
58965891
let edit = T.unlines
58975892
[ "module A where"
58985893
, "a :: Bool"
58995894
, "a = ()"
59005895
]
5901-
doc <- reopenA
5896+
doc <- generateGarbage "A" dir
59025897
changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit]
59035898
builds <- waitForTypecheck doc
59045899
liftIO $ assertBool "it still builds" builds
59055900
expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")]
59065901
]
5902+
]
5903+
where
5904+
isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"]
59075905

5908-
isExpected k = any (`isPrefixOf` k) ["GhcSessionIO"]
5909-
5910-
generateGarbage :: String -> FilePath -> Session(Session TextDocumentIdentifier)
5906+
generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier
59115907
generateGarbage modName dir = do
59125908
let fp = modName <> ".hs"
59135909
body = printf "module %s where" modName
59145910
doc <- createDoc fp "haskell" (T.pack body)
59155911
liftIO $ writeFile (dir </> fp) body
59165912
builds <- waitForTypecheck doc
59175913
liftIO $ assertBool "something is wrong with this test" builds
5918-
closeDoc doc
5919-
waitForBuildQueue
5920-
-- dirty the garbage
5921-
sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
5922-
List [FileEvent (filePathToUri $ dir </> modName <> ".hs") FcChanged ]
5923-
5924-
return $ openDoc (modName <> ".hs") "haskell"
5914+
return doc
59255915

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

0 commit comments

Comments
 (0)