Commit 49c3bb1f authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Configure packages in dependency order, refactor resources.

parent 8e9fe8d6
......@@ -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
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"
......@@ -7,3 +7,4 @@ main = shakeArgs shakeOptions{shakeFiles = shakeFilesPath} $ do
packageRules -- see module Rules
configRules -- see module Rules.Config
generateTargets -- see module Rules
......@@ -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
......@@ -7,7 +7,6 @@ module Oracles.DependencyList (
import Base
import Util
import Oracles.Base
import Data.List
import Data.Maybe
import Data.Function
......
......@@ -7,7 +7,6 @@ module Oracles.PackageData (
import Base
import Util
import Oracles.Base
import Data.List
import Data.Maybe
import Control.Applicative
......
{-# 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 ()
......@@ -6,7 +6,6 @@ module Oracles.WindowsRoot (
import Base
import Util
import Oracles.Base
import Data.List
newtype WindowsRoot = WindowsRoot ()
......
......@@ -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)
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
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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
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
......@@ -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
......
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