Fix performance bug: do not call ghc-cabal to determine package targets
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Sun, 20 Aug 2017 00:12:39 +0000 (01:12 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Sun, 20 Aug 2017 00:12:39 +0000 (01:12 +0100)
See #393

src/Context.hs
src/Hadrian/Haskell/Cabal.hs
src/Hadrian/Haskell/Cabal/Parse.hs
src/Oracles/PackageData.hs
src/Rules.hs
src/Rules/Install.hs
src/Settings/Builders/Ghc.hs
src/Utilities.hs

index 6641943..b4258a6 100644 (file)
@@ -13,9 +13,9 @@ module Context (
 
 import GHC.Generics
 import Hadrian.Expression
+import Hadrian.Haskell.Cabal
 
 import Base
-import Oracles.PackageData
 import Oracles.Setting
 
 -- | Build context for a currently built 'Target'. We generate potentially
@@ -68,10 +68,10 @@ contextDir :: Context -> FilePath
 contextDir Context {..} = stageString stage -/- pkgPath package
 
 pkgFile :: Context -> String -> String -> Action FilePath
-pkgFile context prefix suffix = do
-    path <- buildPath context
-    componentId <- pkgData $ ComponentId path
-    return $ path -/- prefix ++ componentId ++ suffix
+pkgFile context@Context {..} prefix suffix = do
+    path  <- buildPath context
+    pkgId <- pkgIdentifier package
+    return $ path -/- prefix ++ pkgId ++ suffix
 
 -- | Path to inplace package configuration file of a given 'Context'.
 pkgInplaceConfig :: Context -> Action FilePath
@@ -120,13 +120,12 @@ pkgGhciLibraryFile context = pkgFile context "HS" ".o"
 
 -- | Path to the configuration file of a given 'Context'.
 pkgConfFile :: Context -> Action FilePath
-pkgConfFile context@Context {..} = do
-    root        <- buildRoot
-    path        <- buildPath context
-    componentId <- pkgData $ ComponentId path
+pkgConfFile Context {..} = do
+    root  <- buildRoot
+    pkgId <- pkgIdentifier package
     let dbDir | stage == Stage0 = root -/- stage0PackageDbDir
               | otherwise       = inplacePackageDbPath
-    return $ dbDir -/- componentId <.> "conf"
+    return $ dbDir -/- pkgId <.> "conf"
 
 -- | Given a 'Context' and a 'FilePath' to a source file, compute the 'FilePath'
 -- to its object file. For example:
index 6da1e51..02fcd82 100644 (file)
@@ -9,7 +9,9 @@
 -- Basic functionality for extracting Haskell package metadata stored in
 -- @.cabal@ files.
 -----------------------------------------------------------------------------
-module Hadrian.Haskell.Cabal (pkgNameVersion, pkgDependencies) where
+module Hadrian.Haskell.Cabal (
+    pkgNameVersion, pkgIdentifier, pkgDependencies
+    ) where
 
 import Development.Shake
 
@@ -24,6 +26,20 @@ pkgNameVersion pkg = do
     cabal <- readCabalFile (pkgCabalFile pkg)
     return (name cabal, version cabal)
 
+-- | Read the @.cabal@ file of a given package and return the package identifier.
+-- If the @.cabal@ file does not exist return the package name. If the @.cabal@
+-- file exists it is tracked.
+pkgIdentifier :: Package -> Action String
+pkgIdentifier pkg = do
+    cabalExists <- doesFileExist (pkgCabalFile pkg)
+    if cabalExists
+    then do
+        cabal <- readCabalFile (pkgCabalFile pkg)
+        return $ if (null $ version cabal)
+            then name cabal
+            else name cabal ++ "-" ++ version cabal
+    else return (pkgName pkg)
+
 -- | Read the @.cabal@ file of a given package and return the sorted list of its
 -- dependencies. The current version does not take care of Cabal conditionals
 -- and therefore returns a crude overapproximation of actual dependencies. The
index bc234d4..609e494 100644 (file)
@@ -22,11 +22,12 @@ import qualified Distribution.Verbosity                as C
 
 import Hadrian.Haskell.Package
 
+-- TODO: Use fine-grain tracking instead of tracking the whole @.cabal@ file.
 -- | Haskell package metadata extracted from a @.cabal@ file.
 data Cabal = Cabal
-    { name         :: PackageName
+    { dependencies :: [PackageName]
+    , name         :: PackageName
     , version      :: String
-    , dependencies :: [PackageName]
     } deriving (Eq, Read, Show, Typeable)
 
 instance Binary Cabal where
@@ -51,7 +52,7 @@ parseCabal file = do
         allDeps = concat (libDeps : exeDeps)
         sorted  = sort [ C.unPackageName p | C.Dependency p _ <- allDeps ]
         deps    = nubOrd sorted \\ [name]
-    return $ Cabal name version deps
+    return $ Cabal deps name version
 
 collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency]
 collectDeps Nothing = []
index 3621b0e..991caf1 100644 (file)
@@ -7,7 +7,6 @@ import Hadrian.Oracles.TextFile
 import Base
 
 data PackageData = BuildGhciLib FilePath
-                 | ComponentId  FilePath
                  | Synopsis     FilePath
                  | Version      FilePath
 
@@ -40,7 +39,6 @@ askPackageData path = lookupValueOrEmpty (path -/- "package-data.mk")
 pkgData :: PackageData -> Action String
 pkgData packageData = case packageData of
     BuildGhciLib path -> askPackageData path "BUILD_GHCI_LIB"
-    ComponentId  path -> askPackageData path "COMPONENT_ID"
     Synopsis     path -> askPackageData path "SYNOPSIS"
     Version      path -> askPackageData path "VERSION"
 
index 85c116b..61edaf2 100644 (file)
@@ -37,17 +37,26 @@ topLevelTargets = action $ do
     need =<< if stage1Only
              then do
                  libs <- concatForM [Stage0, Stage1] $ \stage ->
-                     concatForM libraryPackages $ packageTargets stage
-                 prgs <- concatForM programsStage1Only $ packageTargets Stage0
+                     concatForM libraryPackages $ packageTargets False stage
+                 prgs <- concatForM programsStage1Only $ packageTargets False Stage0
                  return $ libs ++ prgs ++ inplaceLibCopyTargets
              else do
                  targets <- concatForM allStages $ \stage ->
-                                concatForM (knownPackages \\ [rts, libffi]) $ packageTargets stage
+                     concatForM (knownPackages \\ [rts, libffi]) $
+                        packageTargets False stage
                  return $ targets ++ inplaceLibCopyTargets
 
+
+-- TODO: Get rid of the @includeGhciLib@ hack.
 -- | Return the list of targets associated with a given 'Stage' and 'Package'.
-packageTargets :: Stage -> Package -> Action [FilePath]
-packageTargets stage pkg = do
+-- By setting the Boolean parameter to False it is possible to exclude the GHCi
+-- library from the targets, and avoid running @ghc-cabal@ to determine wether
+-- GHCi library needs to be built for this package. We typically want to set
+-- this parameter to True, however it is important to set it to False when
+-- computing 'topLevelTargets', as otherwise the whole build gets sequentialised
+-- because we need to run @ghc-cabal@ in the order respecting package dependencies.
+packageTargets :: Bool -> Stage -> Package -> Action [FilePath]
+packageTargets includeGhciLib stage pkg = do
     let context = vanillaContext stage pkg
     activePackages <- interpretInContext context getPackages
     if pkg `notElem` activePackages
@@ -57,7 +66,7 @@ packageTargets stage pkg = do
             ways    <- interpretInContext context getLibraryWays
             libs    <- mapM (pkgLibraryFile . Context stage pkg) ways
             docs    <- interpretInContext context =<< buildHaddock <$> flavour
-            more    <- libraryTargets context
+            more    <- libraryTargets includeGhciLib context
             setup   <- pkgSetupConfigFile context
             haddock <- pkgHaddockFile     context
             return $ [ setup   | nonCabalContext context ]
index 2400933..24d7703 100644 (file)
@@ -189,7 +189,7 @@ installPackages = do
                 installDistDir <- buildPath context
                 let absInstallDistDir = top -/- installDistDir
 
-                need =<< packageTargets stage pkg
+                need =<< packageTargets True stage pkg
                 docDir <- installDocDir
                 ghclibDir <- installGhcLibDir
 
index 8b8bc92..8c2efb1 100644 (file)
@@ -2,6 +2,8 @@ module Settings.Builders.Ghc (
     ghcBuilderArgs, ghcMBuilderArgs, haddockGhcArgs, ghcCbuilderArgs
     ) where
 
+import Hadrian.Haskell.Cabal
+
 import Flavour
 import Rules.Gmp
 import Settings.Builders.Common
@@ -116,7 +118,8 @@ wayGhcArgs = do
 -- FIXME: Get rid of to-be-deprecated -this-package-key.
 packageGhcArgs :: Args
 packageGhcArgs = do
-    compId  <- getPkgData ComponentId
+    pkg     <- getPackage
+    pkgId   <- expr $ pkgIdentifier pkg
     thisArg <- do
         not0 <- notStage0
         unit <- expr $ flag SupportsThisUnitId
@@ -124,7 +127,7 @@ packageGhcArgs = do
     mconcat [ arg "-hide-all-packages"
             , arg "-no-user-package-db"
             , bootPackageDatabaseArgs
-            , libraryPackage ? arg (thisArg ++ compId)
+            , libraryPackage ? arg (thisArg ++ pkgId)
             , map ("-package-id " ++) <$> getPkgDataList DepIds ]
 
 includeGhcArgs :: Args
index 56d671c..ab8dedb 100644 (file)
@@ -203,21 +203,24 @@ stage1Dependencies :: Package -> Action [Package]
 stage1Dependencies =
     fmap (map Context.package) . contextDependencies . vanillaContext Stage1
 
--- | Given a library 'Package' this action computes all of its targets.
-libraryTargets :: Context -> Action [FilePath]
-libraryTargets context = do
+-- | Given a library 'Package' this action computes all of its targets. See
+-- 'packageTargets' for the explanation of the @includeGhciLib@ parameter.
+libraryTargets :: Bool -> Context -> Action [FilePath]
+libraryTargets includeGhciLib context = do
     confFile <- pkgConfFile        context
     libFile  <- pkgLibraryFile     context
     lib0File <- pkgLibraryFile0    context
     lib0     <- buildDll0          context
     ghciLib  <- pkgGhciLibraryFile context
-    ghciFlag <- interpretInContext context $ getPkgData BuildGhciLib
+    ghciFlag <- if includeGhciLib
+                then interpretInContext context $ getPkgData BuildGhciLib
+                else return "NO"
     let ghci = ghciFlag == "YES" && (stage context == Stage1 || stage1Only)
     return $ [ confFile, libFile ] ++ [ lib0File | lib0 ] ++ [ ghciLib | ghci ]
 
 -- | Coarse-grain 'need': make sure all given libraries are fully built.
 needLibrary :: [Context] -> Action ()
-needLibrary cs = need =<< concatMapM libraryTargets cs
+needLibrary cs = need =<< concatMapM (libraryTargets True) cs
 
 -- HACK (izgzhen), see https://github.com/snowleopard/hadrian/issues/344.
 -- | Topological sort of packages according to their dependencies.