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