[commit: ghc] wip/nfs-locking: Don't run GHC concurrently with ghc-pkg. (116bf85)
git at git.haskell.org
git at git.haskell.org
Fri Oct 27 00:47:15 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nfs-locking
Link : http://ghc.haskell.org/trac/ghc/changeset/116bf853352b305eccf1392561d699c551cb07aa/ghc
>---------------------------------------------------------------
commit 116bf853352b305eccf1392561d699c551cb07aa
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date: Sat Feb 6 02:40:15 2016 +0000
Don't run GHC concurrently with ghc-pkg.
Fix #205.
>---------------------------------------------------------------
116bf853352b305eccf1392561d699c551cb07aa
src/Rules/Compile.hs | 14 +++++++++-----
src/Rules/Data.hs | 24 ++----------------------
src/Rules/Register.hs | 30 ++++++++++++++++++++++++------
src/Rules/Resources.hs | 13 +++++++++----
4 files changed, 44 insertions(+), 37 deletions(-)
diff --git a/src/Rules/Compile.hs b/src/Rules/Compile.hs
index b27d36e..13af013 100644
--- a/src/Rules/Compile.hs
+++ b/src/Rules/Compile.hs
@@ -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]
diff --git a/src/Rules/Data.hs b/src/Rules/Data.hs
index ade93fd..00ec163 100644
--- a/src/Rules/Data.hs
+++ b/src/Rules/Data.hs
@@ -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
diff --git a/src/Rules/Register.hs b/src/Rules/Register.hs
index 8c3ec73..d1b5312 100644
--- a/src/Rules/Register.hs
+++ b/src/Rules/Register.hs
@@ -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
diff --git a/src/Rules/Resources.hs b/src/Rules/Resources.hs
index d5e58fe..40939e0 100644
--- a/src/Rules/Resources.hs
+++ b/src/Rules/Resources.hs
@@ -1,12 +1,17 @@
-module Rules.Resources (resourceRules, Resources (..)) where
+module Rules.Resources (resourceRules, Resources (..), resPackageDbLimit) where
import Base
data Resources = Resources
{
- resGhcPkg :: Resource
+ resPackageDb :: 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
More information about the ghc-commits
mailing list