Skip to content

Commit

Permalink
Fix reverse dep. tracking for alwaysRerun rules
Browse files Browse the repository at this point in the history
When I ported reverse dependencies from Shake[1] I missed an important
detail. While Shake models alwaysRerun as a dependency on an actual rule
(AlwaysRerun), hls-graph models alwaysRerun by setting actionDeps to
Nothing. This is important because dependencies are not computed for
these rules, and therefore reverse dependency tracking doesn't do
anything, which breaks correctness of dirty rebuilds

This commit adds dependency tracking for alwaysRerun rules, and fixes
reverse dependency tracking. The alternative would be following the
Shake approach but I'm not sure what other implications this might have.

[1] - ndmitchell/shake#802
  • Loading branch information
pepeiborra committed Oct 24, 2021
1 parent 961fc0b commit bd7ac94
Show file tree
Hide file tree
Showing 4 changed files with 45 additions and 25 deletions.
26 changes: 12 additions & 14 deletions hls-graph/src/Development/IDE/Graph/Internal/Action.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}

module Development.IDE.Graph.Internal.Action
( ShakeValue
Expand All @@ -19,23 +19,23 @@ module Development.IDE.Graph.Internal.Action

import Control.Concurrent.Async
import Control.Exception
import Control.Monad.Extra
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.IORef
import Development.IDE.Graph.Classes
import Development.IDE.Graph.Internal.Database
import Development.IDE.Graph.Internal.Rules (RuleResult)
import Development.IDE.Graph.Internal.Types
import System.Exit
import Development.IDE.Graph.Internal.Rules (RuleResult)

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

-- | Always rerun this rule when dirty, regardless of the dependencies.
alwaysRerun :: Action ()
alwaysRerun = do
ref <- Action $ asks actionDeps
liftIO $ writeIORef ref Nothing
liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>)

-- No-op for now
reschedule :: Double -> Action ()
Expand All @@ -48,23 +48,23 @@ parallel xs = do
a <- Action ask
deps <- liftIO $ readIORef $ actionDeps a
case deps of
Nothing ->
UnknownDeps ->
-- if we are already in the rerun mode, nothing we do is going to impact our state
liftIO $ mapConcurrently (ignoreState a) xs
Just deps -> do
deps -> do
(newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs
liftIO $ writeIORef (actionDeps a) $ (deps ++) <$> concatMapM id newDeps
liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps
pure res
where
usingState a x = do
ref <- newIORef $ Just []
ref <- newIORef mempty
res <- runReaderT (fromAction x) a{actionDeps=ref}
deps <- readIORef ref
pure (deps, res)

ignoreState :: SAction -> Action b -> IO b
ignoreState a x = do
ref <- newIORef Nothing
ref <- newIORef mempty
runReaderT (fromAction x) a{actionDeps=ref}

actionFork :: Action a -> (Async a -> Action b) -> Action b
Expand All @@ -73,7 +73,7 @@ actionFork act k = do
deps <- liftIO $ readIORef $ actionDeps a
let db = actionDatabase a
case deps of
Nothing -> do
UnknownDeps -> do
-- if we are already in the rerun mode, nothing we do is going to impact our state
[res] <- liftIO $ withAsync (ignoreState a act) $ \as -> runActions db [k as]
return res
Expand Down Expand Up @@ -116,12 +116,10 @@ apply ks = do
db <- Action $ asks actionDatabase
(is, vs) <- liftIO $ build db ks
ref <- Action $ asks actionDeps
deps <- liftIO $ readIORef ref
whenJust deps $ \deps ->
liftIO $ writeIORef ref $ Just $ is ++ deps
liftIO $ modifyIORef ref (ResultDeps is <>)
pure vs

runActions :: Database -> [Action a] -> IO [a]
runActions db xs = do
deps <- newIORef Nothing
deps <- newIORef mempty
runReaderT (fromAction $ parallel xs) $ SAction db deps
10 changes: 5 additions & 5 deletions hls-graph/src/Development/IDE/Graph/Internal/Database.hs
Original file line number Diff line number Diff line change
Expand Up @@ -135,7 +135,7 @@ builder db@Database{..} keys = do
-- This assumes that the implementation will be a lookup
-- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself
refresh :: Database -> Key -> Id -> Maybe Result -> AIO (IO Result)
refresh db key id result@(Just me@Result{resultDeps=Just deps}) = do
refresh db key id result@(Just me@Result{resultDeps = ResultDeps deps}) = do
res <- builder db $ map Left deps
case res of
Left res ->
Expand All @@ -157,7 +157,7 @@ refresh db key id result =
compute :: Database -> Key -> Id -> RunMode -> Maybe Result -> IO Result
compute db@Database{..} key id mode result = do
let act = runRule databaseRules key (fmap resultData result) mode
deps <- newIORef $ Just []
deps <- newIORef UnknownDeps
(execution, RunResult{..}) <-
duration $ runReaderT (fromAction act) $ SAction db deps
built <- readIORef databaseStep
Expand All @@ -166,14 +166,14 @@ compute db@Database{..} key id mode result = do
built' = if runChanged /= ChangedNothing then built else changed
-- only update the deps when the rule ran with changes
actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
previousDeps= resultDeps =<< result
previousDeps= maybe UnknownDeps resultDeps result
let res = Result runValue built' changed built actualDeps execution runStore
case actualDeps of
Just deps | not(null deps) &&
ResultDeps deps | not(null deps) &&
runChanged /= ChangedNothing
-> do
void $ forkIO $
updateReverseDeps id db (fromMaybe [] previousDeps) (Set.fromList deps)
updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps)
_ -> pure ()
withLock databaseLock $
Ids.insert databaseValues id (key, Clean res)
Expand Down
8 changes: 4 additions & 4 deletions hls-graph/src/Development/IDE/Graph/Internal/Profile.hs
Original file line number Diff line number Diff line change
Expand Up @@ -61,7 +61,7 @@ data ProfileEntry = ProfileEntry
-- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value))
resultsOnly :: [(Ids.Id, (k, Status))] -> Map.HashMap Ids.Id (k, Result)
resultsOnly mp = Map.map (fmap (\r ->
r{resultDeps = fmap (filter (isJust . flip Map.lookup keep)) $ resultDeps r}
r{resultDeps = mapResultDeps (filter (isJust . flip Map.lookup keep)) $ resultDeps r}
)) keep
where
keep = Map.fromList $ mapMaybe ((traverse.traverse) getResult) mp
Expand Down Expand Up @@ -113,7 +113,7 @@ toReport db = do
status <- prepareForDependencyOrder db
let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status
in dependencyOrder shw
$ map (second (fromMaybe [-1] . resultDeps . snd))
$ map (second (getResultDepsDefault [-1] . resultDeps . snd))
$ Map.toList status
ids = IntMap.fromList $ zip order [0..]

