Skip to content

Commit ca47c29

Browse files
pepeiborrapepeiborra
committed
garbage collection
1 parent 6a8dd53 commit ca47c29

File tree

10 files changed

+89
-40
lines changed

10 files changed

+89
-40
lines changed

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

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Development.IDE.Core.Shake
3232
import Development.IDE.Types.Exports
3333
import Development.IDE.Types.Location
3434
import Development.IDE.Types.Logger
35+
import System.Time.Extra (sleep)
3536

3637
newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
3738
instance IsIdeGlobal OfInterestVar
@@ -103,3 +104,7 @@ kick = do
103104
void $ liftIO $ modifyVar' exportsMap (exportsMap' <>)
104105

105106
liftIO $ progressUpdate progress KickCompleted
107+
108+
-- if idle, perform garbage collection
109+
liftIO $ sleep 5
110+
garbageCollectDirtyKeys

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

Lines changed: 38 additions & 26 deletions
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,
@@ -75,7 +74,7 @@ module Development.IDE.Core.Shake(
7574
HieDbWriter(..),
7675
VFSHandle(..),
7776
addPersistentRule
78-
) where
77+
,garbageCollectDirtyKeys) where
7978

8079
import Control.Concurrent.Async
8180
import Control.Concurrent.STM
@@ -109,15 +108,19 @@ import Development.IDE.Core.PositionMapping
109108
import Development.IDE.Core.ProgressReporting
110109
import Development.IDE.Core.RuleTypes
111110
import Development.IDE.Core.Tracing
112-
import Development.IDE.GHC.Compat (NameCacheUpdater (..),
113-
upNameCache, NameCache,
111+
import Development.IDE.GHC.Compat (NameCache,
112+
NameCacheUpdater (..),
114113
initNameCache,
114+
knownKeyNames,
115115
mkSplitUniqSupply,
116-
knownKeyNames)
116+
upNameCache)
117117
import Development.IDE.GHC.Orphans ()
118118
import Development.IDE.Graph hiding (ShakeValue)
119119
import qualified Development.IDE.Graph as Shake
120-
import Development.IDE.Graph.Database
120+
import Development.IDE.Graph.Database (ShakeDatabase,
121+
shakeOpenDatabase,
122+
shakeProfileDatabase,
123+
shakeRunDatabaseForKeys)
121124
import Development.IDE.Graph.Rule
122125
import Development.IDE.Types.Action
123126
import Development.IDE.Types.Diagnostics
@@ -157,6 +160,10 @@ import Ide.Plugin.Config
157160
import qualified Ide.PluginUtils as HLS
158161
import Ide.Types (PluginId)
159162

163+
-- | Maximum age (in # builds) of a cached value after which it's considered garbage
164+
garbageAge :: Int
165+
garbageAge = 100
166+
160167
-- | We need to serialize writes to the database, so we send any function that
161168
-- needs to write to the database over the channel, where it will be picked up by
162169
-- a worker thread.
@@ -325,10 +332,10 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
325332
MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
326333
case mv of
327334
Nothing -> do
328-
void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (file,Key k)
335+
void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (toKey k file)
329336
return Nothing
330337
Just (v,del,ver) -> do
331-
void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k)
338+
void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (toKey k file)
332339
return $ Just (v,addDelta del $ mappingForVersion allMappings file ver)
333340

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

342-
case HMap.lookup (file,Key k) hm of
349+
case HMap.lookup (toKey k file) hm of
343350
Nothing -> readPersistent
344351
Just (ValueWithDiagnostics v _) -> case v of
345352
Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver))
@@ -417,7 +424,7 @@ setValues :: IdeRule k v
417424
-> Vector FileDiagnostic
418425
-> IO ()
419426
setValues state key file val diags =
420-
void $ modifyVar' state $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags)
427+
void $ modifyVar' state $ HMap.insert (toKey key file) (ValueWithDiagnostics (fmap toDyn val) diags)
421428

422429

423430
-- | Delete the value stored for a given ide build key
@@ -428,7 +435,7 @@ deleteValue
428435
-> NormalizedFilePath
429436
-> IO ()
430437
deleteValue ShakeExtras{dirtyKeys, state} key file = do
431-
void $ modifyVar' state $ HMap.delete (file, Key key)
438+
void $ modifyVar' state $ HMap.delete (toKey key file)
432439
atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file)
433440

434441
recordDirtyKeys
@@ -450,7 +457,7 @@ getValues ::
450457
IO (Maybe (Value v, Vector FileDiagnostic))
451458
getValues state key file = do
452459
vs <- readVar state
453-
case HMap.lookup (file, Key key) vs of
460+
case HMap.lookup (toKey key file) vs of
454461
Nothing -> pure Nothing
455462
Just (ValueWithDiagnostics v diagsV) -> do
456463
let r = fmap (fromJust . fromDynamic @v) v
@@ -727,20 +734,25 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
727734
val <- readVar hiddenDiagnostics
728735
return $ getAllDiagnostics val
729736

