Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
a432cffc
Commit
a432cffc
authored
Aug 06, 2017
by
Andrey Mokhov
Browse files
Move ArgsHash oracle to the library
See
#347
parent
fe857d07
Changes
8
Hide whitespace changes
Inline
Side-by-side
hadrian.cabal
View file @
a432cffc
...
...
@@ -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
...
...
src/Builder.hs
View file @
a432cffc
{-# 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
...
...
src/Oracles/ArgsHash.hs
→
src/
Hadrian/
Oracles/ArgsHash.hs
View file @
a432cffc
{-# 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.
A
r)
-- 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.
a
r)
-- 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
getA
rgs
let
trackedArgList
=
filter
(
track
ed
Argument
$
builder
target
)
argList
argList
<-
interpret
target
a
rgs
let
trackedArgList
=
filter
(
trackArgument
target
)
argList
return
$
hash
trackedArgList
src/Hadrian/Target.hs
View file @
a432cffc
{-# 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:
...
...
src/Rules/Oracles.hs
View file @
a432cffc
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
...
...
src/Rules/Selftest.hs
View file @
a432cffc
...
...
@@ -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
)
->
track
ed
Argument
(
M
ake
undefined
)
prefix
==
False
&&
track
ed
Argument
(
M
ake
undefined
)
(
"-j"
++
show
(
n
::
Int
))
==
False
trackArgument
m
ake
prefix
==
False
&&
trackArgument
m
ake
(
"-j"
++
show
(
n
::
Int
))
==
False
testChunksOfSize
::
Action
()
testChunksOfSize
=
do
...
...
src/Target.hs
View file @
a432cffc
module
Target
(
Target
,
target
,
context
,
builder
,
inputs
,
outputs
)
where
module
Target
(
Target
,
target
,
context
,
builder
,
inputs
,
outputs
,
trackArgument
)
where
import
Builde
r
import
Context
import
Data.Cha
r
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="
]
src/Util.hs
View file @
a432cffc
...
...
@@ -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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment