Skip to content

Commit 3f72122

Browse files
sheafsheaf
committed
Add recompilation checking for pre-build rules
This commit adds recompilation logic for SetupHooks pre-build rules. This implements the behaviour described in the SetupHooks API. That is, a rule is considered stale if: [N] The rule is new, or [S1] A dependency of the rule is stale. That is, either we have re-run another rule that this rule depends on, or one of the file inputs to the rule is newer than the oldest output of the rule (or the rule output doesn't exist at all), or [S2] The rule itself has changed, e.g. the parameters stored in RuleData have changed. Fixes #11730
1 parent 7d4f1f1 commit 3f72122

11 files changed

Lines changed: 307 additions & 13 deletions

File tree

‎Cabal/src/Distribution/Simple/BuildPaths.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ module Distribution.Simple.BuildPaths
2727
, haddockPref
2828
, autogenPackageModulesDir
2929
, autogenComponentModulesDir
30+
, preBuildRulesCacheFile
3031
, autogenPathsModuleName
3132
, autogenPackageInfoModuleName
3233
, cppHeaderName
@@ -160,6 +161,15 @@ autogenPackageModulesDir lbi = buildDir lbi </> makeRelativePathEx "global-autog
160161
autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Source)
161162
autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi </> makeRelativePathEx "autogen"
162163

164+
-- | The path to the pre-build rules cache file for a component, used to
165+
-- compute rule staleness across runs.
166+
preBuildRulesCacheFile
167+
:: LocalBuildInfo
168+
-> ComponentLocalBuildInfo
169+
-> SymbolicPath Pkg File
170+
preBuildRulesCacheFile lbi clbi =
171+
componentBuildDir lbi clbi </> makeRelativePathEx "setup-hooks-rules.cache"
172+
163173
-- NB: Look at 'checkForeignDeps' for where a simplified version of this
164174
-- has been copy-pasted.
165175

‎Cabal/src/Distribution/Simple/SetupHooks/Internal.hs‎

Lines changed: 97 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE DeriveGeneric #-}
33
{-# LANGUAGE DerivingStrategies #-}
44
{-# LANGUAGE DuplicateRecordFields #-}
5+
{-# LANGUAGE FlexibleContexts #-}
56
{-# LANGUAGE GADTs #-}
67
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
78
{-# LANGUAGE LambdaCase #-}
@@ -12,7 +13,8 @@
1213
-- |
1314
-- Module: Distribution.Simple.SetupHooks.Internal
1415
--
15-
-- Internal implementation module.
16+
-- Internal implementation module for 'SetupHooks'.
17+
--
1618
-- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks"
1719
-- instead.
1820
module Distribution.Simple.SetupHooks.Internal
@@ -109,20 +111,25 @@ import qualified Distribution.Simple.SetupHooks.Rule as Rule
109111
import Distribution.Simple.Utils
110112
import Distribution.System (Platform (..))
111113
import Distribution.Utils.Path
114+
import Distribution.Utils.Structured
115+
(structuredDecodeOrFailIO, structuredEncodeFile)
112116

113117
import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo)
114118
import Distribution.Types.LocalBuildConfig as LBC
115119
import Distribution.Types.TargetInfo
116120
import Distribution.Verbosity
117121

122+
import qualified Data.ByteString as BS
118123
import qualified Data.ByteString.Lazy as LBS
119124
import Data.Coerce (coerce)
125+
import Data.Either (fromRight)
120126
import qualified Data.Graph as Graph
127+
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
121128
import qualified Data.List.NonEmpty as NE
122129
import qualified Data.Map as Map
123130
import qualified Data.Set as Set
124131

125-
import System.Directory (doesFileExist)
132+
import System.Directory (doesFileExist, getModificationTime)
126133

127134
--------------------------------------------------------------------------------
128135
-- SetupHooks
@@ -849,7 +856,11 @@ executeRules =
849856
-- an external hooks executable.
850857
executeRulesUserOrSystem
851858
:: forall userOrSystem
852-
. SScope userOrSystem
859+
. ( Binary (RuleData userOrSystem)
860+
, Structured (RuleData userOrSystem)
861+
, Eq (RuleData userOrSystem)
862+
)
863+
=> SScope userOrSystem
853864
-> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString)))
854865
-> (RuleId -> RuleExecCmd userOrSystem -> IO ())
855866
-> Verbosity
@@ -858,6 +869,12 @@ executeRulesUserOrSystem
858869
-> Map RuleId (RuleData userOrSystem)
859870
-> IO ()
860871
executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo allRules = do
872+
-- Load the rule cache from the previous build.
873+
-- Used to detect when rule definitions have changed.
874+
oldRules <- handleDoesNotExist Map.empty $ do
875+
-- NB: do a strict read to avoid retaining the file handle.
876+
bs <- BS.readFile rulesCacheFile
877+
fromRight Map.empty <$> structuredDecodeOrFailIO (LBS.fromStrict bs)
861878
-- Compute all extra dynamic dependency edges.
862879
dynDepsEdges <-
863880
flip Map.traverseMaybeWithKey allRules $
@@ -939,7 +956,8 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
939956
, " it is not in the appropriate 'autogenComponentModules' directory)"
940957
]
941958

