Skip to content

Commit e5d8deb

Browse files
pepeiborrapepeiborra
committed
implement reverse deps
1 parent 7c7ba1c commit e5d8deb

File tree

3 files changed

+138
-44
lines changed

3 files changed

+138
-44
lines changed

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

Lines changed: 20 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -13,11 +13,14 @@ module Development.IDE.Graph.Database(
1313

1414
import Control.Concurrent.Extra
1515
import Data.Dynamic
16+
import qualified Data.HashSet as HashSet
17+
import Data.IORef (readIORef)
1618
import Data.Maybe
1719
import Data.Typeable (cast)
1820
import Development.IDE.Graph.Classes
1921
import Development.IDE.Graph.Internal.Action
2022
import Development.IDE.Graph.Internal.Database
23+
import qualified Development.IDE.Graph.Internal.Intern as Intern
2124
import Development.IDE.Graph.Internal.Options
2225
import Development.IDE.Graph.Internal.Rules
2326
import Development.IDE.Graph.Internal.Types
@@ -41,10 +44,7 @@ shakeNewDatabase opts rules = do
4144
pure $ ShakeDatabase threads (length actions) actions db
4245

4346
shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
44-
shakeRunDatabase (ShakeDatabase threads lenAs1 as1 db) as2 = withNumCapabilities threads $ do
45-
incDatabase db
46-
as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2
47-
return (as, [])
47+
shakeRunDatabase = shakeRunDatabaseForKeys Nothing
4848

4949
-- Only valid if we never pull on the results, which we don't
5050
unvoid :: Functor m => m () -> m a
@@ -67,7 +67,19 @@ shakeRunDatabaseForKeys
6767
-> ShakeDatabase
6868
-> [Action a]
6969
-> IO ([a], [IO ()])
70-
shakeRunDatabaseForKeys _keys a b =
71-
-- Shake upstream does not accept the set of keys changed yet
72-
-- https://github.com/ndmitchell/shake/pull/802
73-
shakeRunDatabase a b
70+
shakeRunDatabaseForKeys keysChanged (ShakeDatabase threads lenAs1 as1 db) as2 = withNumCapabilities threads $ do
71+
incDatabase db
72+
flushDirty db
73+
-- record the keys changed
74+
db <- case keysChanged of
75+
Just kk -> do
76+
intern <- readIORef (databaseIds db)
77+
let ids = mapMaybe (\(SomeShakeValue x) -> Intern.lookup (Key x) intern) kk
78+
markDirty db $ HashSet.fromList ids
79+
updateDirtySet db
80+
pure db
81+
Nothing -> do
82+
-- disable reverse deps for this run
83+
pure db{databaseReverseDeps = (databaseReverseDeps db){reverseDepsAllDirty = True} }
84+
as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2
85+
return (as, [])

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

Lines changed: 81 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -14,9 +14,13 @@ import Control.Concurrent.Async
1414
import Control.Concurrent.Extra
1515
import Control.Exception
1616
import Control.Monad
17+
import Control.Monad.Trans.Class (lift)
1718
import Control.Monad.Trans.Reader
19+
import qualified Control.Monad.Trans.State.Strict as State
1820
import Data.Dynamic
1921
import Data.Either
22+
import Data.Foldable (traverse_)
23+
import qualified Data.HashSet as HSet
2024
import Data.IORef.Extra
2125
import Data.Maybe
2226
import Data.Tuple.Extra
@@ -36,6 +40,11 @@ newDatabase databaseExtra databaseRules = do
3640
databaseLock <- newLock
3741
databaseIds <- newIORef Intern.empty
3842
databaseValues <- Ids.empty
43+
reverseDepsClean <- newIORef mempty
44+
reverseDepsDirty <- newIORef mempty
45+
reverseDeps <- Ids.empty
46+
let reverseDepsAllDirty = False
47+
let databaseReverseDeps = ReverseDeps{..}
3948
pure Database{..}
4049

4150
-- | Increment the step and mark all ids dirty
@@ -120,13 +129,19 @@ cleanupAsync ref = mapConcurrently_ uninterruptibleCancel =<< readIORef ref
120129
-- | Check if we need to run the database.
121130
check :: Database -> Key -> Id -> Maybe Result -> IO Result
122131
check db key id result@(Just me@Result{resultDeps=Just deps}) = do
123-
res <- builder db $ map Left deps
124-
let dirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) res
125-
let mode = if dirty then Shake.RunDependenciesChanged else Shake.RunDependenciesSame
132+
amDirty <- isDirty db id
133+
mode <- if amDirty
134+
-- Event if I am dirty, it is still possible that all my dependencies are unchanged
135+
-- thanks to early cutoff, and therefore we must check to avoid redundant work
136+
then do
137+
res <- builder db $ map Left deps
138+
let dirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) res
139+
return $ if dirty then Shake.RunDependenciesChanged else Shake.RunDependenciesSame
140+
-- If I am not dirty then none of my dependencies are, so they must be unchanged
141+
else return Shake.RunDependenciesSame
126142
spawn db key id mode result
127143
check db key id result = spawn db key id Shake.RunDependenciesChanged result
128144

