Skip to content

Commit 7328f9c

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 7328f9c

11 files changed

Lines changed: 308 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: 98 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,27 @@ 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
116+
, structuredEncodeFile
117+
)
112118

113119
import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo)
114120
import Distribution.Types.LocalBuildConfig as LBC
115121
import Distribution.Types.TargetInfo
116122
import Distribution.Verbosity
117123

124+
import qualified Data.ByteString as BS
118125
import qualified Data.ByteString.Lazy as LBS
119126
import Data.Coerce (coerce)
127+
import Data.Either (fromRight)
120128
import qualified Data.Graph as Graph
129+
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
121130
import qualified Data.List.NonEmpty as NE
122131
import qualified Data.Map as Map
123132
import qualified Data.Set as Set
124133

125-
import System.Directory (doesFileExist)
134+
import System.Directory (doesFileExist, getModificationTime)
126135

127136
--------------------------------------------------------------------------------
128137
-- SetupHooks
@@ -849,7 +858,11 @@ executeRules =
849858
-- an external hooks executable.
850859
executeRulesUserOrSystem
851860
:: forall userOrSystem
852-
. SScope userOrSystem
861+
. ( Binary (RuleData userOrSystem)
862+
, Structured (RuleData userOrSystem)
863+
, Eq (RuleData userOrSystem)
864+
)
865+
=> SScope userOrSystem
853866
-> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString)))
854867
-> (RuleId -> RuleExecCmd userOrSystem -> IO ())
855868
-> Verbosity
@@ -858,6 +871,12 @@ executeRulesUserOrSystem
858871
-> Map RuleId (RuleData userOrSystem)
859872
-> IO ()
860873
executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo allRules = do
874+
-- Load the rule cache from the previous build.
875+
-- Used to detect when rule definitions have changed.
876+
oldRules <- handleDoesNotExist Map.empty $ do
877+
-- NB: do a strict read to avoid retaining the file handle.
878+
bs <- BS.readFile rulesCacheFile
879+
fromRight Map.empty <$> structuredDecodeOrFailIO (LBS.fromStrict bs)
861880
-- Compute all extra dynamic dependency edges.
862881
dynDepsEdges <-
863882
flip Map.traverseMaybeWithKey allRules $
@@ -939,7 +958,8 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
939958
, " it is not in the appropriate 'autogenComponentModules' directory)"
940959
]
941960

942-
-- Run all the demanded rules, in dependency order.
961+
-- Run all the demanded rules, in dependency order, propagating staleness.
962+
staleRulesRef <- newIORef Set.empty
943963
for_ sccs $ \(Graph.Node ruleVertex _) ->
944964
-- Don't run a rule unless it is demanded.
945965
unless (ruleVertex `Set.member` nonDemandedRuleVerts) $ do
@@ -960,16 +980,27 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
960980
case NE.nonEmpty missingRuleDeps of
961981
Just missingDeps ->
962982
errorOut $ CantFindSourceForRuleDependencies (toRuleBinary r) missingDeps
963-
-- Dependencies OK: run the associated action.
983+
-- Dependencies OK: check whether the rule is up to date before
984+
-- deciding to run it.
964985
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 ()
986+
let dynDeps = maybe [] fst (Map.lookup rId dynDepsEdges)
987+
upToDate <- ruleUpToDate mbWorkDir oldRules staleRulesRef rId r dynDeps
988+
if upToDate
989+
then
990+
info verbosity $
991+
"Rule " ++ show rId ++ " is up to date; skipping."
992+
else do
993+
modifyIORef' staleRulesRef (Set.insert rId)
994+
let execCmd = ruleExecCmd scope cmds (snd <$> mbDyn)
995+
runCmdData rId execCmd
996+
-- Throw an error if running the action did not result in
997+
-- the generation of outputs that we expected it to.
998+
missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList reslts
999+
for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->
1000+
errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults
1001+
return ()
1002+
-- Save the current rules to the cache for use in the next build.
1003+
structuredEncodeFile rulesCacheFile allRules
9731004
where
9741005
toRuleBinary :: RuleData userOrSystem -> RuleBinary
9751006
toRuleBinary = case scope of
@@ -978,6 +1009,7 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
9781009
clbi = targetCLBI tgtInfo
9791010
mbWorkDir = mbWorkDirLBI lbi
9801011
compAutogenDir = autogenComponentModulesDir lbi clbi
1012+
rulesCacheFile = interpretSymbolicPath mbWorkDir (preBuildRulesCacheFile lbi clbi)
9811013
errorOut e =
9821014
dieWithException verbosity $
9831015
SetupHooksException $
@@ -987,6 +1019,59 @@ directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId
9871019
directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep
9881020
directRuleDependencyMaybe (FileDependency{}) = Nothing
9891021

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