730-
-- | Clear the results for all files that do not match the given predicate.
731-
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
732-
garbageCollect keep = do
733-
ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
734-
liftIO $
735-
do newState <- modifyVar' state $ HMap.filterWithKey (\(file, _) _ -> keep file)
736-
void $ modifyVar' diagnostics $ filterDiagnostics keep
737-
void $ modifyVar' hiddenDiagnostics $ filterDiagnostics keep
738-
void $ modifyVar' publishedDiagnostics $ HMap.filterWithKey (\uri _ -> keep (fromUri uri))
739-
let versionsForFile =
740-
HMap.fromListWith Set.union $
741-
mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
742-
HMap.toList newState
743-
void $ modifyVar' positionMapping $ filterVersionMap versionsForFile
737+
garbageCollectDirtyKeys :: Action ()
738+
garbageCollectDirtyKeys = do
739+
start <- liftIO offsetTime
740+
dirtySet <- fromMaybe [] <$> getDirtySet
741+
extras <- getShakeExtras
742+
(n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap ->
743+
evaluate $ foldl' removeDirtyKey (vmap, (0,[])) dirtySet
744+
liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x ->
745+
foldl' (flip HSet.insert) x garbage
746+
t <- liftIO start
747+
when (n>0) $ liftIO $ logDebug (logger extras) $ T.pack $
748+
"Garbage collected " <> show n <> " keys (took " <> showDuration t <> ")"
749+
where
750+
-- removeDirtyKey :: (Values, Int) -> (Key, Int) -> (Values, [Key], Int)
751+
removeDirtyKey (vmap,(counter, keys)) (k, age)
752+
| age > garbageAge
753+
, (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap
754+
= let !c' = counter+1 in (vmap', (c', k:keys))
755+
| otherwise = (vmap, (counter, keys))
744756

745757
-- | Define a new Rule without early cutoff
746758
define

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

Lines changed: 10 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE CPP #-}
22
{-# LANGUAGE NoApplicativeDo #-}
3+
{-# HLINT ignore #-}
34
module Development.IDE.Core.Tracing
45
( otTracedHandler
56
, otTracedAction
@@ -151,12 +152,14 @@ performMeasurement logger stateRef instrumentFor mapCountInstrument = do
151152
values <- readVar stateRef
152153
let keys = Key GhcSession
153154
: Key GhcSessionDeps
154-
: [ k | (_,k) <- HMap.keys values
155-
-- do GhcSessionIO last since it closes over stateRef itself
156-
, k /= Key GhcSession
157-
, k /= Key GhcSessionDeps
158-
, k /= Key GhcSessionIO
159-
] ++ [Key GhcSessionIO]
155+
-- TODO restore
156+
-- : [ k | (_,k) <- HMap.keys values
157+
-- -- do GhcSessionIO last since it closes over stateRef itself
158+
-- , k /= Key GhcSession
159+
-- , k /= Key GhcSessionDeps
160+
-- , k /= Key GhcSessionIO
161+
-- ]
162+
: [Key GhcSessionIO]
160163
groupedForSharing <- evaluate (keys `using` seqList r0)
161164
measureMemory logger [groupedForSharing] instrumentFor stateRef
162165
`catch` \(e::SomeException) ->
@@ -228,7 +231,7 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory"
228231
let !groupedValues =
229232
[ [ (k, vv)
230233
| k <- groupKeys
231-
, let vv = [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k']
234+
, let vv = [] -- [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k']
232235
]
233236
| groupKeys <- groups
234237
]

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -356,8 +356,9 @@ defaultMain Arguments{..} = do
356356
nub $
357357
Key GhcSession :
358358
Key GhcSessionDeps :
359-
[k | (_, k) <- HashMap.keys values, k /= Key GhcSessionIO]
360-
++ [Key GhcSessionIO]
359+
-- TODO restore
360+
-- [fromKey k | k <- HashMap.keys values, k /= Key GhcSessionIO] ++
361+
[Key GhcSessionIO]
361362
measureMemory logger [keys] consoleObserver valuesRef
362363

363364
unless (null failed) (exitWith $ ExitFailure (length failed))

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -49,7 +49,7 @@ data ValueWithDiagnostics
4949
= ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic)
5050

5151
-- | The state of the all values and diagnostics
52-
type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics
52+
type Values = HashMap Key ValueWithDiagnostics
5353

5454
-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
5555
-- which short-circuits the rest of the action

‎hls-graph/src/Development/IDE/Graph.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,8 @@ module Development.IDE.Graph(
1717
alwaysRerun,
1818
-- * Batching
1919
reschedule,
20+
-- * Dirty keys
21+
getDirtySet,
2022
) where
2123

2224
import Development.IDE.Graph.Database

‎hls-graph/src/Development/IDE/Graph/Database.hs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,8 @@ module Development.IDE.Graph.Database(
88
shakeRunDatabase,
99
shakeRunDatabaseForKeys,
1010
shakeProfileDatabase,
11-
shakeLastBuildKeys) where
11+
shakeGetDirtySet
12+
) where
1213

1314
import Data.Dynamic
1415
import Data.Maybe
@@ -42,6 +43,9 @@ shakeRunDatabase = shakeRunDatabaseForKeys Nothing
4243
shakeLastBuildKeys :: ShakeDatabase -> IO [Key]
4344
shakeLastBuildKeys (ShakeDatabase _ _ db) = getLastBuildKeys db
4445

46+
-- | Returns the set of dirty keys annotated with their age (in # of builds)
47+
shakeGetDirtySet :: ShakeDatabase -> IO (Maybe [(Key, Int)])
48+
shakeGetDirtySet (ShakeDatabase _ _ db) = Development.IDE.Graph.Internal.Database.getDirtySet db
4549

4650
-- Only valid if we never pull on the results, which we don't
4751
unvoid :: Functor m => m () -> m a

‎hls-graph/src/Development/IDE/Graph/Internal/Action.hs‎

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
1+
{-# LANGUAGE ConstraintKinds #-}
12
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
23
{-# LANGUAGE ScopedTypeVariables #-}
34
{-# LANGUAGE TypeFamilies #-}
4-
{-# LANGUAGE ConstraintKinds #-}
55

66
module Development.IDE.Graph.Internal.Action
77
( ShakeValue
@@ -15,6 +15,7 @@ module Development.IDE.Graph.Internal.Action
1515
, parallel
1616
, reschedule
1717
, runActions
18+
, Development.IDE.Graph.Internal.Action.getDirtySet
1819
) where
1920

2021
import Control.Concurrent.Async
@@ -26,9 +27,9 @@ import Control.Monad.Trans.Reader
2627
import Data.IORef
2728
import Development.IDE.Graph.Classes
2829
import Development.IDE.Graph.Internal.Database
30+
import Development.IDE.Graph.Internal.Rules (RuleResult)
2931
import Development.IDE.Graph.Internal.Types
3032
import System.Exit
31-
import Development.IDE.Graph.Internal.Rules (RuleResult)
3233

3334
type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
3435

@@ -125,3 +126,9 @@ runActions :: Database -> [Action a] -> IO [a]
125126
runActions db xs = do
126127
deps <- newIORef Nothing
127128
runReaderT (fromAction $ parallel xs) $ SAction db deps
129+
130+
-- | Returns the set of dirty keys annotated with their age (in # of builds)
131+
getDirtySet :: Action (Maybe [(Key, Int)])
132+
getDirtySet = do
133+
db <- getDatabase
134+
liftIO $ Development.IDE.Graph.Internal.Database.getDirtySet db

‎hls-graph/src/Development/IDE/Graph/Internal/Database.hs‎

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,12 +11,13 @@
1111
{-# LANGUAGE TupleSections #-}
1212
{-# LANGUAGE TypeFamilies #-}
1313

14-
module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build) where
14+
module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build,getDirtySet) where
1515

1616
import Control.Concurrent.Async
1717
import Control.Concurrent.Extra
1818
import Control.Exception
1919
import Control.Monad
20+
import Control.Monad.Extra (mapMaybeM)
2021
import Control.Monad.IO.Class (MonadIO (liftIO))
2122
import Control.Monad.Trans.Class (lift)
2223
import Control.Monad.Trans.Reader
@@ -30,6 +31,7 @@ import qualified Data.IntSet as Set
3031
import Data.Maybe
3132
import Data.Tuple.Extra
3233
import Development.IDE.Graph.Classes
34+
import qualified Development.IDE.Graph.Internal.Ids as Id
3335
import qualified Development.IDE.Graph.Internal.Ids as Ids
3436
import Development.IDE.Graph.Internal.Intern
3537
import qualified Development.IDE.Graph.Internal.Intern as Intern
@@ -182,6 +184,16 @@ compute db@Database{..} key id mode result = do
182184
Ids.insert databaseValues id (key, Clean res)
183185
pure res
184186

187+
-- | Returns the set of dirty keys annotated with their age (in # of builds)
188+
getDirtySet :: Database -> IO (Maybe [(Key, Int)])
189+
getDirtySet db = do
190+
dirtySet <- readIORef (databaseDirtySet db)
191+
Step curr <- readIORef (databaseStep db)
192+
let idToKey = fmap (secondM calcAgeStatus =<<)
193+
. Id.lookup (databaseValues db)
194+
calcAge Result{resultBuilt = Step x} = curr - x
195+
calcAgeStatus = fmap calcAge . getResult
196+
mapMaybeM idToKey `traverse` (Set.toList <$> dirtySet)
185197
--------------------------------------------------------------------------------
186198
-- Lazy IO trick
187199

‎hls-graph/src/Development/IDE/Graph/Internal/Types.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Development.IDE.Graph.Internal.Types where
1010
import Control.Applicative
1111
import Control.Concurrent.Extra
1212
import Control.Monad.Catch
13+
-- Needed in GHC 8.6.5
1314
import Control.Monad.Fail
1415
import Control.Monad.IO.Class
1516
import Control.Monad.Trans.Reader
@@ -57,6 +58,8 @@ data SAction = SAction {
5758
actionDeps :: !(IORef (Maybe [Id])) -- Nothing means always rerun
5859
}
5960

61+
getDatabase :: Action Database
62+
getDatabase = Action $ asks actionDatabase
6063

6164
---------------------------------------------------------------------
6265
-- DATABASE

0 commit comments

Comments
 (0)