[commit: ghc] wip/nfs-locking: Add support for resources. Limit parallelism of ghc-pkg. (6547fc7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/6547fc76758720a51f4b0d4819b95128892be459/ghc

>---------------------------------------------------------------

commit 6547fc76758720a51f4b0d4819b95128892be459
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Sun Jul 26 17:03:36 2015 +0100

    Add support for resources. Limit parallelism of ghc-pkg.


>---------------------------------------------------------------

6547fc76758720a51f4b0d4819b95128892be459
 src/Rules/Actions.hs | 33 ++++++++++++++++-----------------
 src/Rules/Data.hs    | 39 ++++++++++++++++++++++-----------------
 src/Target.hs        |  5 +++--
 3 files changed, 41 insertions(+), 36 deletions(-)

diff --git a/src/Rules/Actions.hs b/src/Rules/Actions.hs
index 055931e..2730c55 100644
--- a/src/Rules/Actions.hs
+++ b/src/Rules/Actions.hs
@@ -1,5 +1,5 @@
 module Rules.Actions (
-    build, buildWhen, run, verboseRun
+    build, buildWithResources, run, verboseRun
     ) where
 
 import Util
@@ -11,38 +11,37 @@ import Settings.Util
 import Oracles.ArgsHash
 import Development.Shake
 
--- Build a given target using an appropriate builder. Force a rebuilt if the
--- argument list has changed since the last built (that is, track changes in
--- the build system).
-build :: FullTarget -> Action ()
-build target = do
+-- Build a given target using an appropriate builder and acquiring necessary
+-- resources. Force a rebuilt if the argument list has changed since the last
+-- built (that is, track changes in the build system).
+buildWithResources :: [(Resource, Int)] -> FullTarget -> Action ()
+buildWithResources rs target = do
     need $ Target.dependencies target
     argList <- interpret target args
     -- The line below forces the rule to be rerun if the args hash has changed
     argsHash <- askArgsHash target
-    run (Target.builder target) argList
+    run rs (Target.builder target) argList
 
-buildWhen :: Predicate -> FullTarget -> Action ()
-buildWhen predicate target = do
-    bool <- interpretExpr target predicate
-    when bool $ build target
+-- Most targets are built without explicitly acquiring resources
+build :: FullTarget -> Action ()
+build = buildWithResources []
 
 -- Run the builder with a given collection of arguments
-verboseRun :: Builder -> [String] -> Action ()
-verboseRun builder args = do
+verboseRun :: [(Resource, Int)] -> Builder -> [String] -> Action ()
+verboseRun rs builder args = do
     needBuilder builder
     path <- builderPath builder
-    cmd [path] args
+    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 :: Builder -> [String] -> Action ()
-run builder args = do
+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 builder args
+    quietly $ verboseRun rs builder args
 
 interestingInfo :: Builder -> [String] -> [String]
 interestingInfo builder ss = case builder of
diff --git a/src/Rules/Data.hs b/src/Rules/Data.hs
index b48ff48..d60dbfa 100644
--- a/src/Rules/Data.hs
+++ b/src/Rules/Data.hs
@@ -12,31 +12,36 @@ import Control.Applicative
 import Control.Monad.Extra
 import Development.Shake
 
+-- TODO: Add ordering between packages? (see ghc.mk)
 -- Build package-data.mk by using GhcCabal to process pkgCabal file
 buildPackageData :: StagePackageTarget -> Rules ()
-buildPackageData target =
+buildPackageData target = do
     let stage     = Target.stage target
         pkg       = Target.package target
         path      = targetPath stage pkg
         cabal     = pkgPath pkg -/- pkgCabal pkg
         configure = pkgPath pkg -/- "configure"
-    in
+
+    -- 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"
-    , "inplace-pkg-config"
-    , "setup-config"
-    , "build" -/- "autogen" -/- "cabal_macros.h"
-    -- TODO: Is this needed? Also check out Paths_cpsa.hs.
-    -- , "build" -/- "autogen" -/- ("Paths_" ++ name) <.> "hs"
-    ] &%> \files -> do
-        -- GhcCabal may run the configure script, so we depend on it
-        -- We still don't know who built the configure script from configure.ac
-        whenM (doesFileExist $ configure <.> "ac") $ need [configure]
-        build $ fullTarget target [cabal] GhcCabal files
-        buildWhen registerPackage $
-            fullTarget target [cabal] (GhcPkg stage) files
-        postProcessPackageData $ path -/- "package-data.mk"
+        [ "package-data.mk"
+        , "haddock-prologue.txt"
+        , "inplace-pkg-config"
+        , "setup-config"
+        , "build" -/- "autogen" -/- "cabal_macros.h"
+        -- TODO: Is this needed? Also check out Paths_cpsa.hs.
+        -- , "build" -/- "autogen" -/- ("Paths_" ++ name) <.> "hs"
+        ] &%> \files -> 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]
+            build $ fullTarget target [cabal] GhcCabal files
+            whenM (interpretExpr target registerPackage) .
+                buildWithResources [(ghcPkg, 1)] $
+                fullTarget target [cabal] (GhcPkg stage) files
+            postProcessPackageData $ path -/- "package-data.mk"
 
 -- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
 -- 1) Drop lines containing '$'
diff --git a/src/Target.hs b/src/Target.hs
index c3b6b93..dc0bde7 100644
--- a/src/Target.hs
+++ b/src/Target.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-}
 module Target (
     Target (..), StageTarget (..), StagePackageTarget (..), FullTarget (..),
-    stageTarget, stagePackageTarget, fullTarget, fullTargetWithWay
+    stageTarget, stagePackageTarget, fullTarget, fullTargetWithWay,
     ) where
 
 import Way
@@ -72,7 +72,8 @@ fullTarget target deps b fs = target
     }
 
 -- Use this function to be explicit about the build way.
-fullTargetWithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way -> [FilePath] -> FullTarget
+fullTargetWithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way
+                  -> [FilePath] -> FullTarget
 fullTargetWithWay target deps b w fs = target
     {
         dependencies = deps,