Move ArgsHash oracle to the library
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Sat, 5 Aug 2017 23:55:44 +0000 (00:55 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Sat, 5 Aug 2017 23:55:44 +0000 (00:55 +0100)
See #347

hadrian.cabal
src/Builder.hs
src/Hadrian/Oracles/ArgsHash.hs [new file with mode: 0644]
src/Hadrian/Target.hs
src/Oracles/ArgsHash.hs [deleted file]
src/Rules/Oracles.hs
src/Rules/Selftest.hs
src/Target.hs
src/Util.hs

index 7211f24..121ba74 100644 (file)
@@ -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
index 4112900..43768a3 100644 (file)
@@ -1,10 +1,8 @@
 {-# 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
diff --git a/src/Hadrian/Oracles/ArgsHash.hs b/src/Hadrian/Oracles/ArgsHash.hs
new file mode 100644 (file)
index 0000000..0eba6c2
--- /dev/null
@@ -0,0 +1,49 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Hadrian.Oracles.ArgsHash (
+    TrackArgument, trackAllArguments, checkArgsHash, argsHashOracle
+    ) where
+
+import Control.Monad
+import Development.Shake
+import Development.Shake.Classes
+
+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)
+
+-- | 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: 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 :: (ShakeValue c, ShakeValue b) => Target c b -> Action ()
+checkArgsHash t = do
+    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 :: (ShakeValue c, ShakeValue b) => TrackArgument c b -> Args c b -> Rules ()
+argsHashOracle trackArgument args = void $
+    addOracle $ \(ArgsHashKey target) -> do
+        argList <- interpret target args
+        let trackedArgList = filter (trackArgument target) argList
+        return $ hash trackedArgList
index e400ad9..fbcfd8c 100644 (file)
@@ -1,10 +1,9 @@
 {-# 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:
diff --git a/src/Oracles/ArgsHash.hs b/src/Oracles/ArgsHash.hs
deleted file mode 100644 (file)
index 439b65f..0000000
+++ /dev/null
@@ -1,35 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Oracles.ArgsHash (checkArgsHash, argsHashOracle) where
-
-import Base
-import Builder
-import Expression
-import Settings
-import Target
-
-newtype ArgsHashKey = ArgsHashKey Target
-    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
--- 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)
--- 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 t = do
-    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 $
-    addOracle $ \(ArgsHashKey target) -> do
-        argList <- interpret target getArgs
-        let trackedArgList = filter (trackedArgument $ builder target) argList
-        return $ hash trackedArgList
index 8f53369..a12bec4 100644 (file)
@@ -1,17 +1,20 @@
 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
index 0a63641..322befc 100644 (file)
@@ -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
index eb50f65..c3a117b 100644 (file)
@@ -1,9 +1,25 @@
-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="]
index 2d564d1..ed535fe 100644 (file)
@@ -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