Skip to content

Commit fd4ab4d

Browse files
soulomoonsoulomoon
committed
linearlize the refreshing of dependencies
1 parent c8b286a commit fd4ab4d

File tree

5 files changed

+39
-26
lines changed

5 files changed

+39
-26
lines changed

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Development.IDE.Graph.Database(
1212
,shakeGetBuildEdges) where
1313
import Control.Concurrent.STM.Stats (readTVarIO)
1414
import Data.Dynamic
15+
import Data.Foldable (fold)
1516
import Data.Maybe
1617
import Development.IDE.Graph.Classes ()
1718
import Development.IDE.Graph.Internal.Action
@@ -77,7 +78,7 @@ shakeGetBuildEdges :: ShakeDatabase -> IO Int
7778
shakeGetBuildEdges (ShakeDatabase _ _ db) = do
7879
keys <- getDatabaseValues db
7980
let ress = mapMaybe (getResult . snd) keys
80-
return $ sum $ map (lengthKeySet . getResultDepsDefault mempty . resultDeps) ress
81+
return $ sum $ map (lengthKeySet . fold . getResultDepsDefault mempty . resultDeps) ress
8182

8283
-- | Returns an approximation of the database keys,
8384
-- annotated with how long ago (in # builds) they were visited

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -114,13 +114,14 @@ actionFinally a b = do
114114
apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
115115
apply1 k = runIdentity <$> apply (Identity k)
116116

117+
-- todo make the result ordered
117118
apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
118119
apply ks = do
119120
db <- Action $ asks actionDatabase
120121
stack <- Action $ asks actionStack
121122
(is, vs) <- liftIO $ build db stack ks
122123
ref <- Action $ asks actionDeps
123-
liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>)
124+
liftIO $ modifyIORef ref (ResultDeps [fromListKeySet $ toList is] <>)
124125
pure vs
125126

126127
-- | Evaluate a list of keys without recording any dependencies.

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

Lines changed: 27 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -3,9 +3,9 @@
33
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
44

55
{-# LANGUAGE DerivingStrategies #-}
6+
{-# LANGUAGE LambdaCase #-}
67
{-# LANGUAGE RecordWildCards #-}
78
{-# LANGUAGE TypeFamilies #-}
8-
{-# LANGUAGE ViewPatterns #-}
99

1010
module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where
1111

@@ -25,7 +25,7 @@ import Control.Monad.Trans.Reader
2525
import qualified Control.Monad.Trans.State.Strict as State
2626
import Data.Dynamic
2727
import Data.Either
28-
import Data.Foldable (for_, traverse_)
28+
import Data.Foldable (fold, for_, traverse_)
2929
import Data.IORef.Extra
3030
import Data.List.NonEmpty (unzip)
3131
import Data.Maybe
@@ -133,6 +133,27 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do
133133
waitAll
134134
pure results
135135

136+
isDirty :: Foldable t => Result -> t (a, Result) -> Bool
137+
isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep)
138+
139+
refreshDeps :: Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result)
140+
refreshDeps db stack key result = \case
141+
-- no more deps to refresh
142+
[] -> pure $ compute db stack key RunDependenciesSame (Just result)
143+
(dep:deps) -> do
144+
res <- builder db stack (toListKeySet dep)
145+
case res of
146+
Left res -> if isDirty result res
147+
-- restart the computation if any of the deps are dirty
148+
then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged (Just result)
149+
-- else kick the rest of the deps
150+
else refreshDeps db stack key result deps
151+
Right iores -> asyncWithCleanUp $ liftIO $ do
152+
res <- iores
153+
if isDirty result res
154+
then compute db stack key RunDependenciesChanged (Just result)
155+
else join $ runAIO $ refreshDeps db stack key result deps
156+
136157
-- | Refresh a key:
137158
-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.
138159
-- This assumes that the implementation will be a lookup
@@ -141,18 +162,7 @@ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)
141162
-- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined
142163
refresh db stack key result = case (addStack key stack, result) of
143164
(Left e, _) -> throw e
144-
(Right stack, Just me@Result{resultDeps = ResultDeps (toListKeySet -> deps)}) -> do
145-
res <- builder db stack deps
146-
let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)
147-
case res of
148-
Left res ->
149-
if isDirty res
150-
then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
151-
else pure $ compute db stack key RunDependenciesSame result
152-
Right iores -> asyncWithCleanUp $ liftIO $ do
153-
res <- iores
154-
let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame
155-
compute db stack key mode result
165+
(Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps db stack key me (reverse deps)
156166
(Right stack, _) ->
157167
asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
158168

@@ -172,8 +182,8 @@ compute db@Database{..} stack key mode result = do
172182
actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
173183
previousDeps= maybe UnknownDeps resultDeps result
174184
let res = Result runValue built' changed built actualDeps execution runStore
175-
case getResultDepsDefault mempty actualDeps of
176-
deps | not(nullKeySet deps)
185+
case fold $ getResultDepsDefault mempty actualDeps of
186+
deps | not (nullKeySet deps)
177187
&& runChanged /= ChangedNothing
178188
-> do
179189
-- IMPORTANT: record the reverse deps **before** marking the key Clean.
@@ -182,7 +192,7 @@ compute db@Database{..} stack key mode result = do
182192
-- on the next build.
183193
void $
184194
updateReverseDeps key db
185-
(getResultDepsDefault mempty previousDeps)
195+
(fold $ getResultDepsDefault mempty previousDeps)
186196
deps
187197
_ -> pure ()
188198
atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ import Data.Bifunctor
1212
import qualified Data.ByteString.Lazy.Char8 as LBS
1313
import Data.Char
1414
import Data.Dynamic (toDyn)
15+
import Data.Foldable (fold)
1516
import qualified Data.HashMap.Strict as Map
1617
import Data.List (dropWhileEnd, foldl',
1718
intercalate,
@@ -108,7 +109,7 @@ toReport :: Database -> IO ([ProfileEntry], KeyMap Int)
108109
toReport db = do
109110
status <- prepareForDependencyOrder db
110111
let order = dependencyOrder show
111-
$ map (second (toListKeySet . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps))
112+
$ map (second (toListKeySet . fold . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps))
112113
$ toListKeyMap status
113114
ids = fromListKeyMap $ zip order [0..]
114115

@@ -121,7 +122,7 @@ toReport db = do
121122
,prfBuilt = fromStep resultBuilt
122123
,prfVisited = fromStep resultVisited
123124
,prfChanged = fromStep resultChanged
124-
,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps
125+
,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ fold $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps
125126
,prfExecution = resultExecution
126127
}
127128
where fromStep i = fromJust $ Map.lookup i steps

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

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -144,17 +144,17 @@ data Result = Result {
144144
resultData :: !BS.ByteString
145145
}
146146

147-
data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet
147+
data ResultDeps = UnknownDeps | AlwaysRerunDeps ![KeySet] | ResultDeps ![KeySet]
148148
deriving (Eq, Show)
149149

150-
getResultDepsDefault :: KeySet -> ResultDeps -> KeySet
150+
getResultDepsDefault :: KeySet -> ResultDeps -> [KeySet]
151151
getResultDepsDefault _ (ResultDeps ids) = ids
152152
getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
153-
getResultDepsDefault def UnknownDeps = def
153+
getResultDepsDefault def UnknownDeps = [def]
154154

155155
mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps
156-
mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids
157-
mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
156+
mapResultDeps f (ResultDeps ids) = ResultDeps $ fmap f ids
157+
mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ fmap f ids
158158
mapResultDeps _ UnknownDeps = UnknownDeps
159159

160160
instance Semigroup ResultDeps where

0 commit comments

Comments
 (0)