942-
-- Run all the demanded rules, in dependency order.
959+
-- Run all the demanded rules, in dependency order, propagating staleness.
960+
staleRulesRef <- newIORef Set.empty
943961
for_ sccs $ \(Graph.Node ruleVertex _) ->
944962
-- Don't run a rule unless it is demanded.
945963
unless (ruleVertex `Set.member` nonDemandedRuleVerts) $ do
@@ -960,16 +978,27 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
960978
case NE.nonEmpty missingRuleDeps of
961979
Just missingDeps ->
962980
errorOut $ CantFindSourceForRuleDependencies (toRuleBinary r) missingDeps
963-
-- Dependencies OK: run the associated action.
981+
-- Dependencies OK: check whether the rule is up to date before
982+
-- deciding to run it.
964983
Nothing -> do
965-
let execCmd = ruleExecCmd scope cmds (snd <$> mbDyn)
966-
runCmdData rId execCmd
967-
-- Throw an error if running the action did not result in
968-
-- the generation of outputs that we expected it to.
969-
missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList reslts
970-
for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->
971-
errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults
972-
return ()
984+
let dynDeps = maybe [] fst (Map.lookup rId dynDepsEdges)
985+
upToDate <- ruleUpToDate mbWorkDir oldRules staleRulesRef rId r dynDeps
986+
if upToDate
987+
then
988+
info verbosity $
989+
"Rule " ++ show rId ++ " is up to date; skipping."
990+
else do
991+
modifyIORef' staleRulesRef (Set.insert rId)
992+
let execCmd = ruleExecCmd scope cmds (snd <$> mbDyn)
993+
runCmdData rId execCmd
994+
-- Throw an error if running the action did not result in
995+
-- the generation of outputs that we expected it to.
996+
missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList reslts
997+
for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->
998+
errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults
999+
return ()
1000+
-- Save the current rules to the cache for use in the next build.
1001+
structuredEncodeFile rulesCacheFile allRules
9731002
where
9741003
toRuleBinary :: RuleData userOrSystem -> RuleBinary
9751004
toRuleBinary = case scope of
@@ -978,6 +1007,7 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
9781007
clbi = targetCLBI tgtInfo
9791008
mbWorkDir = mbWorkDirLBI lbi
9801009
compAutogenDir = autogenComponentModulesDir lbi clbi
1010+
rulesCacheFile = interpretSymbolicPath mbWorkDir (preBuildRulesCacheFile lbi clbi)
9811011
errorOut e =
9821012
dieWithException verbosity $
9831013
SetupHooksException $
@@ -987,6 +1017,60 @@ directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId
9871017
directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep
9881018
directRuleDependencyMaybe (FileDependency{}) = Nothing
9891019

