Skip to content

Commit 54a6bf7

Browse files
pepeiborrapepeiborra
committed
implement reverse deps
1 parent 3dfc695 commit 54a6bf7

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

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

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