Skip to content
GitLab
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
49c3bb1f
Commit
49c3bb1f
authored
Aug 02, 2015
by
Andrey Mokhov
Browse files
Configure packages in dependency order, refactor resources.
parent
8e9fe8d6
Changes
17
Hide whitespace changes
Inline
Side-by-side
doc/demo.txt
View file @
49c3bb1f
...
...
@@ -6,4 +6,9 @@
3. Reduce complexity when searching for source files by 40x:
* compiler, was: 25 dirs (24 source dirs + autogen) x 406 modules x 2 extensions = 20300 candidates
* compiler, now: 25 dirs x 20 module-dirs = 500 candidates
\ No newline at end of file
* compiler, now: 25 dirs x 20 module-dirs = 500 candidates
4. Limit parallelism of ghc-cabal & ghc-pkg
* https://mail.haskell.org/pipermail/ghc-commits/2013-May/001712.html
* see ghc.mk, comment about parallel ghc-pkg invokations
\ No newline at end of file
src/Base.hs
View file @
49c3bb1f
module
Base
(
shakeFilesPath
,
configPath
,
bootPackageConstraints
,
shakeFilesPath
,
configPath
,
bootPackageConstraints
,
packageDependencies
,
module
Development
.
Shake
,
module
Development
.
Shake
.
Util
,
module
Development
.
Shake
.
Config
,
...
...
@@ -21,3 +22,6 @@ configPath = "shake/cfg/"
bootPackageConstraints
::
FilePath
bootPackageConstraints
=
shakeFilesPath
++
"boot-package-constraints"
packageDependencies
::
FilePath
packageDependencies
=
shakeFilesPath
++
"package-dependencies"
src/Main.hs
View file @
49c3bb1f
...
...
@@ -7,3 +7,4 @@ main = shakeArgs shakeOptions{shakeFiles = shakeFilesPath} $ do
packageRules
-- see module Rules
configRules
-- see module Rules.Config
generateTargets
-- see module Rules
src/Oracles/Base.hs
View file @
49c3bb1f
...
...
@@ -38,7 +38,3 @@ configOracle = do
liftIO
$
readConfigFile
configFile
addOracle
$
\
(
ConfigKey
key
)
->
Map
.
lookup
key
<$>
cfg
()
return
()
-- Make oracle's output more distinguishable
putOracle
::
String
->
Action
()
putOracle
=
putColoured
Blue
src/Oracles/DependencyList.hs
View file @
49c3bb1f
...
...
@@ -7,7 +7,6 @@ module Oracles.DependencyList (
import
Base
import
Util
import
Oracles.Base
import
Data.List
import
Data.Maybe
import
Data.Function
...
...
src/Oracles/PackageData.hs
View file @
49c3bb1f
...
...
@@ -7,7 +7,6 @@ module Oracles.PackageData (
import
Base
import
Util
import
Oracles.Base
import
Data.List
import
Data.Maybe
import
Control.Applicative
...
...
src/Oracles/PackageDeps.hs
0 → 100644
View file @
49c3bb1f
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module
Oracles.PackageDeps
(
packageDeps
,
packageDepsOracle
)
where
import
Base
import
Oracles.Base
import
Data.Maybe
import
qualified
Data.HashMap.Strict
as
Map
import
Control.Applicative
newtype
PackageDepsKey
=
PackageDepsKey
String
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
-- packageDeps depFile objFile is an action that looks up dependencies of an
-- object file (objFile) in a generated dependecy file (depFile).
packageDeps
::
String
->
Action
[
String
]
packageDeps
pkg
=
do
res
<-
askOracle
$
PackageDepsKey
pkg
return
.
fromMaybe
[]
$
res
-- Oracle for 'path/dist/*.deps' files
packageDepsOracle
::
Rules
()
packageDepsOracle
=
do
deps
<-
newCache
$
\
_
->
do
putOracle
$
"Reading package dependencies..."
contents
<-
readFileLines
packageDependencies
return
.
Map
.
fromList
$
[
(
head
ps
,
tail
ps
)
|
line
<-
contents
,
let
ps
=
words
line
]
addOracle
$
\
(
PackageDepsKey
pkg
)
->
Map
.
lookup
pkg
<$>
deps
()
return
()
src/Oracles/WindowsRoot.hs
View file @
49c3bb1f
...
...
@@ -6,7 +6,6 @@ module Oracles.WindowsRoot (
import
Base
import
Util
import
Oracles.Base
import
Data.List
newtype
WindowsRoot
=
WindowsRoot
()
...
...
src/Rules.hs
View file @
49c3bb1f
...
...
@@ -10,6 +10,7 @@ import Rules.Cabal
import
Rules.Config
import
Rules.Package
import
Rules.Oracles
import
Rules.Resources
import
Settings.Packages
import
Settings.TargetDirectory
...
...
@@ -26,7 +27,8 @@ generateTargets = action $ do
-- TODO: add Stage2 (compiler only?)
packageRules
::
Rules
()
packageRules
=
packageRules
=
do
resources
<-
resourceRules
forM_
[
Stage0
,
Stage1
]
$
\
stage
->
do
forM_
knownPackages
$
\
pkg
->
do
buildPackage
(
stagePackageTarget
stage
pkg
)
buildPackage
resources
(
stagePackageTarget
stage
pkg
)
src/Rules/Actions.hs
View file @
49c3bb1f
module
Rules.Actions
(
build
,
buildWithResources
,
run
,
verboseRun
build
,
buildWithResources
)
where
import
Base
...
...
@@ -16,33 +16,25 @@ import Oracles.ArgsHash
-- built (that is, track changes in the build system).
buildWithResources
::
[(
Resource
,
Int
)]
->
FullTarget
->
Action
()
buildWithResources
rs
target
=
do
need
$
Target
.
dependencies
target
let
builder
=
Target
.
builder
target
deps
=
Target
.
dependencies
target
needBuilder
builder
need
deps
path
<-
builderPath
builder
argList
<-
interpret
target
args
-- The line below forces the rule to be rerun if the args hash has changed
argsHash
<-
askArgsHash
target
run
rs
(
Target
.
builder
target
)
argList
withResources
rs
$
do
putBuild
$
"/--------
\n
"
++
"| Running "
++
show
builder
++
" with arguments:"
mapM_
(
putBuild
.
(
"| "
++
))
$
interestingInfo
builder
argList
putBuild
$
"
\\
--------"
quietly
$
cmd
[
path
]
argList
-- Most targets are built without explicitly acquiring resources
build
::
FullTarget
->
Action
()
build
=
buildWithResources
[]
-- Run the builder with a given collection of arguments
verboseRun
::
[(
Resource
,
Int
)]
->
Builder
->
[
String
]
->
Action
()
verboseRun
rs
builder
args
=
do
needBuilder
builder
path
<-
builderPath
builder
withResources
rs
$
cmd
[
path
]
args
-- Run the builder with a given collection of arguments printing out a
-- terse commentary with only 'interesting' info for the builder.
run
::
[(
Resource
,
Int
)]
->
Builder
->
[
String
]
->
Action
()
run
rs
builder
args
=
do
putColoured
White
$
"/--------
\n
"
++
"| Running "
++
show
builder
++
" with arguments:"
mapM_
(
putColoured
White
.
(
"| "
++
))
$
interestingInfo
builder
args
putColoured
White
$
"
\\
--------"
quietly
$
verboseRun
rs
builder
args
interestingInfo
::
Builder
->
[
String
]
->
[
String
]
interestingInfo
builder
ss
=
case
builder
of
Ar
->
prefixAndSuffix
2
1
ss
...
...
src/Rules/Cabal.hs
View file @
49c3bb1f
...
...
@@ -3,27 +3,45 @@ module Rules.Cabal (cabalRules) where
import
Base
import
Util
import
Stage
import
Package
import
Expression
import
Package
hiding
(
pkgName
,
library
)
import
Expression
hiding
(
package
)
import
Settings.Packages
import
Data.List
import
Data.Version
import
qualified
Distribution.Package
as
D
import
qualified
Distribution.
PackageDescription
as
D
import
qualified
Distribution.
Verbosity
as
D
import
qualified
Distribution.PackageDescription.Parse
as
D
import
Distribution.Package
import
Distribution.
Verbosity
import
Distribution.
PackageDescription
import
Distribution.PackageDescription.Parse
cabalRules
::
Rules
()
cabalRules
=
cabalRules
=
do
-- Cache boot package constraints (to be used in cabalArgs)
bootPackageConstraints
%>
\
file
->
do
pkgs
<-
interpret
(
stageTarget
Stage0
)
packages
constraints
<-
forM
(
sort
pkgs
)
$
\
pkg
->
do
let
cabal
=
pkgPath
pkg
-/-
pkgCabal
pkg
need
[
cabal
]
descr
<-
liftIO
$
D
.
readPackageDescription
D
.
silent
cabal
let
identifier
=
D
.
package
.
D
.
packageDescription
$
descr
version
=
showVersion
.
D
.
pkgVersion
$
identifier
D
.
PackageName
name
=
D
.
pkgName
$
identifier
descr
iption
<-
liftIO
$
readPackageDescription
silent
cabal
let
identifier
=
package
.
packageDescription
$
descr
iption
version
=
showVersion
.
pkgVersion
$
identifier
PackageName
name
=
pkgName
identifier
return
$
name
++
" == "
++
version
writeFileChanged
file
.
unlines
$
constraints
-- Cache package dependencies
packageDependencies
%>
\
file
->
do
pkgs
<-
interpret
(
stageTarget
Stage1
)
packages
pkgDeps
<-
forM
(
sort
pkgs
)
$
\
pkg
->
do
let
cabal
=
pkgPath
pkg
-/-
pkgCabal
pkg
need
[
cabal
]
description
<-
liftIO
$
readPackageDescription
silent
cabal
let
deps
=
collectDeps
.
condLibrary
$
description
depNames
=
[
name
|
Dependency
(
PackageName
name
)
_
<-
deps
]
return
.
unwords
$
(
dropExtension
$
pkgCabal
pkg
)
:
sort
depNames
writeFileChanged
file
$
unlines
pkgDeps
collectDeps
::
Maybe
(
CondTree
v
[
Dependency
]
a
)
->
[
Dependency
]
collectDeps
Nothing
=
[]
collectDeps
(
Just
(
CondNode
_
deps
ifs
))
=
deps
++
concatMap
f
ifs
where
f
(
_
,
t
,
mt
)
=
collectDeps
(
Just
t
)
++
collectDeps
mt
src/Rules/Data.hs
View file @
49c3bb1f
...
...
@@ -7,24 +7,25 @@ import Builder
import
Switches
import
Expression
import
qualified
Target
import
Oracles.PackageDeps
import
Settings.Packages
import
Settings.TargetDirectory
import
Rules.Actions
import
Rules.Resources
import
Data.List
import
Data.Maybe
import
Control.Applicative
import
Control.Monad.Extra
-- TODO: Add ordering between packages? (see ghc.mk)
-- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData
::
StagePackageTarget
->
Rules
()
buildPackageData
target
=
do
buildPackageData
::
Resources
->
StagePackageTarget
->
Rules
()
buildPackageData
(
Resources
ghcCabal
ghcPkg
)
target
=
do
let
stage
=
Target
.
stage
target
pkg
=
Target
.
package
target
path
=
targetPath
stage
pkg
cabal
=
pkgPath
pkg
-/-
pkgCabal
pkg
configure
=
pkgPath
pkg
-/-
"configure"
-- We do not allow parallel invokations of ghc-pkg (they don't work)
ghcPkg
<-
newResource
"ghc-pkg"
1
(
path
-/-
)
<$>
[
"package-data.mk"
,
"haddock-prologue.txt"
...
...
@@ -37,13 +38,27 @@ buildPackageData target = do
-- GhcCabal may run the configure script, so we depend on it
-- We don't know who built the configure script from configure.ac
whenM
(
doesFileExist
$
configure
<.>
"ac"
)
$
need
[
configure
]
buildWithResources
[(
ghcPkg
,
1
)]
$
-- GhcCabal calls ghc-pkg too
-- We configure packages in the order of their dependencies
deps
<-
packageDeps
.
dropExtension
.
pkgCabal
$
pkg
pkgs
<-
interpret
target
packages
let
depPkgs
=
concatMap
(
maybeToList
.
findPackage
pkgs
)
deps
need
$
map
(
\
p
->
targetPath
stage
p
-/-
"package-data.mk"
)
depPkgs
buildWithResources
[(
ghcCabal
,
1
)]
$
fullTarget
target
[
cabal
]
GhcCabal
files
-- TODO: find out of ghc-cabal can be concurrent with ghc-pkg
whenM
(
interpretExpr
target
registerPackage
)
.
buildWithResources
[(
ghcPkg
,
1
)]
$
fullTarget
target
[
cabal
]
(
GhcPkg
stage
)
files
postProcessPackageData
$
path
-/-
"package-data.mk"
-- Given a package name findPackage attempts to find it a given package list
findPackage
::
[
Package
]
->
String
->
Maybe
Package
findPackage
pkgs
name
=
find
(
\
pkg
->
dropExtension
(
pkgCabal
pkg
)
==
name
)
pkgs
-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
-- 1) Drop lines containing '$'
-- For example, get rid of
...
...
src/Rules/Dependencies.hs
View file @
49c3bb1f
...
...
@@ -10,9 +10,10 @@ import Oracles.PackageData
import
Settings.Util
import
Settings.TargetDirectory
import
Rules.Actions
import
Rules.Resources
buildPackageDependencies
::
StagePackageTarget
->
Rules
()
buildPackageDependencies
target
=
buildPackageDependencies
::
Resources
->
StagePackageTarget
->
Rules
()
buildPackageDependencies
_
target
=
let
stage
=
Target
.
stage
target
pkg
=
Target
.
package
target
path
=
targetPath
stage
pkg
...
...
src/Rules/Oracles.hs
View file @
49c3bb1f
...
...
@@ -7,12 +7,14 @@ import Oracles.Base
import
Oracles.ArgsHash
import
Oracles.PackageData
import
Oracles.WindowsRoot
import
Oracles.PackageDeps
import
Oracles.DependencyList
oracleRules
::
Rules
()
oracleRules
=
do
configOracle
-- see Oracles.Base
packageDataOracle
-- see Oracles.PackageData
packageDepsOracle
-- see Oracles.PackageDeps
dependencyListOracle
-- see Oracles.DependencyList
argsHashOracle
-- see Oracles.ArgsHash
windowsRootOracle
-- see Oracles.WindowsRoot
src/Rules/Package.hs
View file @
49c3bb1f
...
...
@@ -3,7 +3,8 @@ module Rules.Package (buildPackage) where
import
Base
import
Expression
import
Rules.Data
import
Rules.Resources
import
Rules.Dependencies
buildPackage
::
StagePackageTarget
->
Rules
()
buildPackage
::
Resources
->
StagePackageTarget
->
Rules
()
buildPackage
=
buildPackageData
<>
buildPackageDependencies
src/Rules/Resources.hs
0 → 100644
View file @
49c3bb1f
module
Rules.Resources
(
resourceRules
,
Resources
(
..
)
)
where
import
Base
data
Resources
=
Resources
{
ghcCabal
::
Resource
,
ghcPkg
::
Resource
}
-- Unfortunately parallel invokations of ghc-cabal or ghc-pkg do not work:
-- * https://mail.haskell.org/pipermail/ghc-commits/2013-May/001712.html
-- * ghc.mk: see comment about parallel ghc-pkg invokations
resourceRules
::
Rules
Resources
resourceRules
=
do
ghcCabal
<-
newResource
"ghc-cabal"
1
ghcPkg
<-
newResource
"ghc-pkg"
1
return
$
Resources
ghcCabal
ghcPkg
src/Util.hs
View file @
49c3bb1f
...
...
@@ -4,7 +4,7 @@ module Util (
replaceIf
,
replaceEq
,
replaceSeparators
,
unifyPath
,
(
-/-
),
chunksOfSize
,
putColoured
,
redError
,
redError_
,
putColoured
,
putOracle
,
putBuild
,
redError
,
redError_
,
bimap
,
minusOrd
,
intersectOrd
)
where
...
...
@@ -56,6 +56,15 @@ putColoured colour msg = do
liftIO
$
setSGR
[]
liftIO
$
hFlush
stdout
-- Make oracle output more distinguishable
putOracle
::
String
->
Action
()
putOracle
=
putColoured
Blue
-- Make build output more distinguishable
putBuild
::
String
->
Action
()
putBuild
=
putColoured
White
-- A more colourful version of error
redError
::
String
->
Action
a
redError
msg
=
do
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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