1020+
1021+
-- | Is the rule up to date (so that we can skip re-running it)?
1022+
--
1023+
-- As per the SetupHooks documentation, a rule must be re-run if:
1024+
--
1025+
-- - [N] the rule is new, or
1026+
-- - [S] the rule matches with an old rule, and either:
1027+
-- - [S1] an input to the rule has changed (either a file or rule dependency)
1028+
-- - [S2] the rule itself has changed
1029+
ruleUpToDate
1030+
:: Eq (RuleData userOrSystem)
1031+
=> Maybe (SymbolicPath CWD (Dir Pkg))
1032+
-- ^ working directory
1033+
-> Map RuleId (RuleData userOrSystem)
1034+
-- ^ old rules from the previous build
1035+
-> IORef (Set RuleId)
1036+
-- ^ rules that have been re-run
1037+
-> RuleId
1038+
-> RuleData userOrSystem
1039+
-> [Rule.Dependency]
1040+
-- ^ dynamic dependencies of this rule
1041+
-> IO Bool
1042+
ruleUpToDate mbWorkDir oldRules staleRulesRef rId rule dynDeps = do
1043+
staleRules <- readIORef staleRulesRef
1044+
if ruleChanged || any (`Set.member` staleRules) ruleDeps
1045+
then return False
1046+
else do
1047+
let maybeModTime fp = handleDoesNotExist Nothing $ Just <$> getModificationTime fp
1048+
outMtimes <- traverse maybeModTime outputPaths
1049+
case sequenceA outMtimes of
1050+
-- At least one output is missing: must run the rule.
1051+
Nothing -> return False
1052+
Just outs ->
1053+
-- Re-run if an input is more recent than the oldest output.
1054+
case inputPaths of
1055+
[] -> return True
1056+
_ -> do
1057+
inMtimes <- traverse getModificationTime inputPaths
1058+
return (minimum outs >= maximum inMtimes)
1059+
where
1060+
i (Location dir file) = interpretSymbolicPath mbWorkDir (dir </> file)
1061+
allDeps = staticDependencies rule ++ dynDeps
1062+
ruleDeps = [outputOfRule ro | RuleDependency ro <- allDeps]
1063+
fileDeps = [loc | FileDependency loc <- allDeps]
1064+
inputPaths = map i fileDeps
1065+
outputPaths = fmap i (results rule)
1066+
ruleChanged =
1067+
case Map.lookup rId oldRules of
1068+
Just oldRule ->
1069+
-- Use the Eq instance to determine if the rule has changed
1070+
-- (as documented in the API).
1071+
oldRule /= rule
1072+
Nothing -> True
1073+
9901074
resolveDependency :: Verbosity -> RuleId -> Map RuleId (RuleData scope) -> Rule.Dependency -> IO Location
9911075
resolveDependency verbosity rId allRules = \case
9921076
FileDependency l -> return l

‎cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/A.myPP‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
a = True

‎cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/B.myPP‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
b = False

‎cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/C.myPP‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
c = 'x'

‎cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/Setup.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
module Main where
2+
3+
import Distribution.Simple ( defaultMainWithSetupHooks )
4+
import SetupHooks ( setupHooks )
5+
6+
main :: IO ()
7+
main = defaultMainWithSetupHooks setupHooks

‎cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/SetupHooks.hs‎

