Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
badd5513
Commit
badd5513
authored
Feb 19, 2016
by
Andrey Mokhov
Browse files
Refactor paths using Context.
See
#207
.
parent
13ad0500
Changes
32
Hide whitespace changes
Inline
Side-by-side
src/Builder.hs
View file @
badd5513
...
...
@@ -6,12 +6,12 @@ module Builder (
import
Control.Monad.Trans.Reader
import
Base
import
Context
import
GHC
import
GHC.Generics
(
Generic
)
import
Oracles.Config
import
Oracles.LookupInPath
import
Oracles.WindowsPath
import
Package
import
Stage
-- | A 'Builder' is an external command invoked in separate process using 'Shake.cmd'
...
...
@@ -54,22 +54,25 @@ data Builder = Alex
deriving
(
Show
,
Eq
,
Generic
)
-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding 'Stage' and GHC 'Package'.
builderProvenance
::
Builder
->
Maybe
(
Stage
,
Package
)
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
-- 'Stage' and GHC 'Package').
builderProvenance
::
Builder
->
Maybe
Context
builderProvenance
=
\
case
DeriveConstants
->
Jus
t
(
Stage0
,
deriveConstants
)
GenApply
->
Jus
t
(
Stage0
,
genapply
)
GenPrimopCode
->
Jus
t
(
Stage0
,
genprimopcode
)
Ghc
stage
->
if
stage
==
Stage0
then
Nothing
else
Jus
t
(
pred
stage
,
ghc
)
DeriveConstants
->
contex
t
Stage0
deriveConstants
GenApply
->
contex
t
Stage0
genapply
GenPrimopCode
->
contex
t
Stage0
genprimopcode
Ghc
stage
->
if
stage
==
Stage0
then
Nothing
else
contex
t
(
pred
stage
)
ghc
GhcM
stage
->
builderProvenance
$
Ghc
stage
GhcCabal
->
Jus
t
(
Stage0
,
ghcCabal
)
GhcCabal
->
contex
t
Stage0
ghcCabal
GhcCabalHsColour
->
builderProvenance
$
GhcCabal
GhcPkg
stage
->
if
stage
>
Stage0
then
Jus
t
(
Stage0
,
ghcPkg
)
else
Nothing
Haddock
->
Jus
t
(
Stage2
,
haddock
)
Hpc
->
Jus
t
(
Stage1
,
hpcBin
)
Hsc2Hs
->
Jus
t
(
Stage0
,
hsc2hs
)
Unlit
->
Jus
t
(
Stage0
,
unlit
)
GhcPkg
stage
->
if
stage
>
Stage0
then
contex
t
Stage0
ghcPkg
else
Nothing
Haddock
->
contex
t
Stage2
haddock
Hpc
->
contex
t
Stage1
hpcBin
Hsc2Hs
->
contex
t
Stage0
hsc2hs
Unlit
->
contex
t
Stage0
unlit
_
->
Nothing
where
context
s
p
=
Just
$
vanillaContext
s
p
isInternal
::
Builder
->
Bool
isInternal
=
isJust
.
builderProvenance
...
...
@@ -87,7 +90,7 @@ isStaged = \case
-- | Determine the location of a 'Builder'
builderPath
::
Builder
->
Action
FilePath
builderPath
builder
=
case
builderProvenance
builder
of
Just
(
stage
,
pkg
)
->
return
.
fromJust
$
programPath
stage
pkg
Just
context
->
return
.
fromJust
$
programPath
context
Nothing
->
do
let
builderKey
=
case
builder
of
Alex
->
"alex"
...
...
src/Expression.hs
View file @
badd5513
...
...
@@ -15,7 +15,7 @@ module Expression (
Context
,
vanillaContext
,
stageContext
,
Target
,
dummyTarget
,
-- * Convenient accessors
getStage
,
getPackage
,
getBuilder
,
getOutputs
,
getInputs
,
getWay
,
getContext
,
getStage
,
getPackage
,
getBuilder
,
getOutputs
,
getInputs
,
getWay
,
getInput
,
getOutput
,
-- * Re-exports
...
...
@@ -163,22 +163,26 @@ fromDiffExpr = fmap (($ mempty) . fromDiff)
interpretDiff
::
Monoid
a
=>
Target
->
DiffExpr
a
->
Action
a
interpretDiff
target
=
interpret
target
.
fromDiffExpr
-- | Convenient getters for target parameters.
-- | Get the current build 'Context'.
getContext
::
Expr
Context
getContext
=
asks
context
-- | Get the 'Stage' of the current 'Context'.
getStage
::
Expr
Stage
getStage
=
stage
<$>
asks
context
-- | Get the 'Package' of the current '
Targe
t'.
-- | Get the 'Package' of the current '
Contex
t'.
getPackage
::
Expr
Package
getPackage
=
package
<$>
asks
context
-- | Get the 'Way' of the current 'Context'.
getWay
::
Expr
Way
getWay
=
way
<$>
asks
context
-- | Get the 'Builder' for the current 'Target'.
getBuilder
::
Expr
Builder
getBuilder
=
asks
builder
-- | Get the 'Way' of the current 'Target'.
getWay
::
Expr
Way
getWay
=
way
<$>
asks
context
-- | Get the input files of the current 'Target'.
getInputs
::
Expr
[
FilePath
]
getInputs
=
asks
inputs
...
...
src/GHC.hs
View file @
badd5513
...
...
@@ -8,10 +8,11 @@ module GHC (
primitive
,
process
,
rts
,
runGhc
,
stm
,
templateHaskell
,
terminfo
,
time
,
touchy
,
transformers
,
unlit
,
unix
,
win32
,
xhtml
,
defaultKnownPackages
,
programPath
,
targe
tDirectory
defaultKnownPackages
,
programPath
,
contex
tDirectory
,
rtsContext
)
where
import
Base
import
Context
import
Package
import
Stage
...
...
@@ -103,26 +104,29 @@ ghcSplit = "inplace/lib/bin/ghc-split"
-- TODO: move to buildRootPath, see #113
-- TODO: simplify, add programInplaceLibPath
-- | The relative path to the program executable
programPath
::
Stage
->
Package
->
Maybe
FilePath
programPath
stage
pkg
|
p
kg
==
ghc
=
Just
.
inplaceProgram
$
"ghc-stage"
++
show
(
fromEnum
stage
+
1
)
|
p
kg
`
elem
`
[
ghcTags
,
haddock
,
mkUserGuidePart
]
=
case
stage
of
Stage2
->
Just
.
inplaceProgram
$
pkgNameString
p
kg
programPath
::
Context
->
Maybe
FilePath
programPath
context
@
(
Context
{
..
})
|
p
ackage
==
ghc
=
Just
.
inplaceProgram
$
"ghc-stage"
++
show
(
fromEnum
stage
+
1
)
|
p
ackage
`
elem
`
[
ghcTags
,
haddock
,
mkUserGuidePart
]
=
case
stage
of
Stage2
->
Just
.
inplaceProgram
$
pkgNameString
p
ackage
_
->
Nothing
|
p
kg
`
elem
`
[
touchy
,
unlit
]
=
case
stage
of
Stage0
->
Just
$
"inplace/lib/bin"
-/-
pkgNameString
p
kg
<.>
exe
|
p
ackage
`
elem
`
[
touchy
,
unlit
]
=
case
stage
of
Stage0
->
Just
$
"inplace/lib/bin"
-/-
pkgNameString
p
ackage
<.>
exe
_
->
Nothing
|
p
kg
==
hpcBin
=
case
stage
of
|
p
ackage
==
hpcBin
=
case
stage
of
Stage1
->
Just
$
inplaceProgram
"hpc"
_
->
Nothing
|
isProgram
p
kg
=
case
stage
of
Stage0
->
Just
.
inplaceProgram
$
pkgNameString
p
kg
_
->
Just
.
installProgram
$
pkgNameString
p
kg
|
isProgram
p
ackage
=
case
stage
of
Stage0
->
Just
.
inplaceProgram
$
pkgNameString
p
ackage
_
->
Just
.
installProgram
$
pkgNameString
p
ackage
|
otherwise
=
Nothing
where
inplaceProgram
name
=
programInplacePath
-/-
name
<.>
exe
installProgram
name
=
pkgPath
pkg
-/-
targetDirectory
stage
pkg
-/-
"build/tmp"
-/-
name
<.>
exe
installProgram
name
=
pkgPath
package
-/-
contextDirectory
context
-/-
"build/tmp"
-/-
name
<.>
exe
rtsContext
::
Context
rtsContext
=
vanillaContext
Stage1
rts
-- | GHC build results will be placed into target directories with the
-- following typical structure:
...
...
@@ -130,6 +134,6 @@ programPath stage pkg
-- * @build/@ contains compiled object code
-- * @doc/@ is produced by haddock
-- * @package-data.mk@ contains output of ghc-cabal applied to pkgCabal
targe
tDirectory
::
Stage
->
Package
->
FilePath
targe
tDirectory
stage
_
=
stageString
stage
contex
tDirectory
::
Context
->
FilePath
contex
tDirectory
(
Context
{
..
})
=
stageString
stage
src/Oracles/ModuleFiles.hs
View file @
badd5513
...
...
@@ -2,31 +2,31 @@
module
Oracles.ModuleFiles
(
moduleFiles
,
haskellModuleFiles
,
moduleFilesOracle
)
where
import
Base
import
Context
import
Oracles.PackageData
import
Package
import
Stage
import
Settings.Paths
newtype
ModuleFilesKey
=
ModuleFilesKey
([
String
],
[
FilePath
])
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
moduleFiles
::
Stage
->
Package
->
Action
[
FilePath
]
moduleFiles
stage
pkg
=
do
let
path
=
targetPath
stage
pkg
moduleFiles
::
Context
->
Action
[
FilePath
]
moduleFiles
context
@
(
Context
{
..
})
=
do
let
path
=
contextPath
context
srcDirs
<-
fmap
sort
.
pkgDataList
$
SrcDirs
path
modules
<-
fmap
sort
.
pkgDataList
$
Modules
path
let
dirs
=
[
pkgPath
p
kg
-/-
dir
|
dir
<-
srcDirs
]
let
dirs
=
[
pkgPath
p
ackage
-/-
dir
|
dir
<-
srcDirs
]
found
::
[(
String
,
FilePath
)]
<-
askOracle
$
ModuleFilesKey
(
modules
,
dirs
)
return
$
map
snd
found
haskellModuleFiles
::
Stage
->
Package
->
Action
([
FilePath
],
[
String
])
haskellModuleFiles
stage
pkg
=
do
let
path
=
targetPath
stage
pkg
haskellModuleFiles
::
Context
->
Action
([
FilePath
],
[
String
])
haskellModuleFiles
context
@
(
Context
{
..
})
=
do
let
path
=
contextPath
context
autogen
=
path
-/-
"build/autogen"
dropPkgPath
=
drop
$
length
(
pkgPath
p
kg
)
+
1
dropPkgPath
=
drop
$
length
(
pkgPath
p
ackage
)
+
1
srcDirs
<-
fmap
sort
.
pkgDataList
$
SrcDirs
path
modules
<-
fmap
sort
.
pkgDataList
$
Modules
path
let
dirs
=
[
pkgPath
p
kg
-/-
dir
|
dir
<-
srcDirs
]
let
dirs
=
[
pkgPath
p
ackage
-/-
dir
|
dir
<-
srcDirs
]
foundSrcDirs
<-
askOracle
$
ModuleFilesKey
(
modules
,
dirs
)
foundAutogen
<-
askOracle
$
ModuleFilesKey
(
modules
,
[
autogen
])
...
...
src/Rules.hs
View file @
badd5513
...
...
@@ -3,7 +3,7 @@ module Rules (topLevelTargets, buildRules) where
import
Data.Foldable
import
Base
import
Context
hiding
(
stage
,
package
,
way
)
import
Context
import
Expression
import
GHC
import
Rules.Compile
...
...
@@ -33,8 +33,8 @@ topLevelTargets = do
-- TODO: do we want libffiLibrary to be a top-level target?
action
$
do
-- TODO: Add support for all rtsWays
rtsLib
<-
pkgLibraryFile
Stage1
rts
vanilla
rtsThrLib
<-
pkgLibraryFile
Stage1
rts
threaded
rtsLib
<-
pkgLibraryFile
$
rtsContext
{
way
=
vanilla
}
rtsThrLib
<-
pkgLibraryFile
$
rtsContext
{
way
=
threaded
}
need
[
rtsLib
,
rtsThrLib
]
for_
allStages
$
\
stage
->
...
...
@@ -45,11 +45,11 @@ topLevelTargets = do
if
isLibrary
pkg
then
do
-- build a library
ways
<-
interpretInContext
context
getLibraryWays
libs
<-
traverse
(
pkgLibraryFile
stage
pkg
)
ways
libs
<-
traverse
(
pkgLibraryFile
.
Context
stage
pkg
)
ways
docs
<-
interpretInContext
context
buildHaddock
need
$
libs
++
[
pkgHaddockFile
pkg
|
docs
&&
stage
==
Stage1
]
need
$
libs
++
[
pkgHaddockFile
context
|
docs
&&
stage
==
Stage1
]
else
do
-- otherwise build a program
need
[
fromJust
$
programPath
stage
pkg
]
-- TODO: drop fromJust
need
[
fromJust
$
programPath
context
]
-- TODO: drop fromJust
packageRules
::
Rules
()
packageRules
=
do
...
...
src/Rules/Clean.hs
View file @
badd5513
module
Rules.Clean
(
cleanRules
)
where
import
Base
import
Context
import
Package
import
Rules.Generate
import
Settings.Packages
...
...
@@ -25,7 +26,7 @@ cleanRules = do
putBuild
$
"| Remove files generated by ghc-cabal..."
forM_
knownPackages
$
\
pkg
->
forM_
[
Stage0
..
]
$
\
stage
->
do
let
dir
=
pkgPath
pkg
-/-
targe
tDirectory
stage
pkg
let
dir
=
pkgPath
pkg
-/-
contex
tDirectory
(
vanillaContext
stage
pkg
)
removeDirectoryIfExists
dir
putBuild
$
"| Remove the Shake database "
++
shakeFilesPath
++
"..."
removeFilesAfter
shakeFilesPath
[
"//*"
]
...
...
src/Rules/Compile.hs
View file @
badd5513
...
...
@@ -10,7 +10,7 @@ import Target
compilePackage
::
[(
Resource
,
Int
)]
->
Context
->
Rules
()
compilePackage
rs
context
@
(
Context
{
..
})
=
do
let
buildPath
=
targetPath
stage
package
-/-
"build"
let
buildPath
=
contextPath
context
-/-
"build"
buildPath
<//>
"*"
<.>
hisuf
way
%>
\
hi
->
if
compileInterfaceFilesSeparately
...
...
src/Rules/Data.hs
View file @
badd5513
...
...
@@ -20,8 +20,8 @@ buildPackageData :: Context -> Rules ()
buildPackageData
context
@
(
Context
{
..
})
=
do
let
cabalFile
=
pkgCabalFile
package
configure
=
pkgPath
package
-/-
"configure"
dataFile
=
pkgDataFile
stage
package
oldPath
=
pkgPath
package
-/-
targe
tDirectory
stage
package
-- TODO: remove, #113
dataFile
=
pkgDataFile
context
oldPath
=
pkgPath
package
-/-
contex
tDirectory
context
-- TODO: remove, #113
[
dataFile
,
oldPath
-/-
"package-data.mk"
]
&%>
\
_
->
do
-- The first thing we do with any package is make sure all generated
...
...
@@ -35,7 +35,7 @@ buildPackageData context @ (Context {..}) = do
deps
<-
packageDeps
package
pkgs
<-
interpretInContext
context
getPackages
let
depPkgs
=
matchPackageNames
(
sort
pkgs
)
deps
need
=<<
traverse
(
pkgConfFile
stage
)
depPkgs
need
=<<
traverse
(
pkgConfFile
.
vanillaContext
stage
)
depPkgs
-- TODO: get rid of this, see #113
let
inTreeMk
=
oldPath
-/-
takeFileName
dataFile
...
...
@@ -46,19 +46,19 @@ buildPackageData context @ (Context {..}) = do
-- TODO: get rid of this, see #113
liftIO
$
IO
.
copyFile
inTreeMk
dataFile
autogenFiles
<-
getDirectoryFiles
oldPath
[
"build/autogen/*"
]
createDirectory
$
targetPath
stage
package
-/-
"build/autogen"
createDirectory
$
contextPath
context
-/-
"build/autogen"
forM_
autogenFiles
$
\
file
->
do
copyFile
(
oldPath
-/-
file
)
(
targetPath
stage
package
-/-
file
)
copyFile
(
oldPath
-/-
file
)
(
contextPath
context
-/-
file
)
let
haddockPrologue
=
"haddock-prologue.txt"
copyFile
(
oldPath
-/-
haddockPrologue
)
(
targetPath
stage
package
-/-
haddockPrologue
)
copyFile
(
oldPath
-/-
haddockPrologue
)
(
contextPath
context
-/-
haddockPrologue
)
postProcessPackageData
stage
package
dataFile
postProcessPackageData
context
dataFile
-- TODO: PROGNAME was $(CrossCompilePrefix)hp2ps
priority
2.0
$
do
when
(
package
==
hp2ps
)
$
dataFile
%>
\
mk
->
do
includes
<-
interpretInContext
context
$
fromDiffExpr
includesArgs
let
prefix
=
fixKey
(
targetPath
stage
package
)
++
"_"
let
prefix
=
fixKey
(
contextPath
context
)
++
"_"
cSrcs
=
[
"AreaBelow.c"
,
"Curves.c"
,
"Error.c"
,
"Main.c"
,
"Reorder.c"
,
"TopTwenty.c"
,
"AuxFile.c"
,
"Deviation.c"
,
"HpFile.c"
,
"Marks.c"
,
"Scale.c"
...
...
@@ -73,7 +73,7 @@ buildPackageData context @ (Context {..}) = do
putSuccess
$
"| Successfully generated '"
++
mk
++
"'."
when
(
package
==
unlit
)
$
dataFile
%>
\
mk
->
do
let
prefix
=
fixKey
(
targetPath
stage
package
)
++
"_"
let
prefix
=
fixKey
(
contextPath
context
)
++
"_"
contents
=
unlines
$
map
(
prefix
++
)
[
"PROGNAME = unlit"
,
"C_SRCS = unlit.c"
...
...
@@ -82,7 +82,7 @@ buildPackageData context @ (Context {..}) = do
putSuccess
$
"| Successfully generated '"
++
mk
++
"'."
when
(
package
==
touchy
)
$
dataFile
%>
\
mk
->
do
let
prefix
=
fixKey
(
targetPath
stage
package
)
++
"_"
let
prefix
=
fixKey
(
contextPath
context
)
++
"_"
contents
=
unlines
$
map
(
prefix
++
)
[
"PROGNAME = touchy"
,
"C_SRCS = touchy.c"
]
...
...
@@ -93,7 +93,7 @@ buildPackageData context @ (Context {..}) = do
-- package, we cannot generate the corresponding `package-data.mk` file
-- by running by running `ghcCabal`, because it has not yet been built.
when
(
package
==
ghcCabal
&&
stage
==
Stage0
)
$
dataFile
%>
\
mk
->
do
let
prefix
=
fixKey
(
targetPath
stage
package
)
++
"_"
let
prefix
=
fixKey
(
contextPath
context
)
++
"_"
contents
=
unlines
$
map
(
prefix
++
)
[
"PROGNAME = ghc-cabal"
,
"MODULES = Main"
...
...
@@ -106,7 +106,7 @@ buildPackageData context @ (Context {..}) = do
dataFile
%>
\
mk
->
do
orderOnly
$
generatedDependencies
stage
package
windows
<-
windowsHost
let
prefix
=
fixKey
(
targetPath
stage
package
)
++
"_"
let
prefix
=
fixKey
(
contextPath
context
)
++
"_"
dirs
=
[
"."
,
"hooks"
,
"sm"
,
"eventlog"
]
++
[
"posix"
|
not
windows
]
++
[
"win32"
|
windows
]
...
...
@@ -137,8 +137,8 @@ buildPackageData context @ (Context {..}) = do
-- For example libraries/deepseq/dist-install_VERSION = 1.4.0.0
-- 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
package
file
=
fixFile
file
fixPackageData
postProcessPackageData
::
Context
->
FilePath
->
Action
()
postProcessPackageData
context
@
(
Context
{
..
})
file
=
fixFile
file
fixPackageData
where
fixPackageData
=
unlines
.
map
processLine
.
filter
(
not
.
null
)
.
filter
(
'$'
`
notElem
`)
.
lines
processLine
line
=
fixKey
fixedPrefix
++
suffix
...
...
@@ -147,7 +147,7 @@ postProcessPackageData stage package file = fixFile file fixPackageData
-- Change package/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
package
-/-
targe
tDirectory
stage
package
)
len
=
length
(
pkgPath
package
-/-
contex
tDirectory
context
)
-- TODO: remove, see #113
fixKey
::
String
->
String
...
...
src/Rules/Dependencies.hs
View file @
badd5513
...
...
@@ -13,7 +13,7 @@ import Target
-- TODO: simplify handling of AutoApply.cmm
buildPackageDependencies
::
[(
Resource
,
Int
)]
->
Context
->
Rules
()
buildPackageDependencies
rs
context
@
(
Context
{
..
})
=
let
path
=
targetPath
stage
package
let
path
=
contextPath
context
buildPath
=
path
-/-
"build"
dropBuild
=
(
pkgPath
package
++
)
.
drop
(
length
buildPath
)
hDepFile
=
buildPath
-/-
".hs-dependencies"
...
...
src/Rules/Documentation.hs
View file @
badd5513
...
...
@@ -18,12 +18,12 @@ haddockHtmlLib = "inplace/lib/html/haddock-util.js"
buildPackageDocumentation
::
Context
->
Rules
()
buildPackageDocumentation
context
@
(
Context
{
..
})
=
let
cabalFile
=
pkgCabalFile
package
haddockFile
=
pkgHaddockFile
package
haddockFile
=
pkgHaddockFile
context
in
when
(
stage
==
Stage1
)
$
do
haddockFile
%>
\
file
->
do
srcs
<-
interpretInContext
context
getPackageSources
deps
<-
map
PackageName
<$>
interpretInContext
context
(
getPkgDataList
DepNames
)
let
haddocks
=
[
pkgHaddockFile
depPkg
let
haddocks
=
[
pkgHaddockFile
$
vanillaContext
Stage1
depPkg
|
Just
depPkg
<-
map
findKnownPackage
deps
,
depPkg
/=
rts
]
need
$
srcs
++
haddocks
++
[
haddockHtmlLib
]
...
...
@@ -31,7 +31,7 @@ buildPackageDocumentation context @ (Context {..}) =
-- HsColour sources
-- TODO: what is the output of GhcCabalHsColour?
whenM
(
specified
HsColour
)
$
do
pkgConf
<-
pkgConfFile
stage
package
pkgConf
<-
pkgConfFile
context
need
[
cabalFile
,
pkgConf
]
-- TODO: check if need pkgConf
build
$
Target
context
GhcCabalHsColour
[
cabalFile
]
[]
...
...
src/Rules/Generate.hs
View file @
badd5513
...
...
@@ -34,10 +34,12 @@ primopsSource :: FilePath
primopsSource
=
"compiler/prelude/primops.txt.pp"
primopsTxt
::
Stage
->
FilePath
primopsTxt
stage
=
targetPath
stage
compiler
-/-
"build/primops.txt"
primopsTxt
stage
=
contextPath
(
vanillaContext
stage
compiler
)
-/-
"build/primops.txt"
platformH
::
Stage
->
FilePath
platformH
stage
=
targetPath
stage
compiler
-/-
"ghc_boot_platform.h"
platformH
stage
=
contextPath
(
vanillaContext
stage
compiler
)
-/-
"ghc_boot_platform.h"
-- TODO: move generated files to buildRootPath, see #113
includesDependencies
::
[
FilePath
]
...
...
@@ -47,7 +49,8 @@ includesDependencies = ("includes" -/-) <$>
,
"ghcversion.h"
]
ghcPrimDependencies
::
Stage
->
[
FilePath
]
ghcPrimDependencies
stage
=
((
targetPath
stage
ghcPrim
-/-
"build"
)
-/-
)
<$>
ghcPrimDependencies
stage
=
((
contextPath
(
vanillaContext
stage
ghcPrim
)
-/-
"build"
)
-/-
)
<$>
[
"autogen/GHC/Prim.hs"
,
"GHC/PrimopWrappers.hs"
]
...
...
@@ -68,7 +71,7 @@ compilerDependencies stage =
++
[
gmpLibraryH
|
stage
>
Stage0
]
++
filter
(
const
$
stage
>
Stage0
)
libffiDependencies
++
derivedConstantsDependencies
++
fmap
((
targetPath
stage
compiler
-/-
"build"
)
-/-
)
++
fmap
((
contextPath
(
vanillaContext
stage
compiler
)
-/-
"build"
)
-/-
)
[
"primop-can-fail.hs-incl"
,
"primop-code-size.hs-incl"
,
"primop-commutable.hs-incl"
...
...
@@ -115,7 +118,7 @@ generate file context expr = do
generatePackageCode
::
Context
->
Rules
()
generatePackageCode
context
@
(
Context
stage
pkg
_
)
=
let
buildPath
=
targetPath
stage
pkg
-/-
"build"
let
buildPath
=
contextPath
context
-/-
"build"
dropBuild
=
drop
(
length
buildPath
+
1
)
generated
f
=
(
buildPath
++
"//*.hs"
)
?==
f
&&
not
(
"//autogen/*"
?==
f
)
file
<~
gen
=
generate
file
context
gen
...
...
@@ -123,7 +126,7 @@ generatePackageCode context @ (Context stage pkg _) =
generated
?>
\
file
->
do
let
srcFile
=
dropBuild
file
pattern
=
"//"
++
srcFile
-<.>
"*"
files
<-
fmap
(
filter
(
pattern
?==
))
$
moduleFiles
stage
pkg
files
<-
fmap
(
filter
(
pattern
?==
))
$
moduleFiles
context
let
gens
=
[
(
f
,
b
)
|
f
<-
files
,
Just
b
<-
[
determineBuilder
f
]
]
when
(
length
gens
/=
1
)
.
putError
$
"Exactly one generator expected for "
++
file
...
...
@@ -148,7 +151,7 @@ generatePackageCode context @ (Context stage pkg _) =
need
[
primopsTxt
stage
]
build
$
Target
context
GenPrimopCode
[
primopsTxt
stage
]
[
file
]
-- TODO: this is temporary hack, get rid of this (#113)
let
oldPath
=
pkgPath
pkg
-/-
targe
tDirectory
stage
pkg
-/-
"build"
let
oldPath
=
pkgPath
pkg
-/-
contex
tDirectory
context
-/-
"build"
newFile
=
oldPath
++
(
drop
(
length
buildPath
)
file
)
createDirectory
$
takeDirectory
newFile
liftIO
$
IO
.
copyFile
file
newFile
...
...
@@ -159,8 +162,8 @@ generatePackageCode context @ (Context stage pkg _) =
priority
2.0
$
do
-- TODO: this is temporary hack, get rid of this (#113)
let
oldPath
=
pkgPath
pkg
-/-
targe
tDirectory
stage
pkg
olden
f
=
oldPath
++
(
drop
(
length
(
targetPath
stage
pkg
))
f
)
let
oldPath
=
pkgPath
pkg
-/-
contex
tDirectory
context
olden
f
=
oldPath
++
(
drop
(
length
(
contextPath
context
))
f
)
when
(
pkg
==
compiler
)
$
buildPath
-/-
"Config.hs"
%>
\
file
->
do
file
<~
generateConfigHs
...
...
@@ -200,7 +203,7 @@ generateRules = do
-- TODO: simplify, get rid of fake rts context
derivedConstantsPath
++
"//*"
%>
\
file
->
do
withTempDir
$
\
dir
->
build
$
Target
(
vanillaContext
Stage1
rts
)
DeriveConstants
[]
[
file
,
dir
]
Target
rtsContext
DeriveConstants
[]
[
file
,
dir
]
where
file
<~
gen
=
file
%>
\
out
->
generate
out
emptyTarget
gen
...
...
src/Rules/Gmp.hs
View file @
badd5513
...
...
@@ -122,4 +122,4 @@ gmpRules = do
-- This causes integerGmp package to be configured, hence creating the files
[
gmpBase
-/-
"config.mk"
,
gmpBuildInfoPath
]
&%>
\
_
->
need
[
pkgDataFile
Stage1
integerGmp
]
need
[
pkgDataFile
gmpContext
]
src/Rules/Libffi.hs
View file @
badd5513
...
...
@@ -15,7 +15,7 @@ import Target
-- TODO: this should be moved elsewhere
rtsBuildPath
::
FilePath
rtsBuildPath
=
targetPath
Stage1
rts
-/-
"build"
rtsBuildPath
=
contextPath
rtsContext
-/-
"build"
-- TODO: Why copy these include files into rts? Keep in libffi!
libffiDependencies
::
[
FilePath
]
...
...
src/Rules/Library.hs
View file @
badd5513
...
...
@@ -17,7 +17,7 @@ import Target
buildPackageLibrary
::
Context
->
Rules
()
buildPackageLibrary
context
@
(
Context
{
..
})
=
do
let
buildPath
=
targetPath
stage
package
-/-
"build"
let
buildPath
=
contextPath
context
-/-
"build"
libPrefix
=
buildPath
-/-
"libHS"
++
pkgNameString
package
-- TODO: handle dynamic libraries
...
...
@@ -61,7 +61,7 @@ buildPackageLibrary context @ (Context {..}) = do
buildPackageGhciLibrary
::
Context
->
Rules
()
buildPackageGhciLibrary
context
@
(
Context
{
..
})
=
priority
2
$
do
let
buildPath
=
targetPath
stage
package
-/-
"build"
let
buildPath
=
contextPath
context
-/-
"build"
libPrefix
=
buildPath
-/-
"HS"
++
pkgNameString
package
-- TODO: simplify handling of AutoApply.cmm
...
...
src/Rules/Program.hs
View file @
badd5513
...
...
@@ -32,10 +32,10 @@ wrappers = [ (vanillaContext Stage0 ghc , ghcWrapper )
buildProgram
::
[(
Resource
,
Int
)]
->
Context
->
Rules
()
buildProgram
rs
context
@
(
Context
{
..
})
=
do
let
match
file
=
case
programPath
stage
package
of
let
match
file
=
case
programPath
context
of
Nothing
->
False
Just
program
->
program
==
file
matchWrapped
file
=
case
programPath
stage
package
of
matchWrapped
file
=
case
programPath
context
of
Nothing
->
False
Just
program
->
case
computeWrappedPath
program
of
Nothing
->
False
...
...
@@ -71,7 +71,7 @@ buildWrapper context @ (Context stage package _) wrapper wrapperPath binPath = d
-- TODO: Do we need to consider other ways when building programs?
buildBinary
::
[(
Resource
,
Int
)]
->
Context
->
FilePath
->
Action
()
buildBinary
rs
context
@
(
Context
stage
package
_
)
bin
=
do
let
buildPath
=
targetPath
stage
package
-/-
"build"
let
buildPath
=
contextPath
context
-/-
"build"
cSrcs
<-
cSources
context
-- TODO: remove code duplication (Library.hs)
hSrcs
<-
hSources
context
let
cObjs
=
[
buildPath
-/-
src
-<.>
osuf
vanilla
|
src
<-
cSrcs
]
...
...
@@ -89,11 +89,11 @@ buildBinary rs context @ (Context stage package _) bin = do
let
depContext
=
vanillaContext
libStage
dep
ghciFlag
<-
interpretInContext
depContext
$
getPkgData
BuildGhciLib
libFiles
<-
fmap
concat
.
forM
ways
$
\
way
->
do
libFile
<-
pkgLibraryFile
libStage
dep
way
lib0File
<-
pkgLibraryFile0
libStage
dep
way
libFile
<-
pkgLibraryFile
$
Context
libStage
dep
way
lib0File
<-
pkgLibraryFile0
$
Context
libStage
dep
way
dll0
<-
needDll0
libStage
dep
return
$
libFile
:
[
lib0File
|
dll0
]
ghciLib
<-
pkgGhciLibraryFile
libStage
dep
ghciLib
<-
pkgGhciLibraryFile
$
vanillaContext
libStage
dep
return
$
libFiles
++
[
ghciLib
|
ghciFlag
==
"YES"
&&
stage
==
Stage1
]
let
binDeps
=
if
package
==
ghcCabal
&&
stage
==
Stage0
then
[
pkgPath
package
-/-
src
<.>
"hs"
|
src
<-
hSrcs
]
...
...
src/Rules/Register.hs
View file @
badd5513
...
...
@@ -13,19 +13,19 @@ import Target
-- Build package-data.mk by using GhcCabal to process pkgCabal file
registerPackage
::
[(
Resource
,
Int
)]
->
Context
->
Rules
()
registerPackage
rs
context
@
(
Context
{
..
})
=
do
let
oldPath
=
pkgPath
package
-/-
targe
tDirectory
stage
package
-- TODO: remove, #113
let
oldPath
=
pkgPath
package
-/-
contex
tDirectory
context
-- TODO: remove, #113
pkgConf
=
packageDbDirectory
stage
-/-
pkgNameString
package
when
(
stage
<=
Stage1
)
$
matchVersionedFilePath
pkgConf
"conf"
?>
\
conf
->
do
-- This produces inplace-pkg-config. TODO: Add explicit tracking
need
[
pkgDataFile
stage
package
]
need
[
pkgDataFile
context
]
-- Post-process inplace-pkg-config. TODO: remove, see #113, #148
let
pkgConfig
=
oldPath
-/-
"inplace-pkg-config"
fixPkgConf
=
unlines
.
map
(
replace
oldPath
(
targetPath
stage
package
)
.
map
(
replace
oldPath
(
contextPath
context
)
.
replace
(
replaceSeparators
'
\\
'
$
oldPath
)
(
targetPath
stage
package
)
)
(
contextPath
context
)
)
.
lines
fixFile
pkgConfig
fixPkgConf
...
...
@@ -40,7 +40,7 @@ registerPackage rs context @ (Context {..}) = do
Target
context
(
GhcPkg
stage
)
[
rtsConf
]
[
conf
]
rtsConf
%>
\
_
->
do
need
[
pkgDataFile
Stage1
rts
,
rtsConfIn
]
need
[
pkgDataFile
rtsContext
,
rtsConfIn
]
build
$
Target
context
HsCpp
[
rtsConfIn
]
[
rtsConf
]
let
fixRtsConf
=
unlines
...
...
src/Settings.hs
View file @
badd5513
...
...
@@ -4,7 +4,7 @@ module Settings (
module
Settings
.
User
,
module
Settings
.
Ways
,
getPkgData
,
getPkgDataList
,
getTopDirectory
,
isLibrary
,
getPackagePath
,
get
Targe
tDirectory
,
get
Targe
tPath
,
getPackageSources
getPackagePath
,
get
Contex
tDirectory
,
get
Contex
tPath
,
getPackageSources
)
where
import
Base
...
...
@@ -20,17 +20,17 @@ import Settings.Ways
getPackagePath
::
Expr
FilePath
getPackagePath
=
pkgPath
<$>
getPackage
get
Targe
tDirectory
::
Expr
FilePath