Configure packages in dependency order, refactor resources.

doc/demo.txt

@@ -6,4 +6,9 @@
 3. Reduce complexity when searching for source files by 40x:
 
 * compiler, was: 25 dirs (24 source dirs + autogen) x 406 modules x 2 extensions = 20300 candidates
-* compiler, now: 25 dirs x 20 module-dirs = 500 candidates
\ No newline at end of file
+* compiler, now: 25 dirs x 20 module-dirs = 500 candidates
+
+4. Limit parallelism of ghc-cabal & ghc-pkg
+
+* https://mail.haskell.org/pipermail/ghc-commits/2013-May/001712.html
+* see ghc.mk, comment about parallel ghc-pkg invokations 
\ No newline at end of file

src/Base.hs

 module Base (
-    shakeFilesPath, configPath, bootPackageConstraints,
+    shakeFilesPath, configPath,
+    bootPackageConstraints, packageDependencies,
     module Development.Shake,
     module Development.Shake.Util,
     module Development.Shake.Config,
@@ -21,3 +22,6 @@ configPath = "shake/cfg/"
 
 bootPackageConstraints :: FilePath
 bootPackageConstraints = shakeFilesPath ++ "boot-package-constraints"
+
+packageDependencies :: FilePath
+packageDependencies = shakeFilesPath ++ "package-dependencies"

src/Main.hs

@@ -7,3 +7,4 @@ main = shakeArgs shakeOptions{shakeFiles = shakeFilesPath} $ do
     packageRules    -- see module Rules
     configRules     -- see module Rules.Config
     generateTargets -- see module Rules
+

src/Oracles/Base.hs

@@ -38,7 +38,3 @@ configOracle = do
         liftIO $ readConfigFile configFile
     addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
     return ()
-
--- Make oracle's output more distinguishable
-putOracle :: String -> Action ()
-putOracle = putColoured Blue

src/Oracles/DependencyList.hs

@@ -7,7 +7,6 @@ module Oracles.DependencyList (
 
 import Base
 import Util
-import Oracles.Base
 import Data.List
 import Data.Maybe
 import Data.Function

src/Oracles/PackageData.hs

@@ -7,7 +7,6 @@ module Oracles.PackageData (
 
 import Base
 import Util
-import Oracles.Base
 import Data.List
 import Data.Maybe
 import Control.Applicative

src/Oracles/PackageDeps.hs

+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+
+module Oracles.PackageDeps (
+    packageDeps,
+    packageDepsOracle
+    ) where
+
+import Base
+import Oracles.Base
+import Data.Maybe
+import qualified Data.HashMap.Strict as Map
+import Control.Applicative
+
+newtype PackageDepsKey = PackageDepsKey String
+    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+
+-- packageDeps depFile objFile is an action that looks up dependencies of an
+-- object file (objFile) in a generated dependecy file (depFile).
+packageDeps :: String -> Action [String]
+packageDeps pkg = do
+    res <- askOracle $ PackageDepsKey pkg
+    return . fromMaybe [] $ res
+
+-- Oracle for 'path/dist/*.deps' files
+packageDepsOracle :: Rules ()
+packageDepsOracle = do
+    deps <- newCache $ \_ -> do
+        putOracle $ "Reading package dependencies..."
+        contents <- readFileLines packageDependencies
+        return . Map.fromList
+               $ [ (head ps, tail ps) | line <- contents, let ps = words line ]
+    addOracle $ \(PackageDepsKey pkg) -> Map.lookup pkg <$> deps ()
+    return ()

src/Oracles/WindowsRoot.hs

@@ -6,7 +6,6 @@ module Oracles.WindowsRoot (
 
 import Base
 import Util
-import Oracles.Base
 import Data.List
 
 newtype WindowsRoot = WindowsRoot ()

src/Rules.hs

@@ -10,6 +10,7 @@ import Rules.Cabal
 import Rules.Config
 import Rules.Package
 import Rules.Oracles
+import Rules.Resources
 import Settings.Packages
 import Settings.TargetDirectory
 
@@ -26,7 +27,8 @@ generateTargets = action $ do
 
 -- TODO: add Stage2 (compiler only?)
 packageRules :: Rules ()
-packageRules =
+packageRules = do
+    resources <- resourceRules
     forM_ [Stage0, Stage1] $ \stage -> do
         forM_ knownPackages $ \pkg -> do
-            buildPackage (stagePackageTarget stage pkg)
+            buildPackage resources (stagePackageTarget stage pkg)

src/Rules/Actions.hs

 module Rules.Actions (
-    build, buildWithResources, run, verboseRun
+    build, buildWithResources
     ) where
 
 import Base
@@ -16,33 +16,25 @@ import Oracles.ArgsHash
 -- built (that is, track changes in the build system).
 buildWithResources :: [(Resource, Int)] -> FullTarget -> Action ()
 buildWithResources rs target = do
-    need $ Target.dependencies target
+    let builder = Target.builder target
+        deps    = Target.dependencies target
+    needBuilder builder
+    need deps
+    path    <- builderPath builder
     argList <- interpret target args
     -- The line below forces the rule to be rerun if the args hash has changed
     argsHash <- askArgsHash target
-    run rs (Target.builder target) argList
+    withResources rs $ do
+        putBuild $ "/--------\n" ++ "| Running "
+                 ++ show builder ++ " with arguments:"
+        mapM_ (putBuild . ("|   " ++)) $ interestingInfo builder argList
+        putBuild $ "\\--------"
+        quietly $ cmd [path] argList
 
 -- Most targets are built without explicitly acquiring resources
 build :: FullTarget -> Action ()
 build = buildWithResources []
 
--- Run the builder with a given collection of arguments
-verboseRun :: [(Resource, Int)] -> Builder -> [String] -> Action ()
-verboseRun rs builder args = do
-    needBuilder builder
-    path <- builderPath builder
-    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 :: [(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 rs builder args
-
 interestingInfo :: Builder -> [String] -> [String]
 interestingInfo builder ss = case builder of
     Ar       -> prefixAndSuffix 2 1 ss

src/Rules/Cabal.hs

@@ -3,27 +3,45 @@ module Rules.Cabal (cabalRules) where
 import Base
 import Util
 import Stage
-import Package
-import Expression
+import Package hiding (pkgName, library)
+import Expression hiding (package)
 import Settings.Packages
 import Data.List
 import Data.Version
-import qualified Distribution.Package                  as D
-import qualified Distribution.PackageDescription       as D
-import qualified Distribution.Verbosity                as D
-import qualified Distribution.PackageDescription.Parse as D
+import Distribution.Package
+import Distribution.Verbosity
+import Distribution.PackageDescription
+import Distribution.PackageDescription.Parse
 
 cabalRules :: Rules ()
-cabalRules =
+cabalRules = do
     -- Cache boot package constraints (to be used in cabalArgs)
     bootPackageConstraints %> \file -> do
         pkgs <- interpret (stageTarget Stage0) packages
         constraints <- forM (sort pkgs) $ \pkg -> do
             let cabal = pkgPath pkg -/- pkgCabal pkg
             need [cabal]
-            descr <- liftIO $ D.readPackageDescription D.silent cabal
-            let identifier         = D.package . D.packageDescription $ descr
-                version            = showVersion . D.pkgVersion $ identifier
-                D.PackageName name = D.pkgName $ identifier
+            description <- liftIO $ readPackageDescription silent cabal
+            let identifier       = package . packageDescription $ description
+                version          = showVersion . pkgVersion $ identifier
+                PackageName name = pkgName identifier
             return $ name ++ " == " ++ version
         writeFileChanged file . unlines $ constraints
+
+    -- Cache package dependencies
+    packageDependencies %> \file -> do
+        pkgs <- interpret (stageTarget Stage1) packages
+        pkgDeps <- forM (sort pkgs) $ \pkg -> do
+            let cabal = pkgPath pkg -/- pkgCabal pkg
+            need [cabal]
+            description <- liftIO $ readPackageDescription silent cabal
+            let deps     = collectDeps . condLibrary $ description
+                depNames = [ name | Dependency (PackageName name) _ <- deps ]
+            return . unwords $ (dropExtension $ pkgCabal pkg) : sort depNames
+        writeFileChanged file $ unlines pkgDeps
+
+collectDeps :: Maybe (CondTree v [Dependency] a) -> [Dependency]
+collectDeps Nothing = []
+collectDeps (Just (CondNode _ deps ifs)) = deps ++ concatMap f ifs
+  where
+    f (_, t, mt) = collectDeps (Just t) ++ collectDeps mt

src/Rules/Data.hs

@@ -7,24 +7,25 @@ import Builder
 import Switches
 import Expression
 import qualified Target
+import Oracles.PackageDeps
+import Settings.Packages
 import Settings.TargetDirectory
 import Rules.Actions
+import Rules.Resources
+import Data.List
+import Data.Maybe
 import Control.Applicative
 import Control.Monad.Extra
 
--- TODO: Add ordering between packages? (see ghc.mk)
 -- Build package-data.mk by using GhcCabal to process pkgCabal file
-buildPackageData :: StagePackageTarget -> Rules ()
-buildPackageData target = do
+buildPackageData :: Resources -> StagePackageTarget -> Rules ()
+buildPackageData (Resources ghcCabal ghcPkg) target = do
     let stage     = Target.stage target
         pkg       = Target.package target
         path      = targetPath stage pkg
         cabal     = pkgPath pkg -/- pkgCabal pkg
         configure = pkgPath pkg -/- "configure"
 
-    -- 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"
@@ -37,13 +38,27 @@ buildPackageData target = 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]
-            buildWithResources [(ghcPkg, 1)] $ -- GhcCabal calls ghc-pkg too
+
+            -- We configure packages in the order of their dependencies
+            deps <- packageDeps . dropExtension . pkgCabal $ pkg
+            pkgs <- interpret target packages
+            let depPkgs = concatMap (maybeToList . findPackage pkgs) deps
+            need $ map (\p -> targetPath stage p -/- "package-data.mk") depPkgs
+
+            buildWithResources [(ghcCabal, 1)] $
                 fullTarget target [cabal] GhcCabal files
+
+            -- TODO: find out of ghc-cabal can be concurrent with ghc-pkg
             whenM (interpretExpr target registerPackage) .
                 buildWithResources [(ghcPkg, 1)] $
                 fullTarget target [cabal] (GhcPkg stage) files
+
             postProcessPackageData $ path -/- "package-data.mk"
 
+-- Given a package name findPackage attempts to find it a given package list
+findPackage :: [Package] -> String -> Maybe Package
+findPackage pkgs name = find (\pkg -> dropExtension (pkgCabal pkg) == name) pkgs
+
 -- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
 -- 1) Drop lines containing '$'
 -- For example, get rid of

src/Rules/Dependencies.hs

@@ -10,9 +10,10 @@ import Oracles.PackageData
 import Settings.Util
 import Settings.TargetDirectory
 import Rules.Actions
+import Rules.Resources
 
-buildPackageDependencies :: StagePackageTarget -> Rules ()
-buildPackageDependencies target =
+buildPackageDependencies :: Resources -> StagePackageTarget -> Rules ()
+buildPackageDependencies _ target =
     let stage     = Target.stage target
         pkg       = Target.package target
         path      = targetPath stage pkg

src/Rules/Oracles.hs

@@ -7,12 +7,14 @@ import Oracles.Base
 import Oracles.ArgsHash
 import Oracles.PackageData
 import Oracles.WindowsRoot
+import Oracles.PackageDeps
 import Oracles.DependencyList
 
 oracleRules :: Rules ()
 oracleRules = do
     configOracle         -- see Oracles.Base
     packageDataOracle    -- see Oracles.PackageData
+    packageDepsOracle    -- see Oracles.PackageDeps
     dependencyListOracle -- see Oracles.DependencyList
     argsHashOracle       -- see Oracles.ArgsHash
     windowsRootOracle    -- see Oracles.WindowsRoot

src/Rules/Package.hs

@@ -3,7 +3,8 @@ module Rules.Package (buildPackage) where
 import Base
 import Expression
 import Rules.Data
+import Rules.Resources
 import Rules.Dependencies
 
-buildPackage :: StagePackageTarget -> Rules ()
+buildPackage :: Resources -> StagePackageTarget -> Rules ()
 buildPackage = buildPackageData <> buildPackageDependencies

src/Rules/Resources.hs

+module Rules.Resources (
+    resourceRules, Resources(..)
+    ) where
+
+import Base
+
+data Resources = Resources
+    {
+        ghcCabal :: Resource,
+        ghcPkg   :: Resource
+    }
+
+-- Unfortunately parallel invokations of ghc-cabal or ghc-pkg do not work:
+-- * https://mail.haskell.org/pipermail/ghc-commits/2013-May/001712.html
+-- * ghc.mk: see comment about parallel ghc-pkg invokations
+resourceRules :: Rules Resources
+resourceRules = do
+    ghcCabal <- newResource "ghc-cabal" 1
+    ghcPkg   <- newResource "ghc-pkg"   1
+    return $ Resources ghcCabal ghcPkg

src/Util.hs

@@ -4,7 +4,7 @@ module Util (
     replaceIf, replaceEq, replaceSeparators,
     unifyPath, (-/-),
     chunksOfSize,
-    putColoured, redError, redError_,
+    putColoured, putOracle, putBuild, redError, redError_,
     bimap, minusOrd, intersectOrd
     ) where
 
@@ -56,6 +56,15 @@ putColoured colour msg = do
     liftIO $ setSGR []
     liftIO $ hFlush stdout
 
+-- Make oracle output more distinguishable
+putOracle :: String -> Action ()
+putOracle = putColoured Blue
+
+-- Make build output more distinguishable
+putBuild :: String -> Action ()
+putBuild = putColoured White
+
+
 -- A more colourful version of error
 redError :: String -> Action a
 redError msg = do