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
116bf853
Commit
116bf853
authored
Feb 06, 2016
by
Andrey Mokhov
Browse files
Don't run GHC concurrently with ghc-pkg.
Fix
#205
.
parent
83c1e5e7
Changes
4
Hide whitespace changes
Inline
Side-by-side
src/Rules/Compile.hs
View file @
116bf853
...
...
@@ -8,7 +8,7 @@ import Rules.Resources
import
Settings
compilePackage
::
Resources
->
PartialTarget
->
Rules
()
compilePackage
_
target
@
(
PartialTarget
stage
pkg
)
=
do
compilePackage
rs
target
@
(
PartialTarget
stage
pkg
)
=
do
let
buildPath
=
targetPath
stage
pkg
-/-
"build"
matchBuildResult
buildPath
"hi"
?>
\
hi
->
...
...
@@ -17,7 +17,8 @@ compilePackage _ target @ (PartialTarget stage pkg) = do
let
way
=
detectWay
hi
(
src
,
deps
)
<-
dependencies
buildPath
$
hi
-<.>
osuf
way
need
$
src
:
deps
build
$
fullTargetWithWay
target
(
Ghc
stage
)
way
[
src
]
[
hi
]
buildWithResources
[(
resPackageDb
rs
,
1
)]
$
fullTargetWithWay
target
(
Ghc
stage
)
way
[
src
]
[
hi
]
else
need
[
hi
-<.>
osuf
(
detectWay
hi
)
]
matchBuildResult
buildPath
"hi-boot"
?>
\
hiboot
->
...
...
@@ -26,7 +27,8 @@ compilePackage _ target @ (PartialTarget stage pkg) = do
let
way
=
detectWay
hiboot
(
src
,
deps
)
<-
dependencies
buildPath
$
hiboot
-<.>
obootsuf
way
need
$
src
:
deps
build
$
fullTargetWithWay
target
(
Ghc
stage
)
way
[
src
]
[
hiboot
]
buildWithResources
[(
resPackageDb
rs
,
1
)]
$
fullTargetWithWay
target
(
Ghc
stage
)
way
[
src
]
[
hiboot
]
else
need
[
hiboot
-<.>
obootsuf
(
detectWay
hiboot
)
]
-- TODO: add dependencies for #include of .h and .hs-incl files (gcc -MM?)
...
...
@@ -41,7 +43,8 @@ compilePackage _ target @ (PartialTarget stage pkg) = do
if
compileInterfaceFilesSeparately
&&
"//*.hs"
?==
src
&&
not
(
"//HpcParser.*"
?==
src
)
then
need
$
(
obj
-<.>
hisuf
(
detectWay
obj
))
:
src
:
deps
else
need
$
src
:
deps
build
$
fullTargetWithWay
target
(
Ghc
stage
)
way
[
src
]
[
obj
]
buildWithResources
[(
resPackageDb
rs
,
1
)]
$
fullTargetWithWay
target
(
Ghc
stage
)
way
[
src
]
[
obj
]
-- TODO: get rid of these special cases
matchBuildResult
buildPath
"o-boot"
?>
\
obj
->
do
...
...
@@ -50,4 +53,5 @@ compilePackage _ target @ (PartialTarget stage pkg) = do
if
compileInterfaceFilesSeparately
then
need
$
(
obj
-<.>
hibootsuf
(
detectWay
obj
))
:
src
:
deps
else
need
$
src
:
deps
build
$
fullTargetWithWay
target
(
Ghc
stage
)
way
[
src
]
[
obj
]
buildWithResources
[(
resPackageDb
rs
,
1
)]
$
fullTargetWithWay
target
(
Ghc
stage
)
way
[
src
]
[
obj
]
src/Rules/Data.hs
View file @
116bf853
...
...
@@ -12,11 +12,10 @@ import Rules.Libffi
import
Rules.Resources
import
Settings
import
Settings.Builders.Common
import
Settings.Packages.Rts
-- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData
::
Resources
->
PartialTarget
->
Rules
()
buildPackageData
rs
target
@
(
PartialTarget
stage
pkg
)
=
do
buildPackageData
_
target
@
(
PartialTarget
stage
pkg
)
=
do
let
cabalFile
=
pkgCabalFile
pkg
configure
=
pkgPath
pkg
-/-
"configure"
dataFile
=
pkgDataFile
stage
pkg
...
...
@@ -34,8 +33,7 @@ buildPackageData rs target @ (PartialTarget stage pkg) = do
deps
<-
packageDeps
pkg
pkgs
<-
interpretPartial
target
getPackages
let
depPkgs
=
matchPackageNames
(
sort
pkgs
)
deps
depConfs
<-
traverse
(
pkgConfFile
stage
)
depPkgs
orderOnly
depConfs
need
=<<
traverse
(
pkgConfFile
stage
)
depPkgs
-- TODO: get rid of this, see #113
let
inTreeMk
=
oldPath
-/-
takeFileName
dataFile
...
...
@@ -126,24 +124,6 @@ buildPackageData rs target @ (PartialTarget stage pkg) = do
writeFileChanged
mk
contents
putSuccess
$
"| Successfully generated '"
++
mk
++
"'."
need
[
rtsConf
]
buildWithResources
[(
resGhcPkg
rs
,
1
)]
$
fullTarget
target
(
GhcPkg
stage
)
[
rtsConf
]
[]
rtsConf
%>
\
_
->
do
orderOnly
$
generatedDependencies
stage
pkg
need
[
rtsConfIn
]
build
$
fullTarget
target
HsCpp
[
rtsConfIn
]
[
rtsConf
]
let
fixRtsConf
=
unlines
.
map
(
replace
"
\"\"
"
""
.
replace
"rts/dist/build"
rtsBuildPath
)
.
filter
(
not
.
null
)
.
lines
fixFile
rtsConf
fixRtsConf
-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
-- 1) Drop lines containing '$'
-- For example, get rid of
...
...
src/Rules/Register.hs
View file @
116bf853
...
...
@@ -6,11 +6,10 @@ import Base
import
Expression
import
GHC
import
Rules.Actions
import
Rules.Libffi
import
Rules.Resources
import
Settings
-- matchPkgConf :: FilePath -> Bool
-- matchPkgConf file =
import
Settings.Packages.Rts
-- Build package-data.mk by using GhcCabal to process pkgCabal file
registerPackage
::
Resources
->
PartialTarget
->
Rules
()
...
...
@@ -21,7 +20,7 @@ registerPackage rs target @ (PartialTarget stage pkg) = do
Nothing
->
False
Just
suf
->
dropWhile
(
\
c
->
isDigit
c
||
c
==
'.'
)
suf
==
"conf"
when
(
stage
<=
Stage1
)
$
match
?>
\
_
->
do
when
(
stage
<=
Stage1
)
$
match
?>
\
conf
->
do
-- This produces pkgConfig. TODO: Add explicit tracking
need
[
pkgDataFile
stage
pkg
]
...
...
@@ -35,5 +34,24 @@ registerPackage rs target @ (PartialTarget stage pkg) = do
fixFile
pkgConfig
fixPkgConf
buildWithResources
[(
resGhcPkg
rs
,
1
)]
$
fullTarget
target
(
GhcPkg
stage
)
[
pkgConfig
]
[]
buildWithResources
[(
resPackageDb
rs
,
resPackageDbLimit
)]
$
fullTarget
target
(
GhcPkg
stage
)
[
pkgConfig
]
[
conf
]
when
(
pkg
==
rts
&&
stage
==
Stage1
)
$
do
packageDbDirectory
Stage1
-/-
"rts.conf"
%>
\
conf
->
do
need
[
rtsConf
]
buildWithResources
[(
resPackageDb
rs
,
resPackageDbLimit
)]
$
fullTarget
target
(
GhcPkg
stage
)
[
rtsConf
]
[
conf
]
rtsConf
%>
\
_
->
do
need
[
pkgDataFile
Stage1
rts
,
rtsConfIn
]
build
$
fullTarget
target
HsCpp
[
rtsConfIn
]
[
rtsConf
]
let
fixRtsConf
=
unlines
.
map
(
replace
"
\"\"
"
""
.
replace
"rts/dist/build"
rtsBuildPath
)
.
filter
(
not
.
null
)
.
lines
fixFile
rtsConf
fixRtsConf
src/Rules/Resources.hs
View file @
116bf853
module
Rules.Resources
(
resourceRules
,
Resources
(
..
))
where
module
Rules.Resources
(
resourceRules
,
Resources
(
..
)
,
resPackageDbLimit
)
where
import
Base
data
Resources
=
Resources
{
res
GhcPkg
::
Resource
res
PackageDb
::
Resource
}
-- We cannot register multiple packages in parallel:
-- We cannot register multiple packages in parallel. Also we cannot run GHC
-- when the package database is being mutated by "ghc-pkg". This is a classic
-- concurrent read exclusive write (CREW) conflict.
resourceRules
::
Rules
Resources
resourceRules
=
Resources
<$>
newResource
"ghc-pkg"
1
resourceRules
=
Resources
<$>
newResource
"package-db"
resPackageDbLimit
resPackageDbLimit
::
Int
resPackageDbLimit
=
1000
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