129-
130145
-- | Spawn a new computation to run the action.
131146
spawn :: Database -> Key -> Id -> Shake.RunMode -> Maybe Result -> IO Result
132147
spawn db@Database{..} key id mode result = do
@@ -137,10 +152,12 @@ spawn db@Database{..} key id mode result = do
137152
deps <- readIORef deps
138153
let changed = if runChanged == Shake.ChangedRecomputeDiff then built else maybe built resultChanged result
139154
-- only update the deps when the rule ran with changes
140-
let actual_deps = if runChanged /= Shake.ChangedNothing then deps else previousDeps
155+
let actualDeps = if runChanged /= Shake.ChangedNothing then deps else previousDeps
141156
previousDeps= resultDeps =<< result
142-
let res = Result runValue built changed actual_deps runStore
143-
withLock databaseLock $
157+
let res = Result runValue built changed actualDeps runStore
158+
withLock databaseLock $ do
159+
unmarkDirty db id
160+
updateReverseDeps id db (fromMaybe [] previousDeps) (fromMaybe [] actualDeps)
144161
Ids.insert databaseValues id (key, Clean res)
145162
pure res
146163

@@ -152,3 +169,60 @@ splitIO act = do
152169
let act2 = Box <$> act
153170
let res = unsafePerformIO act2
154171
(void $ evaluate res, fromBox res)
172+
173+
--------------------------------------------------------------------------------
174+
-- Reverse dependencies
175+
176+
-- | Update the reverse dependencies of an Id
177+
updateReverseDeps
178+
:: Id -- ^ Id
179+
-> Database
180+
-> [Id] -- ^ Previous direct dependencies of Id
181+
-> [Id] -- ^ Current direct dependencies of Id
182+
-> IO ()
183+
updateReverseDeps myId db prev new = do
184+
forM_ prev $ doOne (HSet.delete myId)
185+
forM_ new $ doOne (HSet.insert myId)
186+
where
187+
doOne f id = do
188+
rdeps <- getReverseDependencies db id
189+
Ids.insert (reverseDeps $ databaseReverseDeps db) id (f $ fromMaybe mempty rdeps)
190+
191+
getReverseDependencies :: Database -> Id -> IO (Maybe (HSet.HashSet Id))
192+
getReverseDependencies db = Ids.lookup (reverseDeps $ databaseReverseDeps db)
193+
194+
markDirty :: Database -> HSet.HashSet Id -> IO ()
195+
markDirty Database{databaseReverseDeps} ids =
196+
atomicModifyIORef'_ (reverseDepsDirty databaseReverseDeps) $ HSet.union ids
197+
198+
unmarkDirty :: Database -> Id -> IO ()
199+
unmarkDirty Database{databaseReverseDeps} i = do
200+
atomicModifyIORef'_ (reverseDepsClean databaseReverseDeps) $ HSet.insert i
201+
202+
flushDirty :: Database -> IO ()
203+
flushDirty Database{databaseReverseDeps} = do
204+
cleanIds <- atomicModifyIORef' (reverseDepsClean databaseReverseDeps) (mempty,)
205+
atomicModifyIORef'_ (reverseDepsDirty databaseReverseDeps) (`HSet.difference` cleanIds)
206+
207+
isDirty :: Database -> Id -> IO Bool
208+
isDirty db@Database{databaseReverseDeps} id
209+
| reverseDepsAllDirty databaseReverseDeps = pure True
210+
| otherwise =
211+
HSet.member id <$> getDirtySet db
212+
213+
getDirtySet :: Database -> IO (HSet.HashSet Id)
214+
getDirtySet db = readIORef (reverseDepsDirty $ databaseReverseDeps db)
215+
216+
-- | Transitively expand the dirty set
217+
updateDirtySet :: Database -> IO ()
218+
updateDirtySet database = do
219+
let loop x = do
220+
seen <- State.get
221+
if x `HSet.member` seen then pure () else do
222+
State.put (HSet.insert x seen)
223+
next <- lift $ getReverseDependencies database x
224+
traverse_ loop (fromMaybe mempty next)
225+
ids <- getDirtySet database
226+
transitive <- flip State.execStateT HSet.empty $ traverse_ loop ids
227+
228+
markDirty database transitive

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

