[commit: ghc] wip/nfs-locking: Pass way to compilePackage via Context. (23d501a)

[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/23d501a474266920e395e60d4d6c69369785608f/ghc

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

commit 23d501a474266920e395e60d4d6c69369785608f
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Tue Feb 16 02:24:35 2016 +0000

    Pass way to compilePackage via Context.
    
    See #207.


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

23d501a474266920e395e60d4d6c69369785608f
 src/Rules.hs         | 10 +++++++---
 src/Rules/Compile.hs | 37 ++++++++++++++-----------------------
 2 files changed, 21 insertions(+), 26 deletions(-)

diff --git a/src/Rules.hs b/src/Rules.hs
index e12fc1c..f765b5e 100644
--- a/src/Rules.hs
+++ b/src/Rules.hs
@@ -3,6 +3,7 @@ module Rules (topLevelTargets, buildRules) where
 import Data.Foldable
 
 import Base
+import Context hiding (stage, package, way)
 import Expression
 import GHC
 import Rules.Compile
@@ -52,18 +53,21 @@ topLevelTargets = do
 
 packageRules :: Rules ()
 packageRules = do
-    -- 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
+    -- We cannot register multiple GHC 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)]
 
+    let contexts = liftM3 Context allStages knownPackages allWays
+
+    traverse_ (compilePackage readPackageDb) contexts
+
     for_ allStages $ \stage ->
         for_ knownPackages $ \package -> do
             let context = vanillaContext stage package
-            compilePackage            readPackageDb  context
             buildPackageData                         context
             buildPackageDependencies  readPackageDb  context
             buildPackageDocumentation                context
diff --git a/src/Rules/Compile.hs b/src/Rules/Compile.hs
index b583f5a..14e71ee 100644
--- a/src/Rules/Compile.hs
+++ b/src/Rules/Compile.hs
@@ -9,52 +9,43 @@ import Rules.Actions
 import Settings
 import Target hiding (context)
 
--- TODO: Use way from Context, #207
 compilePackage :: [(Resource, Int)] -> Context -> Rules ()
 compilePackage rs context @ (Context {..}) = do
     let buildPath = targetPath stage package -/- "build"
 
-    matchBuildResult buildPath "hi" ?> \hi ->
+    buildPath <//> "*" <.> hisuf way %> \hi ->
         if compileInterfaceFilesSeparately && not ("//HpcParser.*" ?== hi)
         then do
-            let w = detectWay hi
-            (src, deps) <- dependencies buildPath $ hi -<.> osuf w
+            (src, deps) <- dependencies buildPath $ hi -<.> osuf way
             need $ src : deps
-            buildWithResources rs $
-                Target (context { way = w }) (Ghc stage) [src] [hi]
-        else need [ hi -<.> osuf (detectWay hi) ]
+            buildWithResources rs $ Target context (Ghc stage) [src] [hi]
+        else need [ hi -<.> osuf way ]
 
-    matchBuildResult buildPath "hi-boot" ?> \hiboot ->
+    buildPath <//> "*" <.> hibootsuf way %> \hiboot ->
         if compileInterfaceFilesSeparately
         then do
-            let w = detectWay hiboot
-            (src, deps) <- dependencies buildPath $ hiboot -<.> obootsuf w
+            (src, deps) <- dependencies buildPath $ hiboot -<.> obootsuf way
             need $ src : deps
-            buildWithResources rs $
-                Target (context { way = w }) (Ghc stage) [src] [hiboot]
-        else need [ hiboot -<.> obootsuf (detectWay hiboot) ]
+            buildWithResources rs $ Target context (Ghc stage) [src] [hiboot]
+        else need [ hiboot -<.> obootsuf way ]
 
     -- TODO: add dependencies for #include of .h and .hs-incl files (gcc -MM?)
-    matchBuildResult buildPath "o" ?> \obj -> do
+    buildPath <//> "*" <.> osuf way %> \obj -> do
         (src, deps) <- dependencies buildPath obj
         if ("//*.c" ?== src)
         then do
             need $ src : deps
             build $ Target context (Gcc stage) [src] [obj]
         else do
-            let w = detectWay obj
             if compileInterfaceFilesSeparately && "//*.hs" ?== src && not ("//HpcParser.*" ?== src)
-            then need $ (obj -<.> hisuf (detectWay obj)) : src : deps
+            then need $ (obj -<.> hisuf way) : src : deps
             else need $ src : deps
-            buildWithResources rs $
-                Target (context { way = w }) (Ghc stage) [src] [obj]
+            buildWithResources rs $ Target context (Ghc stage) [src] [obj]
 
     -- TODO: get rid of these special cases
-    matchBuildResult buildPath "o-boot" ?> \obj -> do
+    buildPath <//> "*" <.> obootsuf way %> \obj -> do
         (src, deps) <- dependencies buildPath obj
-        let w = detectWay obj
         if compileInterfaceFilesSeparately
-        then need $ (obj -<.> hibootsuf (detectWay obj)) : src : deps
+        then need $ (obj -<.> hibootsuf way) : src : deps
         else need $ src : deps
-        buildWithResources rs $
-            Target (context { way = w }) (Ghc stage) [src] [obj]
+        buildWithResources rs $ Target context (Ghc stage) [src] [obj]