Commit a432cffc authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Move ArgsHash oracle to the library

See #347
parent fe857d07
......@@ -27,8 +27,8 @@ executable hadrian
, Flavour
, GHC
, Hadrian.Expression
, Hadrian.Oracles.ArgsHash
, Hadrian.Target
, Oracles.ArgsHash
, Oracles.Config
, Oracles.Config.Flag
, Oracles.Config.Setting
......
{-# LANGUAGE DeriveGeneric, LambdaCase #-}
module Builder (
CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..),
trackedArgument, isOptional
CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..), isOptional
) where
import Data.Char
import GHC.Generics
import Base
......@@ -65,17 +63,6 @@ isOptional = \case
Objdump -> True
_ -> False
-- | Some arguments do not affect build results and therefore do not need to be
-- tracked by the build system. A notable example is "-jN" that controls Make's
-- parallelism. Given a 'Builder' and an argument, this function should return
-- 'True' only if the argument needs to be tracked.
trackedArgument :: Builder -> String -> Bool
trackedArgument (Make _) = not . threadArg
trackedArgument _ = const True
threadArg :: String -> Bool
threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="]
instance Binary Builder
instance Hashable Builder
instance NFData Builder
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Oracles.ArgsHash (checkArgsHash, argsHashOracle) where
module Hadrian.Oracles.ArgsHash (
TrackArgument, trackAllArguments, checkArgsHash, argsHashOracle
) where
import Base
import Builder
import Expression
import Settings
import Target
import Control.Monad
import Development.Shake
import Development.Shake.Classes
newtype ArgsHashKey = ArgsHashKey Target
import Hadrian.Expression
import Hadrian.Target
-- | 'TrackArgument' is used to specify the arguments that should be tracked by
-- the @ArgsHash@ oracle. The safest option is to track all arguments, but some
-- arguments, such as @-jN@, do not change the build results, hence there is no
-- need to initiate unnecessary rebuild if they are added to or removed from a
-- command line. If all arguments should be tracked, use 'trackAllArguments'.
type TrackArgument c b = Target c b -> String -> Bool
-- | Returns 'True' for all targets and arguments, hence can be used a safe
-- default for 'argsHashOracle'.
trackAllArguments :: TrackArgument c b
trackAllArguments _ _ = True
newtype ArgsHashKey c b = ArgsHashKey (Target c b)
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
-- TODO: Hash Target to improve accuracy and performance.
-- | Given a full target this Action determines the corresponding argument list
-- | Given a 'Target' this 'Action' determines the corresponding argument list
-- and computes its hash. The resulting value is tracked in a Shake oracle,
-- hence initiating rebuilds when the hash changes (a hash change indicates
-- changes in the build command for the given target).
-- Note: we keep only the first target input for performance reasons -- to
-- avoid storing long lists of source files passed to some builders (e.g. Ar)
-- Note: for efficiency we replace the list of input files with its hash to
-- avoid storing long lists of source files passed to some builders (e.g. ar)
-- in the Shake database. This optimisation is normally harmless, because
-- argument list constructors are assumed not to examine target sources, but
-- only append them to argument lists where appropriate.
checkArgsHash :: Target -> Action ()
checkArgsHash :: (ShakeValue c, ShakeValue b) => Target c b -> Action ()
checkArgsHash t = do
let hashedInputs = [ show $ hash (inputs t) ]
let hashedInputs = [ show $ hash (inputs t) ]
hashedTarget = target (context t) (builder t) hashedInputs (outputs t)
void (askOracle $ ArgsHashKey hashedTarget :: Action Int)
-- | Oracle for storing per-target argument list hashes.
argsHashOracle :: Rules ()
argsHashOracle = void $
argsHashOracle :: (ShakeValue c, ShakeValue b) => TrackArgument c b -> Args c b -> Rules ()
argsHashOracle trackArgument args = void $
addOracle $ \(ArgsHashKey target) -> do
argList <- interpret target getArgs
let trackedArgList = filter (trackedArgument $ builder target) argList
argList <- interpret target args
let trackedArgList = filter (trackArgument target) argList
return $ hash trackedArgList
{-# LANGUAGE DeriveGeneric #-}
module Hadrian.Target (Target, target, context, builder, inputs, outputs) where
import Development.Shake.Classes
import GHC.Generics
import Base
-- | Each invocation of a builder is fully described by a 'Target', which
-- comprises a build context (type variable @c@), a builder (type variable @b@),
-- a list of input files and a list of output files. For example:
......
module Rules.Oracles (oracleRules) where
import qualified Hadrian.Oracles.ArgsHash
import Base
import qualified Oracles.ArgsHash
import qualified Oracles.Config
import qualified Oracles.Dependencies
import qualified Oracles.DirectoryContents
import qualified Oracles.ModuleFiles
import qualified Oracles.PackageData
import qualified Oracles.Path
import Target
import Settings
oracleRules :: Rules ()
oracleRules = do
Oracles.ArgsHash.argsHashOracle
Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
Oracles.Config.configOracle
Oracles.Dependencies.dependenciesOracles
Oracles.DirectoryContents.directoryContentsOracle
......
......@@ -12,6 +12,7 @@ import Oracles.Config.Setting
import Oracles.ModuleFiles
import Settings
import Settings.Builders.Ar
import Target
import UserSettings
instance Arbitrary Way where
......@@ -36,11 +37,12 @@ selftestRules =
testBuilder :: Action ()
testBuilder = do
putBuild $ "==== trackedArgument"
putBuild $ "==== trackArgument"
let make = target undefined (Make undefined) undefined undefined
test $ forAll (elements ["-j", "MAKEFLAGS=-j", "THREADS="])
$ \prefix (NonNegative n) ->
trackedArgument (Make undefined) prefix == False &&
trackedArgument (Make undefined) ("-j" ++ show (n :: Int)) == False
trackArgument make prefix == False &&
trackArgument make ("-j" ++ show (n :: Int)) == False
testChunksOfSize :: Action ()
testChunksOfSize = do
......
module Target (Target, target, context, builder, inputs, outputs) where
module Target (
Target, target, context, builder, inputs, outputs, trackArgument
) where
import Builder
import Context
import Data.Char
import Data.List.Extra
import qualified Hadrian.Target as H
import Hadrian.Target hiding (Target)
import Builder
import Context
type Target = H.Target Context Builder
-- | Some arguments do not affect build results and therefore do not need to be
-- tracked by the build system. A notable example is "-jN" that controls Make's
-- parallelism. Given a 'Target' and an argument, this function should return
-- 'True' only if the argument needs to be tracked.
trackArgument :: Target -> String -> Bool
trackArgument target arg = case builder target of
(Make _) -> not $ threadArg arg
_ -> True
where
threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="]
......@@ -11,12 +11,13 @@ import qualified System.Directory.Extra as IO
import qualified System.IO as IO
import qualified Control.Exception.Base as IO
import Hadrian.Oracles.ArgsHash
import Base
import CmdLineFlag
import Context
import Expression
import GHC
import Oracles.ArgsHash
import Oracles.DirectoryContents
import Oracles.Path
import Oracles.Config.Setting
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment