Commit 196430d4 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add argsHashOracle for tracking changes in the build system.

parent 35d9a072
...@@ -48,7 +48,7 @@ previously: pass the final lists of arguments through oracles. Care must ...@@ -48,7 +48,7 @@ previously: pass the final lists of arguments through oracles. Care must
be taken though as final command lines can be as large as 5Mb and may bloat be taken though as final command lines can be as large as 5Mb and may bloat
the Shake database! the Shake database!
=> hash command lines and channel them through oracles => DONE: hash command lines and channel them through oracles
================================================ ================================================
...@@ -148,6 +148,7 @@ getPackage, getBuilder, getFile, getWay. Hence, it may be OK to have only ...@@ -148,6 +148,7 @@ getPackage, getBuilder, getFile, getWay. Hence, it may be OK to have only
GetStage env, (GetStage env, GetPackage env), etc. GetStage env, (GetStage env, GetPackage env), etc.
============================================== ==============================================
DONE:
stageEnvironment :: Environment stageEnvironment :: Environment
stageEnvironment stage = Environment stageEnvironment stage = Environment
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Base ( module Base (
...@@ -22,12 +23,17 @@ import Control.Applicative ...@@ -22,12 +23,17 @@ import Control.Applicative
import Data.Function import Data.Function
import Data.Monoid import Data.Monoid
import Data.List import Data.List
import GHC.Generics
import Development.Shake.Classes
data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum) data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum, Generic)
instance Show Stage where instance Show Stage where
show = show . fromEnum show = show . fromEnum
instance Binary Stage
instance Hashable Stage
-- The returned string or list of strings is a part of an argument list -- The returned string or list of strings is a part of an argument list
-- to be passed to a Builder -- to be passed to a Builder
type Arg = Action String type Arg = Action String
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression ( module Expression (
module Control.Monad.Reader, module Control.Monad.Reader,
...@@ -17,6 +18,8 @@ import Ways ...@@ -17,6 +18,8 @@ import Ways
import Oracles import Oracles
import Package import Package
import Data.Monoid import Data.Monoid
import Development.Shake.Classes
import GHC.Generics
import Control.Monad.Reader import Control.Monad.Reader
-- Target captures parameters relevant to the current build target: Stage and -- Target captures parameters relevant to the current build target: Stage and
...@@ -30,6 +33,19 @@ data Target = Target ...@@ -30,6 +33,19 @@ data Target = Target
getFile :: FilePath, -- TODO: handle multple files? getFile :: FilePath, -- TODO: handle multple files?
getWay :: Way getWay :: Way
} }
deriving (Eq, Generic)
-- Shows a target as "package:file@stage (builder, way)"
instance Show Target where
show target = show (getPackage target)
++ ":" ++ show (getFile target)
++ "@" ++ show (getStage target)
++ " (" ++ show (getBuilder target)
++ ", " ++ show (getWay target) ++ ")"
instance Binary Target
instance NFData Target
instance Hashable Target
stageTarget :: Stage -> Target stageTarget :: Stage -> Target
stageTarget stage = Target stageTarget stage = Target
......
import Base import Base
import Rules import Rules
import Config import Config
import Oracles
main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do
oracleRules -- see module Oracles oracleRules -- see module Rules.Oracles
packageRules -- see module Rules packageRules -- see module Rules
autoconfRules -- see module Config autoconfRules -- see module Config
configureRules -- see module Config configureRules -- see module Config
generateTargets -- see module Rules generateTargets -- see module Rules
...@@ -5,7 +5,7 @@ module Oracles ( ...@@ -5,7 +5,7 @@ module Oracles (
module Oracles.Builder, module Oracles.Builder,
module Oracles.PackageData, module Oracles.PackageData,
module Oracles.DependencyList, module Oracles.DependencyList,
oracleRules configOracle, packageDataOracle, dependencyOracle
) where ) where
import Development.Shake.Config import Development.Shake.Config
...@@ -82,9 +82,6 @@ dependencyOracle = do ...@@ -82,9 +82,6 @@ dependencyOracle = do
M.lookup (unifyPath obj) <$> deps (unifyPath file) M.lookup (unifyPath obj) <$> deps (unifyPath file)
return () return ()
oracleRules :: Rules ()
oracleRules = configOracle <> packageDataOracle <> dependencyOracle
-- Make oracle's output more distinguishable -- Make oracle's output more distinguishable
putOracle :: String -> Action () putOracle :: String -> Action ()
putOracle = putColoured Blue putOracle = putColoured Blue
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.ArgsHash (
ArgsHashKey (..), askArgsHash, argsHashOracle
) where
import Development.Shake.Classes
import Base
import Expression
import Settings
newtype ArgsHashKey = ArgsHashKey Target
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
askArgsHash :: Target -> Action Int
askArgsHash = askOracle . ArgsHashKey
-- Oracle for storing per-target argument list hashes
argsHashOracle :: Rules ()
argsHashOracle = do
addOracle $ \(ArgsHashKey target) -> hash <$> interpret target settings
return ()
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Oracles.Builder ( module Oracles.Builder (
...@@ -11,6 +12,8 @@ import Util ...@@ -11,6 +12,8 @@ import Util
import Oracles.Base import Oracles.Base
import Oracles.Flag import Oracles.Flag
import Oracles.Option import Oracles.Option
import GHC.Generics
import Development.Shake.Classes
-- A Builder is an external command invoked in separate process using Shake.cmd -- A Builder is an external command invoked in separate process using Shake.cmd
-- --
...@@ -29,7 +32,10 @@ data Builder = Ar ...@@ -29,7 +32,10 @@ data Builder = Ar
| Gcc Stage | Gcc Stage
| Ghc Stage | Ghc Stage
| GhcPkg Stage | GhcPkg Stage
deriving (Show, Eq) deriving (Show, Eq, Generic)
instance Binary Builder
instance Hashable Builder
builderKey :: Builder -> String builderKey :: Builder -> String
builderKey builder = case builder of builderKey builder = case builder of
......
{-# LANGUAGE DeriveGeneric #-}
module Package (Package (..), library, topLevel, setCabal) where module Package (Package (..), library, topLevel, setCabal) where
import Base import Base
import Util import Util
import GHC.Generics
import Development.Shake.Classes
-- pkgPath is the path to the source code relative to the root -- pkgPath is the path to the source code relative to the root
data Package = Package data Package = Package
...@@ -10,6 +14,7 @@ data Package = Package ...@@ -10,6 +14,7 @@ data Package = Package
pkgPath :: FilePath, -- "libraries/deepseq", "libraries/Cabal/Cabal" pkgPath :: FilePath, -- "libraries/deepseq", "libraries/Cabal/Cabal"
pkgCabal :: FilePath -- "deepseq.cabal", "Cabal.cabal" (relative) pkgCabal :: FilePath -- "deepseq.cabal", "Cabal.cabal" (relative)
} }
deriving Generic
instance Show Package where instance Show Package where
show = pkgName show = pkgName
...@@ -20,6 +25,11 @@ instance Eq Package where ...@@ -20,6 +25,11 @@ instance Eq Package where
instance Ord Package where instance Ord Package where
compare = compare `on` pkgName compare = compare `on` pkgName
instance Binary Package
instance Hashable Package where
hashWithSalt salt = hashWithSalt salt . show
-- TODO: check if unifyPath is actually needed -- TODO: check if unifyPath is actually needed
library :: String -> Package library :: String -> Package
library name = library name =
......
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Rules ( module Rules (
generateTargets, packageRules, generateTargets, packageRules, oracleRules,
module Rules.Package, module Rules.Package,
) where ) where
...@@ -8,6 +8,7 @@ import Base hiding (arg, args, Args) ...@@ -8,6 +8,7 @@ import Base hiding (arg, args, Args)
import Control.Monad import Control.Monad
import Expression import Expression
import Rules.Package import Rules.Package
import Rules.Oracles
import Settings.Packages import Settings.Packages
import Settings.TargetDirectory import Settings.TargetDirectory
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Rules.Data ( module Rules.Data (
cabalSettings, ghcPkgSettings, buildPackageData cabalSettings, ghcPkgSettings, buildPackageData
) where ) where
...@@ -7,11 +9,13 @@ import Package ...@@ -7,11 +9,13 @@ import Package
import Expression hiding (when, liftIO) import Expression hiding (when, liftIO)
import Oracles.Flag (when) import Oracles.Flag (when)
import Oracles.Builder import Oracles.Builder
import Oracles.ArgsHash
import Settings import Settings
import Settings.GhcPkg import Settings.GhcPkg
import Settings.GhcCabal import Settings.GhcCabal
import Settings.TargetDirectory import Settings.TargetDirectory
import Util import Util
import Ways
-- Build package-data.mk by using GhcCabal to process pkgCabal file -- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData :: Target -> Rules () buildPackageData :: Target -> Rules ()
...@@ -31,21 +35,25 @@ buildPackageData target = ...@@ -31,21 +35,25 @@ buildPackageData target =
] &%> \_ -> do ] &%> \_ -> do
let configure = pkgPath pkg </> "configure" let configure = pkgPath pkg </> "configure"
-- TODO: 1) how to automate this? 2) handle multiple files? -- TODO: 1) how to automate this? 2) handle multiple files?
newEnv = target { getFile = path </> "package-data.mk" } newTarget = target { getFile = path </> "package-data.mk" }
-- GhcCabal will run the configure script, so we depend on it -- GhcCabal will run the configure script, so we depend on it
need [pkgPath pkg </> pkgCabal pkg] need [pkgPath pkg </> pkgCabal pkg]
-- We still don't know who built the configure script from configure.ac -- We still don't know who built the configure script from configure.ac
when (doesFileExist $ configure <.> "ac") $ need [configure] when (doesFileExist $ configure <.> "ac") $ need [configure]
run' newEnv GhcCabal run' newTarget GhcCabal
-- TODO: when (registerPackage settings) $ -- TODO: when (registerPackage settings) $
run' newEnv (GhcPkg stage) run' newTarget (GhcPkg stage)
postProcessPackageData $ path </> "package-data.mk" postProcessPackageData $ path </> "package-data.mk"
-- TODO: This should probably go to Oracles.Builder -- TODO: This should probably go to Oracles.Builder
run' :: Target -> Builder -> Action () run' :: Target -> Builder -> Action ()
run' target builder = do run' target builder = do
args <- interpret (target {getBuilder = builder}) settings let finalTarget = target {getBuilder = builder, getWay = vanilla }
args <- interpret finalTarget settings
putColoured Green (show args) putColoured Green (show args)
-- The line below forces the rule to be rerun if the hash has changed
argsHash <- askArgsHash finalTarget
putColoured Yellow (show argsHash)
run builder args run builder args
-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile: -- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
......
module Rules.Oracles (
oracleRules
) where
import Base hiding (arg, args, Args)
import Oracles
import Oracles.ArgsHash
oracleRules :: Rules ()
oracleRules =
configOracle <> packageDataOracle <> dependencyOracle <> argsHashOracle
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module Ways ( -- TODO: rename to "Way"? module Ways ( -- TODO: rename to "Way"?
WayUnit (..), WayUnit (..),
...@@ -20,6 +21,8 @@ module Ways ( -- TODO: rename to "Way"? ...@@ -20,6 +21,8 @@ module Ways ( -- TODO: rename to "Way"?
import Base import Base
import Oracles import Oracles
import GHC.Generics
import Development.Shake.Classes
data WayUnit = Profiling data WayUnit = Profiling
| Logging | Logging
...@@ -28,18 +31,24 @@ data WayUnit = Profiling ...@@ -28,18 +31,24 @@ data WayUnit = Profiling
| Threaded | Threaded
| Debug | Debug
| Dynamic | Dynamic
deriving Eq deriving (Eq, Generic)
-- TODO: think about Booleans instead of a list of ways. -- TODO: think about Booleans instead of a list of ways.
data Way = Way data Way = Way
{ {
tag :: String, -- e.g., "thr_p" tag :: String, -- e.g., "thr_p"
units :: [WayUnit] -- e.g., [Threaded, Profiling] units :: [WayUnit] -- e.g., [Threaded, Profiling]
} } deriving Generic
instance Show Way where instance Show Way where
show = tag show = tag
instance Binary WayUnit
instance Binary Way
instance Hashable Way where
hashWithSalt salt = hashWithSalt salt . show
instance Eq Way where instance Eq Way where
-- The tag is fully determined by the units -- The tag is fully determined by the units
a == b = units a == units b a == b = units a == units b
......
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