Lines changed: 112 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,112 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE DerivingStrategies #-}
5+
{-# LANGUAGE DuplicateRecordFields #-}
6+
{-# LANGUAGE OverloadedStrings #-}
7+
{-# LANGUAGE RecordWildCards #-}
8+
{-# LANGUAGE StaticPointers #-}
9+
10+
module SetupHooks where
11+
12+
-- Cabal
13+
import Distribution.Compat.Binary
14+
import Distribution.Parsec
15+
( simpleParsec )
16+
import Distribution.Simple.LocalBuildInfo
17+
( interpretSymbolicPathLBI )
18+
import Distribution.Simple.Utils
19+
( warn, rewriteFileEx )
20+
import Distribution.Utils.Path
21+
import Distribution.Verbosity
22+
23+
-- Cabal-hooks
24+
import Distribution.Simple.SetupHooks
25+
26+
-- base
27+
import Control.Monad.IO.Class
28+
( liftIO )
29+
import Data.Foldable
30+
( for_ )
31+
import Data.List
32+
( isSuffixOf )
33+
import qualified Data.List.NonEmpty as NE
34+
( NonEmpty(..) )
35+
import Data.String
36+
( fromString )
37+
import GHC.Generics
38+
39+
-- directory
40+
import System.Directory
41+
( listDirectory )
42+
43+
-- filepath
44+
import System.FilePath
45+
( dropExtension )
46+
47+
--------------------------------------------------------------------------------
48+
49+
setupHooks :: SetupHooks
50+
setupHooks =
51+
noSetupHooks
52+
{ buildHooks =
53+
noBuildHooks
54+
{ preBuildComponentRules = Just $ rules (static ()) preBuildRules
55+
}
56+
}
57+
58+
preBuildRules :: PreBuildComponentInputs -> RulesM ()
59+
preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = do
60+
let verbosityFlags = buildingWhatVerbosity what
61+
clbi = targetCLBI tgt
62+
autogenDir = autogenComponentModulesDir lbi clbi
63+
srcDir = sameDirectory
64+
65+
-- Monitor .myPP files in the package directory.
66+
let myPPGlob =
67+
case simpleParsec "*.myPP" of
68+
Just g -> g
69+
Nothing -> error "SetupHooksRecompRules: failed to parse *.myPP glob"
70+
addRuleMonitors [ monitorFileGlobExistence myPPGlob ]
71+
72+
-- Scan the package directory for .myPP files and register one
73+
-- preprocessing rule per file.
74+
allFiles <- liftIO $ listDirectory (interpretSymbolicPathLBI lbi srcDir)
75+
for_ (filter (".myPP" `isSuffixOf`) allFiles) $ \fileName -> do
76+
let baseName = dropExtension fileName
77+
-- For A and B, bake in a constant verbosity so that their rules are
78+
-- unaffected by the --verbose flag. C uses the actual verbosity, so
79+
-- its rule changes when the verbosity changes.
80+
ruleVerbosityFlags
81+
| baseName `elem` ["A", "B"] = normal
82+
| otherwise = verbosityFlags
83+
registerRule_ (fromString $ "myPP " ++ baseName) $
84+
staticRule
85+
(mkCommand (static Dict) (static runMyPP) $
86+
MyPPInput
87+
{ ppVerbosityFlags = ruleVerbosityFlags
88+
, ppSrcDir = srcDir
89+
, ppAutogenDir = autogenDir
90+
, ppBaseName = baseName
91+
})
92+
[ FileDependency $ Location srcDir (makeRelativePathEx fileName) ]
93+
( Location autogenDir (makeRelativePathEx baseName <.> "hs") NE.:| [] )
94+
95+
-- | Preprocess a single .myPP file into a .hs module.
96+
runMyPP :: MyPPInput -> IO ()
97+
runMyPP (MyPPInput {..}) = do
98+
let verbosity = mkVerbosity defaultVerbosityHandles ppVerbosityFlags
99+
warn verbosity $ "Running myPP preprocessor for " ++ ppBaseName
100+
content <- readFile (getSymbolicPath ppSrcDir </> ppBaseName <.> "myPP")
101+
rewriteFileEx verbosity (getSymbolicPath ppAutogenDir </> ppBaseName <.> "hs") $
102+
"module " ++ ppBaseName ++ " where\n" ++ content
103+
104+
data MyPPInput
105+
= MyPPInput
106+
{ ppVerbosityFlags :: VerbosityFlags
107+
, ppSrcDir :: SymbolicPath Pkg (Dir Source)
108+
, ppAutogenDir :: SymbolicPath Pkg (Dir Source)
109+
, ppBaseName :: String
110+
}
111+
deriving stock ( Show, Generic )
112+
deriving anyclass Binary

‎cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/cabal.project‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
packages: .

‎cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup-hooks-recomp-rules-test.cabal‎

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
cabal-version: 3.14
2+
name: setup-hooks-recomp-rules-test
3+
version: 0.1.0.0
4+
synopsis: Test recompilation checking for pre-build rules
5+
license: BSD-3-Clause
6+
author: NA
7+
maintainer: NA
8+
category: Testing
9+
build-type: Hooks
10+
11+
custom-setup
12+
setup-depends:
13+
Cabal
14+
, Cabal-hooks
15+
16+
, base
17+
, filepath
18+
, directory
19+
20+
library
21+
autogen-modules:
22+
A, B, C
23+
exposed-modules:
24+
A, B, C
25+
build-depends:
26+
base
27+
default-language:
28+
Haskell2010

‎cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup.test.hs‎

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
import Test.Cabal.Prelude
2+
3+
main :: IO ()
4+
main = setupTest $ recordMode DoNotRecord $ do
5+
setup "configure" []
6+
7+
-- First build: should run rules for A, B and C.
8+
build1 <- setup' "build" ["--verbose=1"]
9+
assertOutputContains "Running myPP preprocessor for A" build1
10+
assertOutputContains "Running myPP preprocessor for B" build1
11+
assertOutputContains "Running myPP preprocessor for C" build1
12+
13+
-- Modify A.myPP, leaving other files alone.
14+
writeSourceFile "A.myPP" "a = 42\n"
15+
16+
-- Check we only re-run the preprocessor for A (file dependency changed).
17+
build2 <- setup' "build" ["--verbose=1"]
18+
assertOutputContains "Running myPP preprocessor for A" build2
19+
assertOutputDoesNotContain "Running myPP preprocessor for B" build2
20+
assertOutputDoesNotContain "Running myPP preprocessor for C" build2
21+
22+
-- Change verbosity. C's rule stores the actual verbosity, while A and B
23+
-- bake in a constant verbosity. Thus we should only re-run the rule for C.
24+
build3 <- setup' "build" ["--verbose=2"]
25+
assertOutputDoesNotContain "Running myPP preprocessor for A" build3
26+
assertOutputDoesNotContain "Running myPP preprocessor for B" build3
27+
assertOutputContains "Running myPP preprocessor for C" build3

0 commit comments

Comments
 (0)