Lines changed: 37 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -1,25 +1,26 @@
11

22

3+
{-# LANGUAGE ExistentialQuantification #-}
34
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4-
{-# LANGUAGE ExistentialQuantification #-}
5-
{-# LANGUAGE ScopedTypeVariables #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
66

77
module Development.IDE.Graph.Internal.Types where
88

9-
import Control.Monad.Trans.Reader
10-
import Data.IORef
11-
import qualified Data.HashMap.Strict as Map
12-
import Data.Typeable
13-
import Data.Dynamic
14-
import Control.Monad.Fail
15-
import Control.Monad.IO.Class
16-
import Development.IDE.Graph.Internal.Ids
17-
import Control.Concurrent.Extra
18-
import Development.IDE.Graph.Internal.Intern
19-
import Control.Applicative
20-
import Development.Shake.Classes
21-
import qualified Data.ByteString as BS
22-
import Data.Maybe
9+
import Control.Applicative
10+
import Control.Concurrent.Extra
11+
import Control.Monad.Fail
12+
import Control.Monad.IO.Class
13+
import Control.Monad.Trans.Reader
14+
import qualified Data.ByteString as BS
15+
import Data.Dynamic
16+
import qualified Data.HashMap.Strict as Map
17+
import Data.HashSet (HashSet)
18+
import Data.IORef
19+
import Data.Maybe
20+
import Data.Typeable
21+
import Development.IDE.Graph.Internal.Ids
22+
import Development.IDE.Graph.Internal.Intern
23+
import Development.Shake.Classes
2324

2425

2526
unwrapDynamic :: forall a . Typeable a => Dynamic -> a
@@ -36,9 +37,9 @@ newtype Rules a = Rules (ReaderT SRules IO a)
3637
deriving (Monad, Applicative, Functor, MonadIO, MonadFail)
3738

3839
data SRules = SRules {
39-
rulesExtra :: !Dynamic,
40+
rulesExtra :: !Dynamic,
4041
rulesActions :: !(IORef [Action ()]),
41-
rulesMap :: !(IORef TheRules)
42+
rulesMap :: !(IORef TheRules)
4243
}
4344

4445

@@ -50,7 +51,7 @@ newtype Action a = Action {fromAction :: ReaderT SAction IO a}
5051

5152
data SAction = SAction {
5253
actionDatabase :: !Database,
53-
actionDeps :: !(IORef (Maybe [Id])) -- Nothing means always rerun
54+
actionDeps :: !(IORef (Maybe [Id])) -- ^ Nothing means always rerun
5455
}
5556

5657

@@ -74,26 +75,33 @@ instance Show Key where
7475
newtype Value = Value Dynamic
7576

7677
data Database = Database {
77-
databaseExtra :: Dynamic,
78-
databaseRules :: TheRules,
79-
databaseStep :: !(IORef Step),
78+
databaseExtra :: Dynamic,
79+
databaseRules :: TheRules,
80+
databaseStep :: !(IORef Step),
8081
-- Hold the lock while mutating Ids/Values
81-
databaseLock :: !Lock,
82-
databaseIds :: !(IORef (Intern Key)),
83-
databaseValues :: !(Ids (Key, Status))
82+
databaseLock :: !Lock,
83+
databaseIds :: !(IORef (Intern Key)),
84+
databaseValues :: !(Ids (Key, Status)),
85+
databaseReverseDeps :: !ReverseDeps
8486
}
8587

88+
data ReverseDeps = ReverseDeps
89+
{ reverseDepsClean, reverseDepsDirty :: IORef (HashSet Id)
90+
-- ^ An approximation of the dirty set across runs of 'shakeRunDatabaseForKeys'
91+
, reverseDepsAllDirty :: Bool
92+
, reverseDeps :: !(Ids (HashSet Id))
93+
}
8694
data Status
8795
= Clean Result
8896
| Dirty (Maybe Result)
8997
| Running (IO Result) (Maybe Result)
9098

9199
data Result = Result {
92-
resultValue :: !Value,
93-
resultBuilt :: !Step,
100+
resultValue :: !Value,
101+
resultBuilt :: !Step,
94102
resultChanged :: !Step,
95-
resultDeps :: !(Maybe [Id]), -- Nothing = alwaysRerun
96-
resultData :: BS.ByteString
103+
resultDeps :: !(Maybe [Id]), -- Nothing = alwaysRerun
104+
resultData :: BS.ByteString
97105
}
98106

99107

0 commit comments

Comments
 (0)