Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
e8b62f7e
Commit
e8b62f7e
authored
Feb 12, 2016
by
Andrey Mokhov
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Factor out Context from Target.
See
#207
.
parent
2c219087
Changes
20
Hide whitespace changes
Inline
Side-by-side
Showing
20 changed files
with
278 additions
and
272 deletions
+278
-272
shaking-up-ghc.cabal
shaking-up-ghc.cabal
+1
-0
src/Context.hs
src/Context.hs
+28
-0
src/Expression.hs
src/Expression.hs
+11
-13
src/Oracles/PackageDb.hs
src/Oracles/PackageDb.hs
+2
-2
src/Rules.hs
src/Rules.hs
+6
-6
src/Rules/Actions.hs
src/Rules/Actions.hs
+11
-11
src/Rules/Cabal.hs
src/Rules/Cabal.hs
+2
-2
src/Rules/Compile.hs
src/Rules/Compile.hs
+18
-14
src/Rules/Data.hs
src/Rules/Data.hs
+35
-32
src/Rules/Dependencies.hs
src/Rules/Dependencies.hs
+12
-8
src/Rules/Documentation.hs
src/Rules/Documentation.hs
+13
-10
src/Rules/Generate.hs
src/Rules/Generate.hs
+18
-16
src/Rules/Gmp.hs
src/Rules/Gmp.hs
+8
-7
src/Rules/Libffi.hs
src/Rules/Libffi.hs
+9
-8
src/Rules/Library.hs
src/Rules/Library.hs
+34
-30
src/Rules/Package.hs
src/Rules/Package.hs
+2
-2
src/Rules/Program.hs
src/Rules/Program.hs
+38
-35
src/Rules/Register.hs
src/Rules/Register.hs
+15
-11
src/Target.hs
src/Target.hs
+9
-58
src/Test.hs
src/Test.hs
+6
-7
No files found.
shaking-up-ghc.cabal
View file @
e8b62f7e
...
...
@@ -20,6 +20,7 @@ executable ghc-shake
other-modules: Base
, Builder
, CmdLineFlag
, Context
, Environment
, Expression
, GHC
...
...
src/Context.hs
0 → 100644
View file @
e8b62f7e
{-# LANGUAGE DeriveGeneric #-}
module
Context
(
Context
(
..
),
vanillaContext
,
stageContext
)
where
import
GHC.Generics
(
Generic
)
import
Base
import
Package
import
Stage
import
Way
-- | Build context for a currently built 'Target'. We generate potentially
-- different build rules for each 'Context'.
data
Context
=
Context
{
stage
::
Stage
-- ^ Currently build Stage
,
package
::
Package
-- ^ Currently build Package
,
way
::
Way
-- ^ Currently build Way (usually 'vanilla')
}
deriving
(
Show
,
Eq
,
Generic
)
-- | Most targets are built only one way, hence the notion of 'vanillaContext'.
vanillaContext
::
Stage
->
Package
->
Context
vanillaContext
s
p
=
Context
s
p
vanilla
stageContext
::
Stage
->
Context
stageContext
s
=
vanillaContext
s
$
error
"stageContext: package not set"
instance
Binary
Context
instance
NFData
Context
instance
Hashable
Context
src/Expression.hs
View file @
e8b62f7e
...
...
@@ -6,13 +6,13 @@ module Expression (
apply
,
append
,
arg
,
remove
,
removePair
,
appendSub
,
appendSubD
,
filterSub
,
removeSub
,
-- ** Evaluation
interpret
,
interpret
Partial
,
interpretWithStage
,
interpretDiff
,
interpret
,
interpret
InContext
,
interpretDiff
,
-- ** Predicates
Predicate
,
(
?
),
applyPredicate
,
-- ** Common expressions
Args
,
Ways
,
Packages
,
-- ** Target
s
Target
,
PartialTarget
(
..
),
unsafeFromPartial
,
full
Target
,
full
Target
WithWay
,
-- **
Context and
Target
Context
,
vanillaContext
,
stageContext
,
Target
,
dummy
Target
,
-- * Convenient accessors
getStage
,
getPackage
,
getBuilder
,
getOutputs
,
getInputs
,
getWay
,
...
...
@@ -30,6 +30,7 @@ import Control.Monad.Trans.Reader
import
Data.Monoid
import
Base
import
Context
import
Package
import
Builder
import
Stage
...
...
@@ -146,16 +147,13 @@ filterSub prefix p = apply $ map filterSubstr
removeSub
::
String
->
[
String
]
->
Args
removeSub
prefix
xs
=
filterSub
prefix
(`
notElem
`
xs
)
-- | Interpret a given expression
in a given environment
.
-- | Interpret a given expression
according to the given 'Target'
.
interpret
::
Target
->
Expr
a
->
Action
a
interpret
=
flip
runReaderT
interpretPartial
::
PartialTarget
->
Expr
a
->
Action
a
interpretPartial
=
interpret
.
unsafeFromPartial
interpretWithStage
::
Stage
->
Expr
a
->
Action
a
interpretWithStage
s
=
interpretPartial
$
PartialTarget
s
(
error
"interpretWithStage: package not set"
)
-- | Interpret a given expression by looking only at the given 'Context'.
interpretInContext
::
Context
->
Expr
a
->
Action
a
interpretInContext
=
interpret
.
dummyTarget
-- | Extract an expression from a difference expression.
fromDiffExpr
::
Monoid
a
=>
DiffExpr
a
->
Expr
a
...
...
@@ -167,11 +165,11 @@ interpretDiff target = interpret target . fromDiffExpr
-- | Convenient getters for target parameters.
getStage
::
Expr
Stage
getStage
=
asks
stage
getStage
=
stage
<$>
asks
context
-- | Get the 'Package' of the current 'Target'.
getPackage
::
Expr
Package
getPackage
=
asks
package
getPackage
=
package
<$>
asks
context
-- | Get the 'Builder' for the current 'Target'.
getBuilder
::
Expr
Builder
...
...
@@ -179,7 +177,7 @@ getBuilder = asks builder
-- | Get the 'Way' of the current 'Target'.
getWay
::
Expr
Way
getWay
=
asks
way
getWay
=
way
<$>
asks
context
-- | Get the input files of the current 'Target'.
getInputs
::
Expr
[
FilePath
]
...
...
src/Oracles/PackageDb.hs
View file @
e8b62f7e
...
...
@@ -3,6 +3,7 @@ module Oracles.PackageDb (packageDbOracle) where
import
qualified
System.Directory
as
IO
import
Base
import
Context
hiding
(
stage
)
import
Builder
import
GHC
import
Rules.Actions
...
...
@@ -16,8 +17,7 @@ packageDbOracle = do
let
dir
=
packageDbDirectory
stage
file
=
dir
-/-
"package.cache"
unlessM
(
liftIO
$
IO
.
doesFileExist
file
)
$
do
let
target
=
PartialTarget
stage
ghcPkg
removeDirectoryIfExists
dir
build
$
full
Target
ta
r
ge
t
(
GhcPkg
stage
)
[]
[
dir
]
build
$
Target
(
vanillaContext
s
tage
ghcPkg
)
(
GhcPkg
stage
)
[]
[
dir
]
putSuccess
$
"| Successfully initialised "
++
dir
return
()
src/Rules.hs
View file @
e8b62f7e
...
...
@@ -3,7 +3,7 @@ module Rules (topLevelTargets, packageRules) where
import
Base
import
Data.Foldable
import
Expression
import
GHC
import
GHC
hiding
(
haddock
)
import
qualified
Rules.Generate
import
Rules.Package
import
Rules.Resources
...
...
@@ -27,14 +27,14 @@ topLevelTargets = do
for_
allStages
$
\
stage
->
for_
(
knownPackages
\\
[
rts
,
libffi
])
$
\
pkg
->
action
$
do
let
target
=
PartialTarge
t
stage
pkg
activePackages
<-
interpret
Partial
targe
t
getPackages
let
context
=
vanillaContex
t
stage
pkg
activePackages
<-
interpret
InContext
contex
t
getPackages
when
(
pkg
`
elem
`
activePackages
)
$
if
isLibrary
pkg
then
do
-- build a library
ways
<-
interpret
Partial
targe
t
getLibraryWays
ways
<-
interpret
InContext
contex
t
getLibraryWays
libs
<-
traverse
(
pkgLibraryFile
stage
pkg
)
ways
haddock
<-
interpret
Partial
targe
t
buildHaddock
haddock
<-
interpret
InContext
contex
t
buildHaddock
need
$
libs
++
[
pkgHaddockFile
pkg
|
haddock
&&
stage
==
Stage1
]
else
do
-- otherwise build a program
need
[
fromJust
$
programPath
stage
pkg
]
-- TODO: drop fromJust
...
...
@@ -44,4 +44,4 @@ packageRules = do
resources
<-
resourceRules
for_
allStages
$
\
stage
->
for_
knownPackages
$
\
pkg
->
buildPackage
resources
$
PartialTarge
t
stage
pkg
buildPackage
resources
$
vanillaContex
t
stage
pkg
src/Rules/Actions.hs
View file @
e8b62f7e
...
...
@@ -11,20 +11,20 @@ import qualified Control.Exception.Base as IO
import
Base
import
CmdLineFlag
import
Context
import
Expression
import
Oracles.ArgsHash
import
Oracles.WindowsPath
import
Settings
import
Settings.Args
import
Settings.Builders.Ar
import
qualified
Target
import
Target
-- Build a given target using an appropriate builder and acquiring necessary
-- resources. Force a rebuilt if the argument list has changed since the last
-- built (that is, track changes in the build system).
buildWithResources
::
[(
Resource
,
Int
)]
->
Target
->
Action
()
buildWithResources
rs
target
=
do
let
builder
=
Target
.
builder
target
buildWithResources
rs
target
@
Target
{
..
}
=
do
needBuilder
laxDependencies
builder
path
<-
builderPath
builder
argList
<-
interpret
target
getArgs
...
...
@@ -160,15 +160,15 @@ makeExecutable file = do
quietly
$
cmd
"chmod +x "
[
file
]
-- Print out key information about the command being executed
putInfo
::
Target
.
Target
->
Action
()
putInfo
Target
.
Target
{
..
}
=
putProgressInfo
$
renderAction
(
"Run "
++
show
builder
++
" ("
++
stageInfo
++
"package = "
++
pkgNameString
package
++
wayInfo
++
")"
)
(
digest
inputs
)
(
digest
outputs
)
putInfo
::
Target
->
Action
()
putInfo
Target
{
..
}
=
putProgressInfo
$
renderAction
(
"Run "
++
show
builder
++
contextInfo
)
(
digest
inputs
)
(
digest
outputs
)
where
stageInfo
=
if
isStaged
builder
then
""
else
"stage = "
++
show
stage
++
", "
wayInfo
=
if
way
==
vanilla
then
""
else
", way = "
++
show
way
contextInfo
=
concat
$
[
" ("
]
++
[
"stage = "
++
show
(
stage
context
)
]
++
[
", package = "
++
pkgNameString
(
package
context
)
]
++
[
", way = "
++
show
(
way
context
)
|
way
context
/=
vanilla
]
++
[
")"
]
digest
[]
=
"none"
digest
[
x
]
=
x
digest
(
x
:
xs
)
=
x
++
" (and "
++
show
(
length
xs
)
++
" more)"
...
...
src/Rules/Cabal.hs
View file @
e8b62f7e
...
...
@@ -14,7 +14,7 @@ cabalRules :: Rules ()
cabalRules
=
do
-- Cache boot package constraints (to be used in cabalArgs)
bootPackageConstraints
%>
\
out
->
do
bootPkgs
<-
interpret
WithStage
Stage0
getPackages
bootPkgs
<-
interpret
InContext
(
stageContext
Stage0
)
getPackages
let
pkgs
=
filter
(
\
p
->
p
/=
compiler
&&
isLibrary
p
)
bootPkgs
constraints
<-
forM
(
sort
pkgs
)
$
\
pkg
->
do
need
[
pkgCabalFile
pkg
]
...
...
@@ -27,7 +27,7 @@ cabalRules = do
-- Cache package dependencies
packageDependencies
%>
\
out
->
do
pkgs
<-
interpret
WithStage
Stage1
getPackages
pkgs
<-
interpret
InContext
(
stageContext
Stage1
)
getPackages
pkgDeps
<-
forM
(
sort
pkgs
)
$
\
pkg
->
if
pkg
==
rts
then
return
$
pkgNameString
pkg
...
...
src/Rules/Compile.hs
View file @
e8b62f7e
{-# LANGUAGE RecordWildCards #-}
module
Rules.Compile
(
compilePackage
)
where
import
Base
import
Context
import
Expression
import
Oracles.Dependencies
import
Rules.Actions
import
Rules.Resources
import
Settings
import
Target
hiding
(
context
)
compilePackage
::
Resources
->
PartialTarget
->
Rules
()
compilePackage
rs
target
@
(
PartialTarget
stage
pkg
)
=
do
let
buildPath
=
targetPath
stage
pkg
-/-
"build"
-- TODO: Use way from Context, #207
compilePackage
::
Resources
->
Context
->
Rules
()
compilePackage
rs
context
@
(
Context
{
..
})
=
do
let
buildPath
=
targetPath
stage
package
-/-
"build"
matchBuildResult
buildPath
"hi"
?>
\
hi
->
if
compileInterfaceFilesSeparately
&&
not
(
"//HpcParser.*"
?==
hi
)
then
do
let
w
ay
=
detectWay
hi
(
src
,
deps
)
<-
dependencies
buildPath
$
hi
-<.>
osuf
w
ay
let
w
=
detectWay
hi
(
src
,
deps
)
<-
dependencies
buildPath
$
hi
-<.>
osuf
w
need
$
src
:
deps
buildWithResources
[(
resPackageDb
rs
,
1
)]
$
full
Target
WithWay
target
(
Ghc
stage
)
way
[
src
]
[
hi
]
Target
(
context
{
way
=
w
})
(
Ghc
stage
)
[
src
]
[
hi
]
else
need
[
hi
-<.>
osuf
(
detectWay
hi
)
]
matchBuildResult
buildPath
"hi-boot"
?>
\
hiboot
->
if
compileInterfaceFilesSeparately
then
do
let
w
ay
=
detectWay
hiboot
(
src
,
deps
)
<-
dependencies
buildPath
$
hiboot
-<.>
obootsuf
w
ay
let
w
=
detectWay
hiboot
(
src
,
deps
)
<-
dependencies
buildPath
$
hiboot
-<.>
obootsuf
w
need
$
src
:
deps
buildWithResources
[(
resPackageDb
rs
,
1
)]
$
full
Target
WithWay
target
(
Ghc
stage
)
way
[
src
]
[
hiboot
]
Target
(
context
{
way
=
w
})
(
Ghc
stage
)
[
src
]
[
hiboot
]
else
need
[
hiboot
-<.>
obootsuf
(
detectWay
hiboot
)
]
-- TODO: add dependencies for #include of .h and .hs-incl files (gcc -MM?)
...
...
@@ -37,21 +41,21 @@ compilePackage rs target @ (PartialTarget stage pkg) = do
if
(
"//*.c"
?==
src
)
then
do
need
$
src
:
deps
build
$
full
Target
targe
t
(
Gcc
stage
)
[
src
]
[
obj
]
build
$
Target
contex
t
(
Gcc
stage
)
[
src
]
[
obj
]
else
do
let
w
ay
=
detectWay
obj
let
w
=
detectWay
obj
if
compileInterfaceFilesSeparately
&&
"//*.hs"
?==
src
&&
not
(
"//HpcParser.*"
?==
src
)
then
need
$
(
obj
-<.>
hisuf
(
detectWay
obj
))
:
src
:
deps
else
need
$
src
:
deps
buildWithResources
[(
resPackageDb
rs
,
1
)]
$
full
Target
WithWay
target
(
Ghc
stage
)
way
[
src
]
[
obj
]
Target
(
context
{
way
=
w
})
(
Ghc
stage
)
[
src
]
[
obj
]
-- TODO: get rid of these special cases
matchBuildResult
buildPath
"o-boot"
?>
\
obj
->
do
(
src
,
deps
)
<-
dependencies
buildPath
obj
let
w
ay
=
detectWay
obj
let
w
=
detectWay
obj
if
compileInterfaceFilesSeparately
then
need
$
(
obj
-<.>
hibootsuf
(
detectWay
obj
))
:
src
:
deps
else
need
$
src
:
deps
buildWithResources
[(
resPackageDb
rs
,
1
)]
$
full
Target
WithWay
target
(
Ghc
stage
)
way
[
src
]
[
obj
]
Target
(
context
{
way
=
w
})
(
Ghc
stage
)
[
src
]
[
obj
]
src/Rules/Data.hs
View file @
e8b62f7e
{-# LANGUAGE RecordWildCards #-}
module
Rules.Data
(
buildPackageData
)
where
import
qualified
System.Directory
as
IO
import
Base
import
Context
import
Expression
import
GHC
import
Oracles.Config.Setting
...
...
@@ -13,26 +15,27 @@ import Rules.Libffi
import
Rules.Resources
import
Settings
import
Settings.Builders.Common
import
Target
-- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData
::
Resources
->
PartialTarge
t
->
Rules
()
buildPackageData
_
target
@
(
PartialTarget
stage
pkg
)
=
do
let
cabalFile
=
pkgCabalFile
p
kg
configure
=
pkgPath
p
kg
-/-
"configure"
dataFile
=
pkgDataFile
stage
p
kg
oldPath
=
pkgPath
p
kg
-/-
targetDirectory
stage
p
kg
-- TODO: remove, #113
buildPackageData
::
Resources
->
Contex
t
->
Rules
()
buildPackageData
_
context
@
(
Context
{
..
}
)
=
do
let
cabalFile
=
pkgCabalFile
p
ackage
configure
=
pkgPath
p
ackage
-/-
"configure"
dataFile
=
pkgDataFile
stage
p
ackage
oldPath
=
pkgPath
p
ackage
-/-
targetDirectory
stage
p
ackage
-- TODO: remove, #113
[
dataFile
,
oldPath
-/-
"package-data.mk"
]
&%>
\
_
->
do
-- The first thing we do with any package is make sure all generated
-- dependencies are in place before proceeding.
orderOnly
$
generatedDependencies
stage
p
kg
orderOnly
$
generatedDependencies
stage
p
ackage
-- GhcCabal may run the configure script, so we depend on it
whenM
(
doesFileExist
$
configure
<.>
"ac"
)
$
need
[
configure
]
-- Before we configure a package its dependencies need to be registered
deps
<-
packageDeps
p
kg
pkgs
<-
interpret
Partial
targe
t
getPackages
deps
<-
packageDeps
p
ackage
pkgs
<-
interpret
InContext
contex
t
getPackages
let
depPkgs
=
matchPackageNames
(
sort
pkgs
)
deps
need
=<<
traverse
(
pkgConfFile
stage
)
depPkgs
...
...
@@ -40,24 +43,24 @@ buildPackageData _ target @ (PartialTarget stage pkg) = do
let
inTreeMk
=
oldPath
-/-
takeFileName
dataFile
need
[
cabalFile
]
build
$
full
Target
targe
t
GhcCabal
[
cabalFile
]
[
inTreeMk
]
build
$
Target
contex
t
GhcCabal
[
cabalFile
]
[
inTreeMk
]
-- TODO: get rid of this, see #113
liftIO
$
IO
.
copyFile
inTreeMk
dataFile
autogenFiles
<-
getDirectoryFiles
oldPath
[
"build/autogen/*"
]
createDirectory
$
targetPath
stage
p
kg
-/-
"build/autogen"
createDirectory
$
targetPath
stage
p
ackage
-/-
"build/autogen"
forM_
autogenFiles
$
\
file
->
do
copyFile
(
oldPath
-/-
file
)
(
targetPath
stage
p
kg
-/-
file
)
copyFile
(
oldPath
-/-
file
)
(
targetPath
stage
p
ackage
-/-
file
)
let
haddockPrologue
=
"haddock-prologue.txt"
copyFile
(
oldPath
-/-
haddockPrologue
)
(
targetPath
stage
p
kg
-/-
haddockPrologue
)
copyFile
(
oldPath
-/-
haddockPrologue
)
(
targetPath
stage
p
ackage
-/-
haddockPrologue
)
postProcessPackageData
stage
p
kg
dataFile
postProcessPackageData
stage
p
ackage
dataFile
-- TODO: PROGNAME was $(CrossCompilePrefix)hp2ps
priority
2.0
$
do
when
(
p
kg
==
hp2ps
)
$
dataFile
%>
\
mk
->
do
includes
<-
interpret
Partial
targe
t
$
fromDiffExpr
includesArgs
let
prefix
=
fixKey
(
targetPath
stage
p
kg
)
++
"_"
when
(
p
ackage
==
hp2ps
)
$
dataFile
%>
\
mk
->
do
includes
<-
interpret
InContext
contex
t
$
fromDiffExpr
includesArgs
let
prefix
=
fixKey
(
targetPath
stage
p
ackage
)
++
"_"
cSrcs
=
[
"AreaBelow.c"
,
"Curves.c"
,
"Error.c"
,
"Main.c"
,
"Reorder.c"
,
"TopTwenty.c"
,
"AuxFile.c"
,
"Deviation.c"
,
"HpFile.c"
,
"Marks.c"
,
"Scale.c"
...
...
@@ -71,8 +74,8 @@ buildPackageData _ target @ (PartialTarget stage pkg) = do
writeFileChanged
mk
contents
putSuccess
$
"| Successfully generated '"
++
mk
++
"'."
when
(
p
kg
==
unlit
)
$
dataFile
%>
\
mk
->
do
let
prefix
=
fixKey
(
targetPath
stage
p
kg
)
++
"_"
when
(
p
ackage
==
unlit
)
$
dataFile
%>
\
mk
->
do
let
prefix
=
fixKey
(
targetPath
stage
p
ackage
)
++
"_"
contents
=
unlines
$
map
(
prefix
++
)
[
"PROGNAME = unlit"
,
"C_SRCS = unlit.c"
...
...
@@ -80,8 +83,8 @@ buildPackageData _ target @ (PartialTarget stage pkg) = do
writeFileChanged
mk
contents
putSuccess
$
"| Successfully generated '"
++
mk
++
"'."
when
(
p
kg
==
touchy
)
$
dataFile
%>
\
mk
->
do
let
prefix
=
fixKey
(
targetPath
stage
p
kg
)
++
"_"
when
(
p
ackage
==
touchy
)
$
dataFile
%>
\
mk
->
do
let
prefix
=
fixKey
(
targetPath
stage
p
ackage
)
++
"_"
contents
=
unlines
$
map
(
prefix
++
)
[
"PROGNAME = touchy"
,
"C_SRCS = touchy.c"
]
...
...
@@ -91,8 +94,8 @@ buildPackageData _ target @ (PartialTarget stage pkg) = do
-- Bootstrapping `ghcCabal`: although `ghcCabal` is a proper cabal
-- package, we cannot generate the corresponding `package-data.mk` file
-- by running by running `ghcCabal`, because it has not yet been built.
when
(
p
kg
==
ghcCabal
&&
stage
==
Stage0
)
$
dataFile
%>
\
mk
->
do
let
prefix
=
fixKey
(
targetPath
stage
p
kg
)
++
"_"
when
(
p
ackage
==
ghcCabal
&&
stage
==
Stage0
)
$
dataFile
%>
\
mk
->
do
let
prefix
=
fixKey
(
targetPath
stage
p
ackage
)
++
"_"
contents
=
unlines
$
map
(
prefix
++
)
[
"PROGNAME = ghc-cabal"
,
"MODULES = Main"
...
...
@@ -101,24 +104,24 @@ buildPackageData _ target @ (PartialTarget stage pkg) = do
writeFileChanged
mk
contents
putSuccess
$
"| Successfully generated '"
++
mk
++
"'."
when
(
p
kg
==
rts
&&
stage
==
Stage1
)
$
do
when
(
p
ackage
==
rts
&&
stage
==
Stage1
)
$
do
dataFile
%>
\
mk
->
do
orderOnly
$
generatedDependencies
stage
p
kg
orderOnly
$
generatedDependencies
stage
p
ackage
windows
<-
windowsHost
let
prefix
=
fixKey
(
targetPath
stage
p
kg
)
++
"_"
let
prefix
=
fixKey
(
targetPath
stage
p
ackage
)
++
"_"
dirs
=
[
"."
,
"hooks"
,
"sm"
,
"eventlog"
]
++
[
"posix"
|
not
windows
]
++
[
"win32"
|
windows
]
-- TODO: rts/dist/build/sm/Evac_thr.c, rts/dist/build/sm/Scav_thr.c
-- TODO: adding cmm/S sources to C_SRCS is a hack; rethink after #18
cSrcs
<-
getDirectoryFiles
(
pkgPath
p
kg
)
(
map
(
-/-
"*.c"
)
dirs
)
cmmSrcs
<-
getDirectoryFiles
(
pkgPath
p
kg
)
[
"*.cmm"
]
cSrcs
<-
getDirectoryFiles
(
pkgPath
p
ackage
)
(
map
(
-/-
"*.c"
)
dirs
)
cmmSrcs
<-
getDirectoryFiles
(
pkgPath
p
ackage
)
[
"*.cmm"
]
buildAdjustor
<-
anyTargetArch
[
"i386"
,
"powerpc"
,
"powerpc64"
]
buildStgCRunAsm
<-
anyTargetArch
[
"powerpc64le"
]
let
sSrcs
=
[
"AdjustorAsm.S"
|
buildAdjustor
]
++
[
"StgCRunAsm.S"
|
buildStgCRunAsm
]
extraSrcs
=
[
rtsBuildPath
-/-
"AutoApply.cmm"
]
includes
<-
interpret
Partial
targe
t
$
fromDiffExpr
includesArgs
includes
<-
interpret
InContext
contex
t
$
fromDiffExpr
includesArgs
let
contents
=
unlines
$
map
(
prefix
++
)
[
"C_SRCS = "
++
unwords
(
cSrcs
++
cmmSrcs
++
sSrcs
++
extraSrcs
)
...
...
@@ -137,16 +140,16 @@ buildPackageData _ target @ (PartialTarget stage pkg) = do
-- is replaced by libraries_deepseq_dist-install_VERSION = 1.4.0.0
-- Reason: Shake's built-in makefile parser doesn't recognise slashes
postProcessPackageData
::
Stage
->
Package
->
FilePath
->
Action
()
postProcessPackageData
stage
p
kg
file
=
fixFile
file
fixPackageData
postProcessPackageData
stage
p
ackage
file
=
fixFile
file
fixPackageData
where
fixPackageData
=
unlines
.
map
processLine
.
filter
(
not
.
null
)
.
filter
(
'$'
`
notElem
`)
.
lines
processLine
line
=
fixKey
fixedPrefix
++
suffix
where
(
prefix
,
suffix
)
=
break
(
==
'='
)
line
-- Change p
kg
/path/targetDir to takeDirectory file
-- Change p
ackage
/path/targetDir to takeDirectory file
-- This is a temporary hack until we get rid of ghc-cabal
fixedPrefix
=
takeDirectory
file
++
drop
len
prefix
len
=
length
(
pkgPath
p
kg
-/-
targetDirectory
stage
p
kg
)
len
=
length
(
pkgPath
p
ackage
-/-
targetDirectory
stage
p
ackage
)
-- TODO: remove, see #113
fixKey
::
String
->
String
...
...
src/Rules/Dependencies.hs
View file @
e8b62f7e
{-# LANGUAGE RecordWildCards #-}
module
Rules.Dependencies
(
buildPackageDependencies
)
where
import
Development.Shake.Util
(
parseMakefile
)
import
Base
import
Context
import
Expression
import
Oracles.PackageData
import
Rules.Actions
import
Rules.Resources
import
Settings
import
Development.Shake.Util
(
parseMakefile
)
import
Target
-- TODO: simplify handling of AutoApply.cmm
buildPackageDependencies
::
Resources
->
PartialTarge
t
->
Rules
()
buildPackageDependencies
rs
target
@
(
PartialTarget
stage
pkg
)
=
let
path
=
targetPath
stage
p
kg
buildPackageDependencies
::
Resources
->
Contex
t
->
Rules
()
buildPackageDependencies
rs
context
@
(
Context
{
..
}
)
=
let
path
=
targetPath
stage
p
ackage
buildPath
=
path
-/-
"build"
dropBuild
=
(
pkgPath
p
kg
++
)
.
drop
(
length
buildPath
)
dropBuild
=
(
pkgPath
p
ackage
++
)
.
drop
(
length
buildPath
)
hDepFile
=
buildPath
-/-
".hs-dependencies"
in
do
fmap
(
buildPath
++
)
...
...
@@ -22,15 +26,15 @@ buildPackageDependencies rs target @ (PartialTarget stage pkg) =
then
dropExtension
out
else
dropBuild
.
dropExtension
$
out
need
[
srcFile
]
build
$
full
Target
targe
t
(
GccM
stage
)
[
srcFile
]
[
out
]
build
$
Target
contex
t
(
GccM
stage
)
[
srcFile
]
[
out
]
hDepFile
%>
\
out
->
do
srcs
<-
interpret
Partial
targe
t
getPackageSources
srcs
<-
interpret
InContext
contex
t
getPackageSources
need
srcs
if
srcs
==
[]
then
writeFileChanged
out
""
else
buildWithResources
[(
resPackageDb
rs
,
1
)]
$
full
Target
targe
t
(
GhcM
stage
)
srcs
[
out
]
Target
contex
t
(
GhcM
stage
)
srcs
[
out
]
removeFileIfExists
$
out
<.>
"bak"
-- TODO: don't accumulate *.deps into .dependencies
...
...
src/Rules/Documentation.hs
View file @
e8b62f7e
{-# LANGUAGE RecordWildCards #-}
module
Rules.Documentation
(
buildPackageDocumentation
)
where
import
Base
import
Context
import
Expression
import
GHC
import
Oracles.PackageData
import
Rules.Actions
import
Rules.Resources
import
Settings
import
Target
haddockHtmlLib
::
FilePath
haddockHtmlLib
=
"inplace/lib/html/haddock-util.js"
...
...
@@ -14,14 +17,14 @@ haddockHtmlLib = "inplace/lib/html/haddock-util.js"
-- Note: this build rule creates plenty of files, not just the .haddock one.
-- All of them go into the 'doc' subdirectory. Pedantically tracking all built
-- files in the Shake databases seems fragile and unnecesarry.
buildPackageDocumentation
::
Resources
->
PartialTarge
t
->
Rules
()
buildPackageDocumentation
_
target
@
(
PartialTarget
stage
pkg
)
=
let
cabalFile
=
pkgCabalFile
p
kg
haddockFile
=
pkgHaddockFile
p
kg
buildPackageDocumentation
::
Resources
->
Contex
t
->
Rules
()
buildPackageDocumentation
_
context
@
(
Context
{
..
}
)
=
let
cabalFile
=
pkgCabalFile
p
ackage
haddockFile
=
pkgHaddockFile
p
ackage
in
when
(
stage
==
Stage1
)
$
do
haddockFile
%>
\
file
->
do
srcs
<-
interpret
Partial
targe
t
getPackageSources
deps
<-
map
PackageName
<$>
interpret
Partial
targe
t
(
getPkgDataList
DepNames
)
srcs
<-
interpret
InContext
contex
t
getPackageSources
deps
<-
map
PackageName
<$>
interpret
InContext
contex
t
(
getPkgDataList
DepNames
)
let
haddocks
=
[
pkgHaddockFile
depPkg
|
Just
depPkg
<-
map
findKnownPackage
deps
,
depPkg
/=
rts
]
...
...
@@ -30,15 +33,15 @@ buildPackageDocumentation _ target @ (PartialTarget stage pkg) =
-- HsColour sources
-- TODO: what is the output of GhcCabalHsColour?
whenM
(
specified
HsColour
)
$
do
pkgConf
<-
pkgConfFile
stage
p
kg
pkgConf
<-
pkgConfFile
stage
p
ackage
need
[
cabalFile
,
pkgConf
]
-- TODO: check if need pkgConf
build
$
full
Target
targe
t
GhcCabalHsColour
[
cabalFile
]
[]
build
$
Target
contex
t
GhcCabalHsColour
[
cabalFile
]
[]
-- Build Haddock documentation
let
haddockWay
=
if
dynamicGhcPrograms
then
dynamic
else
vanilla
build
$
full
Target
WithWay
target
Haddock
h
addock
Way
srcs
[
file
]
build
$
Target
(
context
{
way
=
haddockWay
})
H
addock
srcs
[
file
]
when
(
p
kg
==
haddock
)
$
haddockHtmlLib
%>
\
_
->
do
when
(
p
ackage
==
haddock
)
$
haddockHtmlLib
%>
\
_
->
do
let
dir
=
takeDirectory
haddockHtmlLib
liftIO
$
removeFiles
dir
[
"//*"
]
copyDirectory
"utils/haddock/haddock-api/resources/html"
dir
...
...
src/Rules/Generate.hs
View file @
e8b62f7e
...
...
@@ -6,6 +6,7 @@ module Rules.Generate (
import
qualified
System.Directory
as
IO
import
Base
import
Context
hiding
(
stage
)
import
Expression
import
GHC
import
Rules.Generators.ConfigHs
...
...
@@ -21,6 +22,7 @@ import Rules.Gmp
import
Rules.Libffi
import
Rules.Resources
(
Resources
)
import
Settings
import
Target
hiding
(
builder
,
context
)
installTargets
::
[
FilePath
]
installTargets
=
[
"inplace/lib/ghc-usage.txt"
...
...
@@ -106,18 +108,18 @@ determineBuilder file = fmap fst $ find (\(_, e) -> e == ext) knownGenerators
where
ext
=
takeExtension
file
generate
::
FilePath
->
PartialTarge
t
->
Expr
String
->
Action
()
generate
file
targe
t
expr
=
do
contents
<-
interpret
Partial
targe
t
expr
generate
::
FilePath
->
Contex
t
->
Expr
String
->
Action
()
generate
file
contex
t
expr
=
do
contents
<-
interpret
InContext
contex
t
expr
writeFileChanged
file
contents
putSuccess
$
"| Successfully generated '"
++
file
++
"'."
generatePackageCode
::
Resources
->
PartialTarge
t
->
Rules
()
generatePackageCode
_
target
@
(
PartialTarge
t
stage
pkg
)
=
generatePackageCode
::
Resources
->
Contex
t
->
Rules
()
generatePackageCode
_
context
@
(
Contex
t
stage
pkg
_
)
=
let
buildPath
=
targetPath
stage
pkg
-/-
"build"
dropBuild
=
drop
(
length
buildPath
+
1
)
generated
f
=
(
buildPath
++
"//*.hs"
)
?==
f
&&
not
(
"//autogen/*"
?==
f
)
file
<~
gen
=
generate
file
targe
t
gen
file
<~
gen
=
generate
file
contex
t
gen
in
do
generated
?>
\
file
->
do