Expand All @@ -126,14 +126,14 @@ toReport db = do
,prfBuilt = fromStep resultBuilt
,prfVisited = fromStep resultVisited
,prfChanged = fromStep resultChanged
,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ fromMaybe [-1] $ resultDeps
,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ getResultDepsDefault [-1] resultDeps
,prfExecution = resultExecution
}
where fromStep i = fromJust $ Map.lookup i steps
pure ([maybe (error "toReport") f $ Map.lookup i status | i <- order], ids)

alwaysRerunResult :: Step -> Result
alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (Just []) 0 mempty
alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps []) 0 mempty

readDataFileHTML :: FilePath -> IO LBS.ByteString
readDataFileHTML file = LBS.readFile =<< getDataFile ("html" </> file)
Expand Down
26 changes: 24 additions & 2 deletions hls-graph/src/Development/IDE/Graph/Internal/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,7 @@ newtype Action a = Action {fromAction :: ReaderT SAction IO a}

data SAction = SAction {
actionDatabase :: !Database,
actionDeps :: !(IORef (Maybe [Id])) -- Nothing means always rerun
actionDeps :: !(IORef ResultDeps)
}


Expand Down Expand Up @@ -105,11 +105,33 @@ data Result = Result {
resultBuilt :: !Step, -- ^ the step when it was last recomputed
resultChanged :: !Step, -- ^ the step when it last changed
resultVisited :: !Step, -- ^ the step when it was last looked up
resultDeps :: !(Maybe [Id]), -- ^ Nothing = alwaysRerun
resultDeps :: !ResultDeps,
resultExecution :: !Seconds, -- ^ How long it took, last time it ran
resultData :: BS.ByteString
}

data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Id] | ResultDeps ![Id]

getResultDepsDefault :: [Id] -> ResultDeps -> [Id]
getResultDepsDefault _ (ResultDeps ids) = ids
getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
getResultDepsDefault def UnknownDeps = def

mapResultDeps :: ([Id] -> [Id]) -> ResultDeps -> ResultDeps
mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids
mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
mapResultDeps _ UnknownDeps = UnknownDeps

instance Semigroup ResultDeps where
UnknownDeps <> x = x
x <> UnknownDeps = x
AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault [] x)
x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault [] x <> ids)
ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids')

instance Monoid ResultDeps where
mempty = UnknownDeps

---------------------------------------------------------------------
-- Running builds

Expand Down

0 comments on commit bd7ac94

Please sign in to comment.