@@ -14,9 +14,13 @@ import Control.Concurrent.Async
14
14
import Control.Concurrent.Extra
15
15
import Control.Exception
16
16
import Control.Monad
17
+ import Control.Monad.Trans.Class (lift )
17
18
import Control.Monad.Trans.Reader
19
+ import qualified Control.Monad.Trans.State.Strict as State
18
20
import Data.Dynamic
19
21
import Data.Either
22
+ import Data.Foldable (traverse_ )
23
+ import qualified Data.HashSet as HSet
20
24
import Data.IORef.Extra
21
25
import Data.Maybe
22
26
import Data.Tuple.Extra
@@ -36,6 +40,11 @@ newDatabase databaseExtra databaseRules = do
36
40
databaseLock <- newLock
37
41
databaseIds <- newIORef Intern. empty
38
42
databaseValues <- Ids. empty
43
+ reverseDepsClean <- newIORef mempty
44
+ reverseDepsDirty <- newIORef mempty
45
+ reverseDeps <- Ids. empty
46
+ let reverseDepsAllDirty = False
47
+ let databaseReverseDeps = ReverseDeps {.. }
39
48
pure Database {.. }
40
49
41
50
-- | Increment the step and mark all ids dirty
@@ -120,13 +129,19 @@ cleanupAsync ref = mapConcurrently_ uninterruptibleCancel =<< readIORef ref
120
129
-- | Check if we need to run the database.
121
130
check :: Database -> Key -> Id -> Maybe Result -> IO Result
122
131
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
126
142
spawn db key id mode result
127
143
check db key id result = spawn db key id Shake. RunDependenciesChanged result
128
144
129
-
130
145
-- | Spawn a new computation to run the action.
131
146
spawn :: Database -> Key -> Id -> Shake. RunMode -> Maybe Result -> IO Result
132
147
spawn db@ Database {.. } key id mode result = do
@@ -137,10 +152,12 @@ spawn db@Database{..} key id mode result = do
137
152
deps <- readIORef deps
138
153
let changed = if runChanged == Shake. ChangedRecomputeDiff then built else maybe built resultChanged result
139
154
-- 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
141
156
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)
144
161
Ids. insert databaseValues id (key, Clean res)
145
162
pure res
146
163
@@ -152,3 +169,60 @@ splitIO act = do
152
169
let act2 = Box <$> act
153
170
let res = unsafePerformIO act2
154
171
(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
0 commit comments