Commit 116bf853 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Don't run GHC concurrently with ghc-pkg.

Fix #205.
parent 83c1e5e7
......@@ -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]
......@@ -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
......
......@@ -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
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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment