Drop Rules.Resources, move packageDb resource to buildRules.

shaking-up-ghc.cabal

@@ -61,7 +61,6 @@ executable ghc-shake
                        , Rules.Perl
                        , Rules.Program
                        , Rules.Register
-                       , Rules.Resources
                        , Rules.Selftest
                        , Rules.Setup
                        , Rules.Test

src/Rules.hs

@@ -10,7 +10,6 @@ import Rules.Data
 import Rules.Dependencies
 import Rules.Documentation
 import Rules.Generate
-import Rules.Resources
 import Rules.Cabal
 import Rules.Gmp
 import Rules.Libffi
@@ -53,18 +52,25 @@ topLevelTargets = do
 
 packageRules :: Rules ()
 packageRules = do
-    resources <- resourceRules
+    -- 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.
+    let maxConcurrentReaders = 1000
+    packageDb <- newResource "package-db" maxConcurrentReaders
+    let readPackageDb  = [(packageDb, 1)]
+        writePackageDb = [(packageDb, maxConcurrentReaders)]
+
     for_ allStages $ \stage ->
         for_ knownPackages $ \package -> do
             let context = vanillaContext stage package
-            compilePackage            resources context
-            buildPackageData                    context
-            buildPackageDependencies  resources context
-            buildPackageDocumentation           context
-            generatePackageCode                 context
-            buildPackageLibrary                 context
-            buildProgram                        context
-            registerPackage           resources context
+            compilePackage            readPackageDb  context
+            buildPackageData                         context
+            buildPackageDependencies  readPackageDb  context
+            buildPackageDocumentation                context
+            generatePackageCode                      context
+            buildPackageLibrary                      context
+            buildProgram                             context
+            registerPackage           writePackageDb context
 
 buildRules :: Rules ()
 buildRules = do

src/Rules/Compile.hs

@@ -6,12 +6,11 @@ import Context
 import Expression
 import Oracles.Dependencies
 import Rules.Actions
-import Rules.Resources
 import Settings
 import Target hiding (context)
 
 -- TODO: Use way from Context, #207
-compilePackage :: Resources -> Context -> Rules ()
+compilePackage :: [(Resource, Int)] -> Context -> Rules ()
 compilePackage rs context @ (Context {..}) = do
     let buildPath = targetPath stage package -/- "build"
 
@@ -21,7 +20,7 @@ compilePackage rs context @ (Context {..}) = do
             let w = detectWay hi
             (src, deps) <- dependencies buildPath $ hi -<.> osuf w
             need $ src : deps
-            buildWithResources [(resPackageDb rs, 1)] $
+            buildWithResources rs $
                 Target (context { way = w }) (Ghc stage) [src] [hi]
         else need [ hi -<.> osuf (detectWay hi) ]
 
@@ -31,7 +30,7 @@ compilePackage rs context @ (Context {..}) = do
             let w = detectWay hiboot
             (src, deps) <- dependencies buildPath $ hiboot -<.> obootsuf w
             need $ src : deps
-            buildWithResources [(resPackageDb rs, 1)] $
+            buildWithResources rs $
                 Target (context { way = w }) (Ghc stage) [src] [hiboot]
         else need [ hiboot -<.> obootsuf (detectWay hiboot) ]
 
@@ -47,7 +46,7 @@ compilePackage rs context @ (Context {..}) = do
             if compileInterfaceFilesSeparately && "//*.hs" ?== src && not ("//HpcParser.*" ?== src)
             then need $ (obj -<.> hisuf (detectWay obj)) : src : deps
             else need $ src : deps
-            buildWithResources [(resPackageDb rs, 1)] $
+            buildWithResources rs $
                 Target (context { way = w }) (Ghc stage) [src] [obj]
 
     -- TODO: get rid of these special cases
@@ -57,5 +56,5 @@ compilePackage rs context @ (Context {..}) = do
         if compileInterfaceFilesSeparately
         then need $ (obj -<.> hibootsuf (detectWay obj)) : src : deps
         else need $ src : deps
-        buildWithResources [(resPackageDb rs, 1)] $
+        buildWithResources rs $
             Target (context { way = w }) (Ghc stage) [src] [obj]

src/Rules/Dependencies.hs

@@ -8,12 +8,11 @@ import Context
 import Expression
 import Oracles.PackageData
 import Rules.Actions
-import Rules.Resources
 import Settings
 import Target
 
 -- TODO: simplify handling of AutoApply.cmm
-buildPackageDependencies :: Resources -> Context -> Rules ()
+buildPackageDependencies :: [(Resource, Int)] -> Context -> Rules ()
 buildPackageDependencies rs context @ (Context {..}) =
     let path      = targetPath stage package
         buildPath = path -/- "build"
@@ -33,7 +32,7 @@ buildPackageDependencies rs context @ (Context {..}) =
             need srcs
             if srcs == []
             then writeFileChanged out ""
-            else buildWithResources [(resPackageDb rs, 1)] $
+            else buildWithResources rs $
                 Target context (GhcM stage) srcs [out]
             removeFileIfExists $ out <.> "bak"
 

src/Rules/Register.hs

@@ -9,14 +9,13 @@ import Expression
 import GHC
 import Rules.Actions
 import Rules.Libffi
-import Rules.Resources
 import Settings
 import Settings.Packages.Rts
 import Target
 
 -- TODO: Use way from Context, #207
 -- Build package-data.mk by using GhcCabal to process pkgCabal file
-registerPackage :: Resources -> Context -> Rules ()
+registerPackage :: [(Resource, Int)] -> Context -> Rules ()
 registerPackage rs context @ (Context {..}) = do
     let oldPath = pkgPath package -/- targetDirectory stage package -- TODO: remove, #113
         pkgConf = packageDbDirectory stage -/- pkgNameString package
@@ -38,13 +37,13 @@ registerPackage rs context @ (Context {..}) = do
 
         fixFile pkgConfig fixPkgConf
 
-        buildWithResources [(resPackageDb rs, resPackageDbLimit)] $
+        buildWithResources rs $
             Target context (GhcPkg stage) [pkgConfig] [conf]
 
     when (package == rts && stage == Stage1) $ do
         packageDbDirectory Stage1 -/- "rts.conf" %> \conf -> do
             need [rtsConf]
-            buildWithResources [(resPackageDb rs, resPackageDbLimit)] $
+            buildWithResources rs $
                 Target context (GhcPkg stage) [rtsConf] [conf]
 
         rtsConf %> \_ -> do

src/Rules/Resources.hs

-module Rules.Resources (resourceRules, Resources (..), resPackageDbLimit) where
-
-import Base
-
-data Resources = Resources
-    {
-        resPackageDb :: Resource
-    }
-
--- 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 "package-db" resPackageDbLimit
-
-resPackageDbLimit :: Int
-resPackageDbLimit = 1000