Hadrian: Fix untracked dependencies
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 14 Feb 2019 14:29:50 +0000 (14:29 +0000)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Wed, 20 Feb 2019 14:59:16 +0000 (09:59 -0500)
This is a preparation for #16295: https://ghc.haskell.org/trac/ghc/ticket/16295

This commit mostly focuses on getting rid of untracked dependencies,
which prevent Shake's new `--shared` feature from appropriately caching
build rules.

There are three different solutions to untracked dependencies:

* Track them! This is the obvious and the best approach, but in some
  situations we cannot use it, for example, because a build rule creates
  files whose names are not known statically and hence cannot be
  specified as the rule's outputs.

* Use Shake's `produces` to record outputs dynamically, within the rule.

* Use Shake's `historyDisable` to disable caching for a particular build
  rule. We currently use this approach only for `ghc-pkg` which mutates
  the package database and the file `package.cache`.

These two tickets are fixed as the result:

Ticket #16271: ​https://ghc.haskell.org/trac/ghc/ticket/16271

Ticket #16272: ​https://ghc.haskell.org/trac/ghc/ticket/16272 (this one
is fixed only partially: we correctly record the dependency, but we
still copy files into the RTS build tree).

25 files changed:
hadrian/hadrian.cabal
hadrian/src/Base.hs
hadrian/src/Builder.hs
hadrian/src/Context.hs
hadrian/src/Hadrian/Haskell/Cabal.hs
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
hadrian/src/Hadrian/Haskell/Cabal/Type.hs
hadrian/src/Hadrian/Oracles/Cabal/Rules.hs
hadrian/src/Oracles/ModuleFiles.hs
hadrian/src/Packages.hs
hadrian/src/Rules.hs
hadrian/src/Rules/Compile.hs
hadrian/src/Rules/Configure.hs
hadrian/src/Rules/Dependencies.hs
hadrian/src/Rules/Documentation.hs
hadrian/src/Rules/Generate.hs
hadrian/src/Rules/Gmp.hs
hadrian/src/Rules/Libffi.hs
hadrian/src/Rules/Register.hs
hadrian/src/Settings.hs
hadrian/src/Settings/Builders/Ghc.hs
hadrian/src/Settings/Builders/GhcPkg.hs
hadrian/src/Settings/Builders/Hsc2Hs.hs
hadrian/src/Settings/Default.hs
utils/touchy/touchy.cabal

index 6a4fff1..56c68aa 100644 (file)
@@ -124,7 +124,7 @@ executable hadrian
                        , mtl                  == 2.2.*
                        , parsec               >= 3.1     && < 3.2
                        , QuickCheck           >= 2.6     && < 2.13
-                       , shake                >= 0.16.4
+                       , shake                >= 0.17.5
                        , transformers         >= 0.4     && < 0.6
                        , unordered-containers >= 0.2.1   && < 0.3
     build-tools:         alex  >= 3.1
index 77eec0a..7949fcf 100644 (file)
@@ -24,7 +24,8 @@ module Base (
     -- * Paths
     hadrianPath, configPath, configFile, sourcePath, shakeFilesDir,
     generatedDir, generatedPath, stageBinPath, stageLibPath, templateHscPath,
-    ghcDeps, haddockDeps, relativePackageDbPath, packageDbPath, packageDbStamp,
+    ghcDeps, includesDependencies, haddockDeps, relativePackageDbPath,
+    packageDbPath, packageDbStamp,
     ghcSplitPath
     ) where
 
@@ -106,15 +107,20 @@ stageBinPath stage = buildRoot <&> (-/- stageString stage -/- "bin")
 stageLibPath :: Stage -> Action FilePath
 stageLibPath stage = buildRoot <&> (-/- stageString stage -/- "lib")
 
--- | Files the `ghc` binary depends on
+-- | Files the GHC binary depends on.
 ghcDeps :: Stage -> Action [FilePath]
 ghcDeps stage = mapM (\f -> stageLibPath stage <&> (-/- f))
-      [ "ghc-usage.txt"
-      , "ghci-usage.txt"
-      , "llvm-targets"
-      , "llvm-passes"
-      , "platformConstants"
-      , "settings" ]
+    [ "ghc-usage.txt"
+    , "ghci-usage.txt"
+    , "llvm-targets"
+    , "llvm-passes"
+    , "platformConstants"
+    , "settings" ]
+
+includesDependencies :: Action [FilePath]
+includesDependencies = do
+    path <- generatedPath
+    return $ (path -/-) <$> [ "ghcautoconf.h", "ghcplatform.h", "ghcversion.h" ]
 
 -- | Files the `haddock` binary depends on
 haddockDeps :: Stage -> Action [FilePath]
index d09af99..02edb19 100644 (file)
@@ -75,13 +75,13 @@ instance Hashable ConfigurationInfo
 instance NFData   ConfigurationInfo
 
 -- TODO: Do we really need all these modes? Why do we need 'Dependencies'? We
--- can extract dependencies using the Cabal library.
+-- can extract dependencies using the Cabal library. Note: we used to also have
+-- the @Init@ mode for initialising a new package database but we've deleted it.
 -- | 'GhcPkg' can initialise a package database and register packages in it.
-data GhcPkgMode = Init         -- ^ Initialize a new database.
-                | Update       -- ^ Update a package.
-                | Copy         -- ^ Copy a package from one database to another.
-                | Unregister   -- ^ Unregister a package.
+data GhcPkgMode = Copy         -- ^ Copy a package from one database to another.
                 | Dependencies -- ^ Compute package dependencies.
+                | Unregister   -- ^ Unregister a package.
+                | Update       -- ^ Update a package.
                 deriving (Eq, Generic, Show)
 
 instance Binary   GhcPkgMode
@@ -173,16 +173,18 @@ instance H.Builder Builder where
         Autoreconf dir -> return [dir -/- "configure.ac"]
         Configure  dir -> return [dir -/- "configure"]
 
-        Ghc _ Stage0 -> return []
+        Ghc _ Stage0 -> generatedGhcDependencies Stage0
         Ghc _ stage -> do
             root <- buildRoot
             win <- windowsHost
             touchyPath <- programPath (vanillaContext Stage0 touchy)
             unlitPath  <- builderPath Unlit
             ghcdeps <- ghcDeps stage
+            ghcgens <- generatedGhcDependencies stage
             return $ [ root -/- ghcSplitPath stage -- TODO: Make conditional on --split-objects
                      , unlitPath ]
                   ++ ghcdeps
+                  ++ ghcgens
                   ++ [ touchyPath | win ]
 
         Hsc2Hs stage -> (\p -> [p]) <$> templateHscPath stage
index 7943e6d..f8a07d7 100644 (file)
@@ -8,7 +8,7 @@ module Context (
     -- * Paths
     contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile,
     pkgHaddockFile, pkgLibraryFile, pkgGhciLibraryFile, pkgConfFile, objectPath,
-    contextPath, getContextPath, libDir, libPath, distDir
+    contextPath, getContextPath, libPath, distDir
     ) where
 
 import Base
@@ -43,12 +43,9 @@ getWay = way <$> getContext
 getStagedSettingList :: (Stage -> SettingList) -> Args Context b
 getStagedSettingList f = getSettingList . f =<< getStage
 
-libDir :: Context -> FilePath
-libDir Context {..} = stageString stage -/- "lib"
-
 -- | Path to the directory containg the final artifact in a given 'Context'.
 libPath :: Context -> Action FilePath
-libPath context = buildRoot <&> (-/- libDir context)
+libPath Context {..} = buildRoot <&> (-/- (stageString stage -/- "lib"))
 
 -- | Get the directory name for binary distribution files
 -- @<arch>-<os>-ghc-<version>@.
@@ -70,16 +67,11 @@ pkgFile context@Context {..} prefix suffix = do
 
 -- | Path to inplace package configuration file of a given 'Context'.
 pkgInplaceConfig :: Context -> Action FilePath
-pkgInplaceConfig context = do
-    path <- contextPath context
-    return $ path -/- "inplace-pkg-config"
+pkgInplaceConfig context = contextPath context <&> (-/- "inplace-pkg-config")
 
--- TODO: Add a @Rules FilePath@ alternative.
 -- | Path to the @setup-config@ of a given 'Context'.
 pkgSetupConfigFile :: Context -> Action FilePath
-pkgSetupConfigFile context = do
-    path <- contextPath context
-    return $ path -/- "setup-config"
+pkgSetupConfigFile context = contextPath context <&> (-/- "setup-config")
 
 -- | Path to the haddock file of a given 'Context', e.g.:
 -- @_build/stage1/libraries/array/doc/html/array/array.haddock@.
index 91de7b2..de4dd18 100644 (file)
@@ -11,8 +11,7 @@
 -----------------------------------------------------------------------------
 module Hadrian.Haskell.Cabal (
     pkgVersion, pkgIdentifier, pkgSynopsis, pkgDescription, pkgDependencies,
-    pkgGenericDescription,
-    cabalArchString, cabalOsString,
+    pkgGenericDescription, cabalArchString, cabalOsString,
     ) where
 
 import Development.Shake
index 8df343b..d53aabd 100644 (file)
@@ -10,8 +10,8 @@
 -- Extracting Haskell package metadata stored in Cabal files.
 -----------------------------------------------------------------------------
 module Hadrian.Haskell.Cabal.Parse (
-    ContextData (..), parsePackageData, resolveContextData, parseCabalPkgId,
-    configurePackage, copyPackage, registerPackage
+    parsePackageData, resolveContextData, parseCabalPkgId, configurePackage,
+    buildAutogenFiles, copyPackage, registerPackage
     ) where
 
 import Data.Bifunctor
@@ -107,8 +107,7 @@ biModules pd = go [ comp | comp@(bi,_,_) <-
 -- the package the 'Context' points to.
 configurePackage :: Context -> Action ()
 configurePackage context@Context {..} = do
-    putLoud $ "| Configure package " ++ quote (pkgName package)
-
+    putProgressInfo $ "| Configure package " ++ quote (pkgName package)
     gpd     <- pkgGenericDescription package
     depPkgs <- packageDependencies <$> readPackageData package
 
@@ -145,11 +144,18 @@ configurePackage context@Context {..} = do
     liftIO $ C.defaultMainWithHooksNoReadArgs hooks gpd
         (argList ++ ["--flags=" ++ unwords flagList, v])
 
+    dir <- Context.buildPath context
+    files <- liftIO $ getDirectoryFilesIO "." [ dir -/- "include" <//> "*"
+                                              , dir -/- "*.buildinfo"
+                                              , dir -/- "lib" <//> "*"
+                                              , dir -/- "config.*" ]
+    produces files
+
 -- | Copy the 'Package' of a given 'Context' into the package database
 -- corresponding to the 'Stage' of the 'Context'.
 copyPackage :: Context -> Action ()
 copyPackage context@Context {..} = do
-    putLoud $ "| Copy package " ++ quote (pkgName package)
+    putProgressInfo $ "| Copy package " ++ quote (pkgName package)
     gpd <- pkgGenericDescription package
     ctxPath   <- Context.contextPath context
     pkgDbPath <- packageDbPath stage
@@ -161,7 +167,7 @@ copyPackage context@Context {..} = do
 -- | Register the 'Package' of a given 'Context' into the package database.
 registerPackage :: Context -> Action ()
 registerPackage context@Context {..} = do
-    putLoud $ "| Register package " ++ quote (pkgName package)
+    putProgressInfo $ "| Register package " ++ quote (pkgName package)
     ctxPath <- Context.contextPath context
     gpd <- pkgGenericDescription package
     verbosity <- getVerbosity
@@ -199,19 +205,13 @@ resolveContextData context@Context {..} = do
                          (const True) platform (C.compilerInfo compiler) [] gpd
 
     cPath <- Context.contextPath context
-    need [cPath -/- "setup-config"]
-
     lbi <- liftIO $ C.getPersistBuildConfig cPath
 
-    -- TODO: Move this into its own rule for @build/autogen/cabal_macros.h@, and
-    -- @build/autogen/Path_*.hs@ and 'need' these files here.
-    -- Create the @cabal_macros.h@, ...
     -- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
     -- from the local build info @lbi@.
     pdi <- liftIO $ getHookedBuildInfo [pkgPath package, cPath -/- "build"]
     let pd'  = C.updatePackageDescription pdi pd
         lbi' = lbi { C.localPkgDescr = pd' }
-    liftIO $ C.initialBuildSteps cPath pd' lbi' C.silent
 
     -- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
     -- See: https://github.com/snowleopard/hadrian/issues/548
@@ -272,16 +272,30 @@ resolveContextData context@Context {..} = do
               ++ C.languageToFlags   (C.compiler lbi') (C.defaultLanguage buildInfo)
               ++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions  buildInfo)
               ++ C.programOverrideArgs ghcProg
-          , asmOpts         = C.asmOptions buildInfo
-          , ccOpts          = C.ccOptions  buildInfo
-          , cmmOpts         = C.cmmOptions buildInfo
-          , cppOpts         = C.cppOptions buildInfo
-          , ldOpts          = C.ldOptions  buildInfo
-          , depIncludeDirs  = forDeps Installed.includeDirs
-          , depCcOpts       = forDeps Installed.ccOptions
-          , depLdOpts       = forDeps Installed.ldOptions
-          , buildGhciLib    = C.withGHCiLib lbi'
-          , frameworks      = C.frameworks buildInfo }
+          , asmOpts            = C.asmOptions buildInfo
+          , ccOpts             = C.ccOptions  buildInfo
+          , cmmOpts            = C.cmmOptions buildInfo
+          , cppOpts            = C.cppOptions buildInfo
+          , ldOpts             = C.ldOptions  buildInfo
+          , depIncludeDirs     = forDeps Installed.includeDirs
+          , depCcOpts          = forDeps Installed.ccOptions
+          , depLdOpts          = forDeps Installed.ldOptions
+          , buildGhciLib       = C.withGHCiLib lbi'
+          , frameworks         = C.frameworks buildInfo
+          , packageDescription = pd' }
+
+-- | Build autogenerated files @autogen/cabal_macros.h@ and @autogen/Paths_*.hs@.
+buildAutogenFiles :: Context -> Action ()
+buildAutogenFiles context = do
+    cPath <- Context.contextPath context
+    setupConfig <- pkgSetupConfigFile context
+    need [setupConfig] -- This triggers 'configurePackage'
+    pd <- packageDescription <$> readContextData context
+    -- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
+    -- from the local build info @lbi@.
+    liftIO $ do
+        lbi <- C.getPersistBuildConfig cPath
+        C.initialBuildSteps cPath pd (lbi { C.localPkgDescr = pd }) C.silent
 
 -- | Look for a @.buildinfo@ in all of the specified directories, stopping on
 -- the first one we find.
index b2a7002..2b5d51a 100644 (file)
@@ -38,33 +38,34 @@ data PackageData = PackageData
 -- See 'PackageData' for metadata that can be obtained without resolving package
 -- configuration flags and conditionals.
 data ContextData = ContextData
-    { dependencies    :: [PackageName]
-    , componentId     :: String
-    , mainIs          :: Maybe (String, FilePath)  -- ("Main", filepath)
-    , modules         :: [String]
-    , otherModules    :: [String]
-    , srcDirs         :: [String]
-    , depIds          :: [String]
-    , depNames        :: [String]
-    , includeDirs     :: [String]
-    , includes        :: [String]
-    , installIncludes :: [String]
-    , extraLibs       :: [String]
-    , extraLibDirs    :: [String]
-    , asmSrcs         :: [String]
-    , cSrcs           :: [String]
-    , cmmSrcs         :: [String]
-    , hcOpts          :: [String]
-    , asmOpts         :: [String]
-    , ccOpts          :: [String]
-    , cmmOpts         :: [String]
-    , cppOpts         :: [String]
-    , ldOpts          :: [String]
-    , depIncludeDirs  :: [String]
-    , depCcOpts       :: [String]
-    , depLdOpts       :: [String]
-    , buildGhciLib    :: Bool
-    , frameworks      :: [String]
+    { dependencies       :: [PackageName]
+    , componentId        :: String
+    , mainIs             :: Maybe (String, FilePath)  -- ("Main", filepath)
+    , modules            :: [String]
+    , otherModules       :: [String]
+    , srcDirs            :: [String]
+    , depIds             :: [String]
+    , depNames           :: [String]
+    , includeDirs        :: [String]
+    , includes           :: [String]
+    , installIncludes    :: [String]
+    , extraLibs          :: [String]
+    , extraLibDirs       :: [String]
+    , asmSrcs            :: [String]
+    , cSrcs              :: [String]
+    , cmmSrcs            :: [String]
+    , hcOpts             :: [String]
+    , asmOpts            :: [String]
+    , ccOpts             :: [String]
+    , cmmOpts            :: [String]
+    , cppOpts            :: [String]
+    , ldOpts             :: [String]
+    , depIncludeDirs     :: [String]
+    , depCcOpts          :: [String]
+    , depLdOpts          :: [String]
+    , buildGhciLib       :: Bool
+    , frameworks         :: [String]
+    , packageDescription :: PackageDescription
     } deriving (Eq, Generic, Show, Typeable)
 
 instance Binary   PackageData
@@ -72,5 +73,5 @@ instance Hashable PackageData where hashWithSalt salt = hashWithSalt salt . show
 instance NFData   PackageData
 
 instance Binary   ContextData
-instance Hashable ContextData
+instance Hashable ContextData where hashWithSalt salt = hashWithSalt salt . show
 instance NFData   ContextData
index dcda370..b7f0f93 100644 (file)
@@ -19,7 +19,7 @@ import Distribution.Simple.Program.Db
 import Distribution.Verbosity
 
 import Builder
-import Context.Type
+import Context
 import Hadrian.Haskell.Cabal.Parse
 import Hadrian.Oracles.Cabal.Type
 import Hadrian.Package
@@ -46,6 +46,11 @@ cabalOracle = do
         putLoud $ "| ContextData oracle: resolving data for "
                ++ quote (pkgName package) ++ " (" ++ show stage
                ++ ", " ++ show way ++ ")..."
+        -- Calling 'need' on @setup-config@ triggers 'configurePackage'. Why
+        -- this indirection? Going via @setup-config@ allows us to cache the
+        -- configuration step, i.e. not to repeat it if it's already been done.
+        setupConfig <- pkgSetupConfigFile context
+        need [setupConfig]
         resolveContextData context
 
     void $ addOracleCache $ \(PackageConfigurationKey (pkg, stage)) -> do
index 1e508c0..d2f0299 100644 (file)
@@ -81,7 +81,9 @@ findGenerator Context {..} file = do
 -- | Find all Haskell source files for a given 'Context'.
 hsSources :: Context -> Action [FilePath]
 hsSources context = do
-    let modFile (m, Nothing   ) = generatedFile context m
+    let modFile (m, Nothing)
+            | "Paths_" `isPrefixOf` m = autogenFile context m
+            | otherwise               = generatedFile context m
         modFile (m, Just file )
             | takeExtension file `elem` haskellExtensions = return file
             | otherwise = generatedFile context m
@@ -99,6 +101,10 @@ hsObjects context = do
 generatedFile :: Context -> ModuleName -> Action FilePath
 generatedFile context moduleName = buildPath context <&> (-/- moduleSource moduleName)
 
+-- | Generated module files live in the 'Context' specific build directory.
+autogenFile :: Context -> ModuleName -> Action FilePath
+autogenFile context modName = autogenPath context <&> (-/- moduleSource modName)
+
 -- | Turn a module name (e.g. @Data.Functor@) to a path (e.g. @Data/Functor.hs@).
 moduleSource :: ModuleName -> FilePath
 moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs"
@@ -125,6 +131,7 @@ moduleFilesOracle :: Rules ()
 moduleFilesOracle = void $ do
     void . addOracleCache $ \(ModuleFiles (stage, package)) -> do
         let context = vanillaContext stage package
+        ensureConfigured context
         srcDirs <- interpretInContext context (getContextData PD.srcDirs)
         mainIs  <- interpretInContext context (getContextData PD.mainIs)
         let removeMain = case mainIs of
index 02dc134..8d2aef1 100644 (file)
@@ -12,7 +12,8 @@ module Packages (
 
     -- * Package information
     programName, nonHsMainPackage, autogenPath, programPath, timeoutPath,
-    rtsContext, rtsBuildPath, libffiContext, libffiBuildPath, libffiLibraryName
+    rtsContext, rtsBuildPath, libffiContext, libffiBuildPath, libffiLibraryName,
+    generatedGhcDependencies, ensureConfigured
     ) where
 
 import Hadrian.Package
@@ -145,7 +146,7 @@ programName Context {..} = do
                                         (Profiling, "-prof"),
                                         (Dynamic,   "-dyn")
                                     ]]
-                              _               -> pkgName package
+                              _ -> pkgName package
 
 -- | The 'FilePath' to a program executable in a given 'Context'.
 programPath :: Context -> Action FilePath
@@ -170,8 +171,8 @@ timeoutPath = "testsuite/timeout/install-inplace/bin/timeout" <.> exe
 nonHsMainPackage :: Package -> Bool
 nonHsMainPackage = (`elem` [ghc, hp2ps, iserv, touchy, unlit])
 
--- TODO: Can we extract this information from Cabal files?
--- | Path to the @autogen@ directory generated when configuring a package.
+-- TODO: Combine this with 'programName'.
+-- | Path to the @autogen@ directory generated by 'buildAutogenFiles'.
 autogenPath :: Context -> Action FilePath
 autogenPath context@Context {..}
     | isLibrary package = autogen "build"
@@ -181,6 +182,16 @@ autogenPath context@Context {..}
   where
     autogen dir = contextPath context <&> (-/- dir -/- "autogen")
 
+-- | Make sure a given context has already been fully configured. The
+-- implementation simply calls 'need' on the context's @autogen/cabal_macros.h@
+-- file, which triggers 'configurePackage' and 'buildAutogenFiles'. Why this
+-- indirection? Going via @autogen/cabal_macros.h@ allows us to cache the
+-- configuration steps, i.e. not to repeat them if they have already been done.
+ensureConfigured :: Context -> Action ()
+ensureConfigured context = do
+    autogen <- autogenPath context
+    need [autogen -/- "cabal_macros.h"]
+
 -- | RTS is considered a Stage1 package. This determines RTS build directory.
 rtsContext :: Stage -> Context
 rtsContext stage = vanillaContext stage rts
@@ -189,9 +200,8 @@ rtsContext stage = vanillaContext stage rts
 rtsBuildPath :: Stage -> Action FilePath
 rtsBuildPath stage = buildPath (rtsContext stage)
 
--- | Build directory for libffi
--- This probably doesn't need to be stage dependent but it is for
--- consistency for now.
+-- | Build directory for @libffi@. This probably doesn't need to be stage
+-- dependent but it is for consistency for now.
 libffiContext :: Stage -> Context
 libffiContext stage = vanillaContext stage libffi
 
@@ -208,3 +218,12 @@ libffiLibraryName = do
         (True , False) -> "ffi"
         (False, False) -> "Cffi"
         (_    , True ) -> "Cffi-6"
+
+-- | Generated header files required by GHC in runtime.
+generatedGhcDependencies :: Stage -> Action [FilePath]
+generatedGhcDependencies stage = do
+    let context = vanillaContext stage compiler
+    bh <- buildPath   context <&> (-/- "ghc_boot_platform.h")
+    ch <- contextPath context <&> (-/- "ghc_boot_platform.h")
+    is <- includesDependencies
+    return $ is ++ [bh, ch]
index f634f22..c5be5a7 100644 (file)
@@ -82,8 +82,8 @@ packageTargets includeGhciLib stage pkg = do
             ways  <- interpretInContext context pkgWays
             libs  <- mapM (pkgLibraryFile . Context stage pkg) ways
             more  <- libraryTargets includeGhciLib context
-            setup <- pkgSetupConfigFile context
-            return $ [setup] ++ libs ++ more
+            setupConfig <- pkgSetupConfigFile context
+            return $ [setupConfig] ++ libs ++ more
         else do -- The only target of a program package is the executable.
             prgContext <- programContext stage pkg
             prgPath    <- programPath prgContext
index 74570a1..0a84e67 100644 (file)
@@ -8,7 +8,6 @@ import Context
 import Expression
 import Rules.Generate
 import Settings
-import Settings.Default
 import Target
 import Utilities
 
@@ -19,7 +18,6 @@ import qualified Text.Parsec as Parsec
 compilePackage :: [(Resource, Int)] -> Rules ()
 compilePackage rs = do
     root <- buildRootRules
-
     -- We match all file paths that look like:
     --   <root>/...stuffs.../build/...stuffs.../<something>.<suffix>
     --
@@ -32,13 +30,11 @@ compilePackage rs = do
     -- and parse the information we need (stage, package path, ...) from
     -- the path and figure out the suitable way to produce that object file.
     objectFilesUnder root |%> \path -> do
-      obj <- parsePath (parseBuildObject root) "<object file path parser>" path
-      compileObject rs path obj
-
+        obj <- parsePath (parseBuildObject root) "<object file path parser>" path
+        compileObject rs path obj
   where
     objectFilesUnder r = [ r -/- ("**/build/**/*" ++ pat)
-                         | pat <- extensionPats
-                         ]
+                         | pat <- extensionPats ]
 
     exts = [ "o", "hi", "o-boot", "hi-boot" ]
     patternsFor e = [ "." ++ e, ".*_" ++ e ]
@@ -73,8 +69,7 @@ compilePackage rs = do
 -}
 
 -- | Non Haskell source languages that we compile to get object files.
-data SourceLang = Asm | C | Cmm
-  deriving (Eq, Show)
+data SourceLang = Asm | C | Cmm deriving (Eq, Show)
 
 parseSourceLang :: Parsec.Parsec String () SourceLang
 parseSourceLang = Parsec.choice
@@ -96,16 +91,15 @@ data NonHsObject = NonHsObject SourceLang Basename Way
 
 parseNonHsObject :: Parsec.Parsec String () NonHsObject
 parseNonHsObject = do
-  lang <- parseSourceLang
-  _ <- Parsec.char '/'
-  file <- parseBasename
-  way <- parseWayPrefix vanilla
-  _ <- Parsec.char 'o'
-  return (NonHsObject lang file way)
+    lang <- parseSourceLang
+    _ <- Parsec.char '/'
+    file <- parseBasename
+    way <- parseWayPrefix vanilla
+    _ <- Parsec.char 'o'
+    return (NonHsObject lang file way)
 
 -- | > <o|hi|o-boot|hi-boot>
-data SuffixType = O | Hi | OBoot | HiBoot
-  deriving (Eq, Show)
+data SuffixType = O | Hi | OBoot | HiBoot deriving (Eq, Show)
 
 parseSuffixType :: Parsec.Parsec String () SuffixType
 parseSuffixType = Parsec.choice
@@ -120,31 +114,26 @@ parseSuffixType = Parsec.choice
   ]
 
 -- | > <way prefix>_<o|hi|o-boot|hi-boot>
-data Extension = Extension Way SuffixType
-  deriving (Eq, Show)
+data Extension = Extension Way SuffixType deriving (Eq, Show)
 
 parseExtension :: Parsec.Parsec String () Extension
-parseExtension =
-  Extension <$> parseWayPrefix vanilla <*> parseSuffixType
+parseExtension = Extension <$> parseWayPrefix vanilla <*> parseSuffixType
 
 -- | > <file>.<way prefix>_<o|hi|o-boot|hi-boot>
-data HsObject = HsObject Basename Extension
-  deriving (Eq, Show)
+data HsObject = HsObject Basename Extension deriving (Eq, Show)
 
 parseHsObject :: Parsec.Parsec String () HsObject
 parseHsObject = do
-  file <- parseBasename
-  ext <- parseExtension
-  return (HsObject file ext)
+    file <- parseBasename
+    ext <- parseExtension
+    return (HsObject file ext)
 
-data Object = Hs HsObject | NonHs NonHsObject
-  deriving (Eq, Show)
+data Object = Hs HsObject | NonHs NonHsObject deriving (Eq, Show)
 
 parseObject :: Parsec.Parsec String () Object
 parseObject = Parsec.choice
-  [ NonHs <$> parseNonHsObject
-  , Hs    <$> parseHsObject
-  ]
+    [ NonHs <$> parseNonHsObject
+    , Hs    <$> parseHsObject ]
 
 -- * Toplevel parsers
 
@@ -153,50 +142,38 @@ parseBuildObject root = parseBuildPath root parseObject
 
 -- * Getting contexts from objects
 
-objectContext :: BuildPath Object -> Action Context
-objectContext (BuildPath _ stage pkgpath obj) = do
-  pkg <- getPackageFromPath pkgpath
-  return (Context stage pkg way)
-
-  where way = case obj of
-          NonHs (NonHsObject _lang _file w)      -> w
-          Hs (HsObject _file (Extension w _suf)) -> w
-
-        getPackageFromPath path = do
-          pkgs <- getPackages
-          case filter (\p -> pkgPath p == path) pkgs of
-            (p:_) -> return p
-            _     -> error $ "couldn't find a package with path: " ++ path
-
-        getPackages = do
-          pkgs <- stagePackages stage
-          testPkgs <- testsuitePackages
-          return $ pkgs ++ if stage == Stage1 then testPkgs else []
+objectContext :: BuildPath Object -> Context
+objectContext (BuildPath _ stage pkgPath obj) =
+    Context stage (unsafeFindPackageByPath pkgPath) way
+  where
+    way = case obj of
+        NonHs (NonHsObject _lang _file w)         -> w
+        Hs    (HsObject _file (Extension w _suf)) -> w
 
 -- * Building an object
 
 compileHsObject
-  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> HsObject -> Action ()
+    :: [(Resource, Int)] -> FilePath -> BuildPath Object -> HsObject -> Action ()
 compileHsObject rs objpath b@(BuildPath _root stage _path _o) hsobj =
   case hsobj of
-    HsObject _basename (Extension _way Hi)     ->
-      need [ change "hi" "o" objpath ]
-    HsObject _basename (Extension _way HiBoot) ->
-      need [ change "hi-boot" "o-boot" objpath ]
-    HsObject _basename (Extension _way _suf)   -> do
-      ctx <- objectContext b
-      ctxPath <- contextPath ctx
-      (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
-      need (src:deps)
-      needLibrary =<< contextDependencies ctx
-      buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
-
-  where change oldSuffix newSuffix str
-          | not (oldSuffix `isSuffixOf` str) = error $
-              "compileHsObject.change: " ++ oldSuffix ++
-              " not a suffix of " ++ str
-          | otherwise = take (length str - length oldSuffix) str
-                     ++ newSuffix
+    HsObject _basename (Extension way Hi    ) -> need [objpath -<.> osuf     way]
+    HsObject _basename (Extension way HiBoot) -> need [objpath -<.> obootsuf way]
+    HsObject _basename (Extension way suf) -> do
+        let ctx = objectContext b
+        ctxPath <- contextPath ctx
+        (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
+        need (src:deps)
+        needLibrary =<< contextDependencies ctx
+        buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
+        -- Andrey: It appears that the previous refactoring has broken
+        -- multiple-output build rules. Ideally, we should bring multiple-output
+        -- rules back, see: https://github.com/snowleopard/hadrian/issues/216.
+        -- As a temporary solution, I'm using Shake's new 'produces' feature to
+        -- record that this rule also produces a corresponding interface file.
+        let hi | suf == O     = objpath -<.> hisuf     way
+               | suf == OBoot = objpath -<.> hibootsuf way
+               | otherwise    = error "Internal error: unknown Haskell object extension"
+        produces [hi]
 
 compileNonHsObject
   :: [(Resource, Int)] -> FilePath -> BuildPath Object -> NonHsObject
@@ -214,11 +191,11 @@ compileNonHsObject rs objpath b@(BuildPath _root stage _path _o) nonhsobj =
         toSrcFor Cmm = obj2src "cmm" isGeneratedCmmFile
 
         go builder tosrc = do
-          ctx <- objectContext b
-          src <- tosrc ctx objpath
-          need [src]
-          needDependencies ctx src (objpath <.> "d")
-          buildWithResources rs $ target ctx (builder stage) [src] [objpath]
+            let ctx = objectContext b
+            src <- tosrc ctx objpath
+            need [src]
+            needDependencies ctx src (objpath <.> "d")
+            buildWithResources rs $ target ctx (builder stage) [src] [objpath]
 
 compileObject
   :: [(Resource, Int)] -> FilePath -> BuildPath Object -> Action ()
index 909b3c3..8395472 100644 (file)
@@ -42,6 +42,8 @@ configureRules = do
             when System.isWindows $ do
                 root <- buildRoot
                 copyDirectory "inplace/mingw" (root -/- "mingw")
+                mingwFiles <- liftIO $ getDirectoryFilesIO "." [root -/- "mingw/**"]
+                produces mingwFiles
 
     ["configure", configH <.> "in"] &%> \_ -> do
         skip <- not <$> cmdConfigure
index 8b09a82..9a2a233 100644 (file)
@@ -9,7 +9,7 @@ import Expression
 import Hadrian.BuildPath
 import Oracles.ModuleFiles
 import Rules.Generate
-import Settings.Default
+import Settings
 import Target
 import Utilities
 
@@ -19,17 +19,15 @@ buildPackageDependencies :: [(Resource, Int)] -> Rules ()
 buildPackageDependencies rs = do
     root <- buildRootRules
     root -/- "**/.dependencies.mk" %> \mk -> do
-        depfile <- getDepMkFile root mk
-        context <- depMkFileContext depfile
+        DepMkFile stage pkgpath <- getDepMkFile root mk
+        let context = Context stage (unsafeFindPackageByPath pkgpath) vanilla
         srcs <- hsSources context
-        need srcs
-        orderOnly =<< interpretInContext context generatedDependencies
+        gens <- interpretInContext context generatedDependencies
+        need (srcs ++ gens)
         if null srcs
         then writeFileChanged mk ""
-        else buildWithResources rs $
-            target context
-                   (Ghc FindHsDependencies $ Context.stage context)
-                   srcs [mk]
+        else buildWithResources rs $ target context
+            (Ghc FindHsDependencies $ Context.stage context) srcs [mk]
         removeFile $ mk <.> "bak"
 
     root -/- "**/.dependencies" %> \deps -> do
@@ -43,22 +41,16 @@ buildPackageDependencies rs = do
                               $ parseMakefile mkDeps
 
 
-data DepMkFile = DepMkFile Stage FilePath
-  deriving (Eq, Show)
+data DepMkFile = DepMkFile Stage FilePath deriving (Eq, Show)
 
 parseDepMkFile :: FilePath -> Parsec.Parsec String () DepMkFile
 parseDepMkFile root = do
-  _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
-  stage <- parseStage
-  _ <- Parsec.char '/'
-  pkgPath <- Parsec.manyTill Parsec.anyChar
-    (Parsec.try $ Parsec.string "/.dependencies.mk")
-  return (DepMkFile stage pkgPath)
+    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+    stage <- parseStage
+    _ <- Parsec.char '/'
+    pkgPath <- Parsec.manyTill Parsec.anyChar
+        (Parsec.try $ Parsec.string "/.dependencies.mk")
+    return (DepMkFile stage pkgPath)
 
 getDepMkFile :: FilePath -> FilePath -> Action DepMkFile
 getDepMkFile root = parsePath (parseDepMkFile root) "<dependencies file>"
-
-depMkFileContext :: DepMkFile -> Action Context
-depMkFileContext (DepMkFile stage pkgpath) = do
-  pkg <- getPackageByPath pkgpath
-  return (Context stage pkg vanilla)
index 2d7a4b1..c9de303 100644 (file)
@@ -141,7 +141,7 @@ buildPackageDocumentation = do
 
     -- Per-package haddocks
     root -/- htmlRoot -/- "libraries/*/haddock-prologue.txt" %> \file -> do
-        ctx <- getPkgDocTarget root file >>= pkgDocContext
+        ctx <- pkgDocContext <$> getPkgDocTarget root file
         -- This is how @ghc-cabal@ used to produces "haddock-prologue.txt" files.
         syn  <- pkgSynopsis    (Context.package ctx)
         desc <- pkgDescription (Context.package ctx)
@@ -149,7 +149,7 @@ buildPackageDocumentation = do
         liftIO $ writeFile file prologue
 
     root -/- htmlRoot -/- "libraries/*/*.haddock" %> \file -> do
-        context <- getPkgDocTarget root file >>= pkgDocContext
+        context <- pkgDocContext <$> getPkgDocTarget root file
         need [ takeDirectory file  -/- "haddock-prologue.txt"]
         haddocks <- haddockDependencies context
 
@@ -172,14 +172,11 @@ buildPackageDocumentation = do
 data PkgDocTarget = DotHaddock PackageName | HaddockPrologue PackageName
   deriving (Eq, Show)
 
-pkgDocContext :: PkgDocTarget -> Action Context
-pkgDocContext target = case findPackageByName pkgname of
-  Nothing -> error $ "pkgDocContext: couldn't find package " ++ pkgname
-  Just p  -> return (Context Stage1 p vanilla)
-
-  where pkgname = case target of
-          DotHaddock n      -> n
-          HaddockPrologue n -> n
+pkgDocContext :: PkgDocTarget -> Context
+pkgDocContext target = Context Stage1 (unsafeFindPackageByName name) vanilla
+  where
+    name = case target of DotHaddock n      -> n
+                          HaddockPrologue n -> n
 
 parsePkgDocTarget :: FilePath -> Parsec.Parsec String () PkgDocTarget
 parsePkgDocTarget root = do
index 9db5b19..13544f2 100644 (file)
@@ -1,6 +1,7 @@
 module Rules.Generate (
-    isGeneratedCmmFile, generatePackageCode, generateRules, copyRules,
-    includesDependencies, generatedDependencies, ghcPrimDependencies
+    isGeneratedCmmFile, compilerDependencies, generatePackageCode,
+    generateRules, copyRules, generatedDependencies, generatedGhcDependencies,
+    ghcPrimDependencies
     ) where
 
 import Base
@@ -26,18 +27,9 @@ primopsSource = "compiler/prelude/primops.txt.pp"
 primopsTxt :: Stage -> FilePath
 primopsTxt stage = buildDir (vanillaContext stage compiler) -/- "primops.txt"
 
-platformH :: Stage -> FilePath
-platformH stage = buildDir (vanillaContext stage compiler) -/- "ghc_boot_platform.h"
-
 isGeneratedCmmFile :: FilePath -> Bool
 isGeneratedCmmFile file = takeBaseName file == "AutoApply"
 
-includesDependencies :: [FilePath]
-includesDependencies = fmap (generatedDir -/-)
-    [ "ghcautoconf.h"
-    , "ghcplatform.h"
-    , "ghcversion.h" ]
-
 ghcPrimDependencies :: Expr [FilePath]
 ghcPrimDependencies = do
     stage <- getStage
@@ -59,9 +51,7 @@ compilerDependencies = do
     ghcPath <- expr $ buildPath (vanillaContext stage compiler)
     gmpPath <- expr gmpBuildPath
     rtsPath <- expr (rtsBuildPath stage)
-    mconcat [ return [root -/- platformH stage]
-            , return ((root -/-) <$> includesDependencies)
-            , return ((root -/-) <$> derivedConstantsDependencies)
+    mconcat [ return ((root -/-) <$> derivedConstantsDependencies)
             , notStage0 ? isGmp ? return [gmpPath -/- gmpLibraryH]
             , notStage0 ? return ((rtsPath -/-) <$> libffiDependencies)
             , return $ fmap (ghcPath -/-)
@@ -83,15 +73,16 @@ compilerDependencies = do
 
 generatedDependencies :: Expr [FilePath]
 generatedDependencies = do
-    root    <- getBuildRoot
-    stage   <- getStage
-    rtsPath <- expr (rtsBuildPath stage)
+    root     <- getBuildRoot
+    stage    <- getStage
+    rtsPath  <- expr (rtsBuildPath stage)
+    includes <- expr includesDependencies
     mconcat [ package compiler ? compilerDependencies
             , package ghcPrim  ? ghcPrimDependencies
             , package rts      ? return (fmap (rtsPath -/-) libffiDependencies
-                ++ fmap (root -/-) includesDependencies
+                ++ includes
                 ++ fmap (root -/-) derivedConstantsDependencies)
-            , stage0 ? return (fmap (root -/-) includesDependencies) ]
+            , stage0 ? return includes ]
 
 generate :: FilePath -> Context -> Expr String -> Action ()
 generate file context expr = do
@@ -111,40 +102,38 @@ generatePackageCode context@(Context stage pkg _) = do
         need [src]
         build $ target context builder [src] [file]
         let boot = src -<.> "hs-boot"
-        whenM (doesFileExist boot) . copyFile boot $ file -<.> "hs-boot"
+        whenM (doesFileExist boot) $ do
+            let target = file -<.> "hs-boot"
+            copyFile boot target
+            produces [target]
 
     priority 2.0 $ do
-        when (pkg == compiler) $ do root <//> dir -/- "Config.hs" %> go generateConfigHs
-                                    root <//> dir -/- "*.hs-incl" %> genPrimopCode context
-        when (pkg == ghcPrim) $ do (root <//> dir -/- "GHC/Prim.hs") %> genPrimopCode context
-                                   (root <//> dir -/- "GHC/PrimopWrappers.hs") %> genPrimopCode context
-        when (pkg == ghcPkg) $ do root <//> dir -/- "Version.hs" %> go generateVersionHs
+        when (pkg == compiler) $ do
+            root <//> dir -/- "Config.hs" %> go generateConfigHs
+            root <//> dir -/- "*.hs-incl" %> genPrimopCode context
+        when (pkg == ghcPrim) $ do
+            root <//> dir -/- "GHC/Prim.hs" %> genPrimopCode context
+            root <//> dir -/- "GHC/PrimopWrappers.hs" %> genPrimopCode context
+        when (pkg == ghcPkg) $
+            root <//> dir -/- "Version.hs" %> go generateVersionHs
 
-    -- TODO: needing platformH is ugly and fragile
     when (pkg == compiler) $ do
         root -/- primopsTxt stage %> \file -> do
-            root <- buildRoot
-            need $ [ root -/- platformH stage
-                   , primopsSource]
-                ++ fmap (root -/-) includesDependencies
+            includes <- includesDependencies
+            need $ [primopsSource] ++ includes
             build $ target context HsCpp [primopsSource] [file]
 
-        -- only generate this once! Until we have the include logic fixed.
-        -- See the note on `platformH`
-        when (stage == Stage0) $ do
-            root <//> "compiler/ghc_boot_platform.h" %> go generateGhcBootPlatformH
-        root <//> platformH stage %> go generateGhcBootPlatformH
+        root -/- stageString stage <//> "ghc_boot_platform.h" %>
+            go generateGhcBootPlatformH
 
     when (pkg == rts) $ do
         root <//> dir -/- "cmm/AutoApply.cmm" %> \file ->
             build $ target context GenApply [] [file]
-        -- XXX: this should be fixed properly, e.g. generated here on demand.
+        -- TODO: This should be fixed properly, e.g. generated here on demand.
         (root <//> dir -/- "DerivedConstants.h") <~ (buildRoot <&> (-/- generatedDir))
         (root <//> dir -/- "ghcautoconf.h") <~ (buildRoot <&> (-/- generatedDir))
         (root <//> dir -/- "ghcplatform.h") <~ (buildRoot <&> (-/- generatedDir))
         (root <//> dir -/- "ghcversion.h") <~ (buildRoot <&> (-/- generatedDir))
-    when (pkg == integerGmp) $ do
-        (root <//> dir -/- "ghc-gmp.h") <~ (buildRoot <&> (-/- "include"))
  where
     pattern <~ mdir = pattern %> \file -> do
         dir <- mdir
index 8e0d338..a78170c 100644 (file)
@@ -1,6 +1,4 @@
-module Rules.Gmp (
-    gmpRules, gmpBuildPath, gmpObjects, gmpLibraryH
-    ) where
+module Rules.Gmp (gmpRules, gmpBuildPath, gmpObjects, gmpLibraryH) where
 
 import Base
 import Context
@@ -41,6 +39,10 @@ gmpContext = vanillaContext Stage1 integerGmp
 gmpBuildPath :: Action FilePath
 gmpBuildPath = buildRoot <&> (-/- stageString (stage gmpContext) -/- "gmp")
 
+-- | Like 'gmpBuildPath' but in the 'Rules' monad.
+gmpBuildPathRules :: Rules FilePath
+gmpBuildPathRules = buildRootRules <&> (-/- stageString (stage gmpContext) -/- "gmp")
+
 -- | GMP library header, relative to 'gmpBuildPath'.
 gmpLibraryH :: FilePath
 gmpLibraryH = "include/ghc-gmp.h"
@@ -57,8 +59,8 @@ configureEnvironment = sequence [ builderEnvironment "CC" $ Cc CompileC Stage1
 gmpRules :: Rules ()
 gmpRules = do
     -- Copy appropriate GMP header and object files
-    root <- buildRootRules
-    root <//> gmpLibraryH %> \header -> do
+    gmpPath <- gmpBuildPathRules
+    gmpPath -/- gmpLibraryH %> \header -> do
         windows  <- windowsHost
         configMk <- readFile' =<< (buildPath gmpContext <&> (-/- "config.mk"))
         if not windows && -- TODO: We don't use system GMP on Windows. Fix?
@@ -68,46 +70,39 @@ gmpRules = do
             copyFile (gmpBase -/- "ghc-gmp.h") header
         else do
             putBuild "| No GMP library/framework detected; in tree GMP will be built"
-            gmpPath <- gmpBuildPath
             need [gmpPath -/- gmpLibrary]
             createDirectory (gmpPath -/- gmpObjectsDir)
             top <- topDirectory
             build $ target gmpContext (Ar Unpack Stage1)
                 [top -/- gmpPath -/- gmpLibrary] [gmpPath -/- gmpObjectsDir]
-            copyFile (gmpPath -/- "gmp.h") header
-            copyFile (gmpPath -/- "gmp.h") (gmpPath -/- gmpLibraryInTreeH)
+            objs <- liftIO $ getDirectoryFilesIO "." [gmpPath -/- gmpObjectsDir -/- "*"]
+            produces objs
+            copyFileUntracked (gmpPath -/- "gmp.h") header
 
     -- Build in-tree GMP library, prioritised so that it matches "before"
-    -- the generic .a library rule in Rules.Library, whenever applicable.
-    priority 2.0 $ root <//> gmpLibrary %> \lib -> do
-        gmpPath <- gmpBuildPath
+    -- the generic @.a@ library rule in 'Rules.Library'.
+    priority 2.0 $ gmpPath -/- gmpLibrary %> \lib -> do
         build $ target gmpContext (Make gmpPath) [gmpPath -/- "Makefile"] [lib]
         putSuccess "| Successfully built custom library 'gmp'"
 
-    -- In-tree GMP header is built by the gmpLibraryH rule
-    root <//> gmpLibraryInTreeH %> \_ -> do
-        gmpPath <- gmpBuildPath
-        need [gmpPath -/- gmpLibraryH]
+    gmpPath -/- gmpLibraryInTreeH %> copyFile (gmpPath -/- gmpLibraryH)
+
+    root <- buildRootRules
+    root -/- buildDir gmpContext -/- gmpLibraryH %>
+        copyFile (gmpPath -/- gmpLibraryH)
 
-    -- This causes integerGmp package to be configured, hence creating the files
-    root <//> "gmp/config.mk" %> \_ -> do
-        -- Calling 'need' on @setup-config@ triggers 'configurePackage'.
-        -- TODO: Shall we run 'configurePackage' directly? Why this indirection?
-        setupConfig <- pkgSetupConfigFile gmpContext
-        need [setupConfig]
+    -- This file is created when 'integerGmp' is configured.
+    gmpPath -/- "config.mk" %> \_ -> ensureConfigured gmpContext
 
-    -- TODO: Get rid of hard-coded @gmp@.
     -- Run GMP's configure script
-    root <//> "gmp/Makefile" %> \mk -> do
-        env     <- configureEnvironment
-        gmpPath <- gmpBuildPath
+    gmpPath -/- "Makefile" %> \mk -> do
+        env <- configureEnvironment
         need [mk <.> "in"]
         buildWithCmdOptions env $
             target gmpContext (Configure gmpPath) [mk <.> "in"] [mk]
 
     -- Extract in-tree GMP sources and apply patches
-    root <//> "gmp/Makefile.in" %> \_ -> do
-        gmpPath <- gmpBuildPath
+    fmap (gmpPath -/-) ["Makefile.in", "configure"] &%> \_ -> do
         removeDirectory gmpPath
         -- Note: We use a tarball like gmp-4.2.4-nodoc.tar.bz2, which is
         -- gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents.
index 465065e..1fe6174 100644 (file)
@@ -43,17 +43,16 @@ configureEnvironment stage = do
              , return . AddEnv "LDFLAGS" $ unwords ldFlags ++ " -w" ]
 
 libffiRules :: Rules ()
-libffiRules =
-    forM_ [Stage1 ..] $ \stage -> do
-      root <- buildRootRules
-      fmap ((root -/- stageString stage -/- "rts/build") -/-) libffiDependencies
-          &%> \_ -> do
-            libffiPath <- libffiBuildPath stage
-            need [libffiPath -/- libffiLibrary]
-
-    -- we set a higher priority because this overlaps
-    -- with the static lib rule from Rules.Library.libraryRules.
-      priority 2.0 $ root -/- stageString stage <//> libffiLibrary %> \_ -> do
+libffiRules = forM_ [Stage1 ..] $ \stage -> do
+    root <- buildRootRules
+    let path       = root -/- stageString stage
+        libffiPath = path -/- pkgName libffi -/- "build"
+        libffiOuts = [libffiPath -/- libffiLibrary] ++
+                     fmap ((path -/- "rts/build") -/-) libffiDependencies
+
+    -- We set a higher priority because this rule overlaps with the build rule
+    -- for static libraries 'Rules.Library.libraryRules'.
+    priority 2.0 $ libffiOuts &%> \(out : _) -> do
         useSystemFfi <- flag UseSystemFfi
         rtsPath      <- rtsBuildPath stage
         if useSystemFfi
@@ -64,23 +63,25 @@ libffiRules =
                 copyFile (ffiIncludeDir -/- file) (rtsPath -/- file)
             putSuccess "| Successfully copied system FFI library header files"
         else do
-            libffiPath <- libffiBuildPath stage
             build $ target (libffiContext stage) (Make libffiPath) [] []
 
-            hs <- getDirectoryFiles "" [libffiPath -/- "inst/include/*"]
-            forM_ hs $ \header ->
-                copyFile header (rtsPath -/- takeFileName header)
+            -- Here we produce 'libffiDependencies'
+            hs <- liftIO $ getDirectoryFilesIO "" [libffiPath -/- "inst/include/*"]
+            forM_ hs $ \header -> do
+                let target = rtsPath -/- takeFileName header
+                copyFileUntracked header target
+                produces [target]
 
             ways <- interpretInContext (libffiContext stage)
                                        (getLibraryWays <> getRtsWays)
             forM_ (nubOrd ways) $ \way -> do
                 rtsLib <- rtsLibffiLibrary stage way
-                copyFileUntracked (libffiPath -/- libffiLibrary) rtsLib
+                copyFileUntracked out rtsLib
+                produces [rtsLib]
 
             putSuccess "| Successfully built custom library 'libffi'"
 
-      root -/- stageString stage -/- "libffi/build/Makefile.in" %> \mkIn -> do
-        libffiPath <- libffiBuildPath stage
+    fmap (libffiPath -/-) ["Makefile.in", "configure" ] &%> \[mkIn, _] -> do
         removeDirectory libffiPath
         tarball <- unifyPath . fromSingleton "Exactly one LibFFI tarball is expected"
                <$> getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"]
@@ -93,21 +94,25 @@ libffiRules =
         removeDirectory (root -/- libname)
         -- TODO: Simplify.
         actionFinally (do
-          build $ target (libffiContext stage) (Tar Extract)
-                                                  [tarball]
-                                                  [root -/- stageString stage]
-          moveDirectory (root -/- stageString stage -/- libname) libffiPath)  $
-            removeFiles (root -/- stageString stage) [libname <//> "*"]
+            build $ target (libffiContext stage) (Tar Extract) [tarball] [path]
+            moveDirectory (path -/- libname) libffiPath) $
+            -- And finally:
+            removeFiles (path) [libname <//> "*"]
 
         top <- topDirectory
         fixFile mkIn (fixLibffiMakefile top)
 
-      -- TODO: Get rid of hard-coded @libffi@.
-      root -/- stageString stage -/- "libffi/build/Makefile" %> \mk -> do
+        files <- liftIO $ getDirectoryFilesIO "." [libffiPath <//> "*"]
+        produces files
+
+    fmap (libffiPath -/-) ["Makefile", "config.guess", "config.sub"] &%> \[mk, _, _] -> do
         need [mk <.> "in"]
-        libffiPath <- libffiBuildPath stage
         forM_ ["config.guess", "config.sub"] $ \file -> do
             copyFile file (libffiPath -/- file)
         env <- configureEnvironment stage
         buildWithCmdOptions env $
-          target (libffiContext stage) (Configure libffiPath) [mk <.> "in"] [mk]
+            target (libffiContext stage) (Configure libffiPath) [mk <.> "in"] [mk]
+
+        dir   <- setting BuildPlatform
+        files <- liftIO $ getDirectoryFilesIO "." [libffiPath -/- dir <//> "*"]
+        produces files
index ef56da5..d215938 100644 (file)
@@ -4,9 +4,11 @@ import Base
 import Context
 import Hadrian.BuildPath
 import Hadrian.Expression
+import Hadrian.Haskell.Cabal
+import Oracles.Setting
 import Packages
+import Rules.Gmp
 import Settings
-import Settings.Default
 import Target
 import Utilities
 
@@ -21,27 +23,41 @@ import qualified Text.Parsec                 as Parsec
 
 -- * Configuring
 
--- | Configure a package and build its @setup-config@ file.
+-- | Configure a package and build its @setup-config@ file, as well as files in
+-- the @build/pkgName/build/autogen@ directory.
 configurePackageRules :: Rules ()
 configurePackageRules = do
     root <- buildRootRules
-    root -/- "**/setup-config" %> \path ->
-        parsePath (parseSetupConfig root) "<setup config path parser>" path
-          >>= configurePackage
+    root -/- "**/setup-config" %> \out -> do
+        (stage, path) <- parsePath (parseSetupConfig root) "<setup config path parser>" out
+        let pkg = unsafeFindPackageByPath path
+        Cabal.configurePackage (Context stage pkg vanilla)
+
+    root -/- "**/autogen/cabal_macros.h" %> \out -> do
+        (stage, path) <- parsePath (parseToBuildSubdirectory root) "<cabal macros path parser>" out
+        let pkg = unsafeFindPackageByPath path
+        Cabal.buildAutogenFiles (Context stage pkg vanilla)
+
+    root -/- "**/autogen/Paths_*.hs" %> \out ->
+        need [takeDirectory out -/- "cabal_macros.h"]
 
 parseSetupConfig :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
 parseSetupConfig root = do
-  _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
-  stage <- parseStage
-  _ <- Parsec.char '/'
-  pkgPath <- Parsec.manyTill Parsec.anyChar
-    (Parsec.try $ Parsec.string "/setup-config")
-  return (stage, pkgPath)
-
-configurePackage :: (Stage, FilePath) -> Action ()
-configurePackage (stage, pkgpath) = do
-  pkg <- getPackageByPath pkgpath
-  Cabal.configurePackage (Context stage pkg vanilla)
+    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+    stage <- parseStage
+    _ <- Parsec.char '/'
+    pkgPath <- Parsec.manyTill Parsec.anyChar
+        (Parsec.try $ Parsec.string "/setup-config")
+    return (stage, pkgPath)
+
+parseToBuildSubdirectory :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
+parseToBuildSubdirectory root = do
+    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+    stage <- parseStage
+    _ <- Parsec.char '/'
+    pkgPath <- Parsec.manyTill Parsec.anyChar
+        (Parsec.try $ Parsec.string "/build/")
+    return (stage, pkgPath)
 
 -- * Registering
 
@@ -57,6 +73,7 @@ registerPackageRules rs stage = do
 
     -- Register a package.
     root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
+        historyDisable
         let libpath = takeDirectory (takeDirectory conf)
             settings = libpath -/- "settings"
             platformConstants = libpath -/- "platformConstants"
@@ -64,7 +81,7 @@ registerPackageRules rs stage = do
         need [settings, platformConstants]
 
         pkgName <- getPackageNameFromConfFile conf
-        pkg <- getPackageByName pkgName
+        let pkg = unsafeFindPackageByName pkgName
         isBoot <- (pkg `notElem`) <$> stagePackages Stage0
 
         let ctx = Context stage pkg vanilla
@@ -73,12 +90,9 @@ registerPackageRules rs stage = do
             _               -> buildConf rs ctx conf
 
 buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
-buildConf _ context@Context {..} _conf = do
+buildConf _ context@Context {..} conf = do
     depPkgIds <- cabalDependencies context
-
-    -- Calling 'need' on @setupConfig@, triggers the package configuration.
-    setupConfig <- pkgSetupConfigFile context
-    need [setupConfig]
+    ensureConfigured context
     need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
 
     ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
@@ -97,12 +111,28 @@ buildConf _ context@Context {..} _conf = do
              , path -/- "ghcversion.h"
              , path -/- "ffi.h" ]
 
-    when (package == integerGmp) $ need [path -/- "ghc-gmp.h"]
+    when (package == integerGmp) $ need [path -/- gmpLibraryH]
 
     -- Copy and register the package.
     Cabal.copyPackage context
     Cabal.registerPackage context
 
+    -- The above two steps produce an entry in the package database, with copies
+    -- of many of the files we have build, e.g. Haskell interface files. We need
+    -- to record this side effect so that Shake can cache these files too.
+    -- See why we need 'fixWindows': https://ghc.haskell.org/trac/ghc/ticket/16073
+    let fixWindows path = do
+            win <- windowsHost
+            version  <- setting GhcVersion
+            hostOs   <- cabalOsString <$> setting BuildOs
+            hostArch <- cabalArchString <$> setting BuildArch
+            let dir = hostArch ++ "-" ++ hostOs ++ "-ghc-" ++ version
+            return $ if win then path -/- "../.." -/- dir else path
+    pkgDbPath <- fixWindows =<< packageDbPath stage
+    let dir = pkgDbPath -/- takeBaseName conf
+    files <- liftIO $ getDirectoryFilesIO "." [dir -/- "**"]
+    produces files
+
 copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
 copyConf rs context@Context {..} conf = do
     depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
@@ -126,18 +156,14 @@ copyConf rs context@Context {..} conf = do
 
 getPackageNameFromConfFile :: FilePath -> Action String
 getPackageNameFromConfFile conf
-  | takeBaseName conf == "rts" = return "rts"
-  | otherwise = case parseCabalName (takeBaseName conf) of
-      Left err -> error $ "getPackageNameFromConfFile: couldn't parse " ++ takeBaseName conf ++ ": " ++ err
-      Right (name, _) -> return name
+    | takeBaseName conf == "rts" = return "rts"
+    | otherwise = case parseCabalName (takeBaseName conf) of
+        Left err -> error $ "getPackageNameFromConfFile: Couldn't parse " ++
+                            takeBaseName conf ++ ": " ++ err
+        Right (name, _) -> return name
 
 parseCabalName :: String -> Either String (String, Version)
 parseCabalName = fmap f . Cabal.eitherParsec
   where
     f :: Cabal.PackageId -> (String, Version)
     f pkg_id = (Cabal.unPackageName $ Cabal.pkgName pkg_id, Cabal.pkgVersion pkg_id)
-
-getPackageByName :: String -> Action Package
-getPackageByName n = case findPackageByName n of
-  Nothing -> error $ "getPackageByName: couldn't find " ++ n
-  Just p  -> return p
index 519d1fc..fdbef1c 100755 (executable)
@@ -1,7 +1,7 @@
 module Settings (
     getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
-    findPackageByName, isLibrary, stagePackages, programContext,
-    getIntegerPackage
+    findPackageByName, unsafeFindPackageByName, unsafeFindPackageByPath,
+    isLibrary, stagePackages, programContext, getIntegerPackage
     ) where
 
 import CommandLine
@@ -66,3 +66,13 @@ knownPackages = sort $ ghcPackages ++ userPackages
 -- Note: this is slow but we keep it simple as there are just ~50 packages
 findPackageByName :: PackageName -> Maybe Package
 findPackageByName name = find (\pkg -> pkgName pkg == name) knownPackages
+
+unsafeFindPackageByName :: PackageName -> Package
+unsafeFindPackageByName name = fromMaybe (error msg) $ findPackageByName name
+  where
+    msg = "unsafeFindPackageByName: No package with name " ++ name
+
+unsafeFindPackageByPath :: FilePath -> Package
+unsafeFindPackageByPath path = err $ find (\pkg -> pkgPath pkg == path) knownPackages
+  where
+    err = fromMaybe $ error ("findPackageByPath: No package for path " ++ path)
index 488e551..f18832c 100644 (file)
@@ -146,6 +146,8 @@ includeGhcArgs = do
     context <- getContext
     srcDirs <- getContextData srcDirs
     autogen <- expr $ autogenPath context
+    let cabalMacros = autogen -/- "cabal_macros.h"
+    expr $ need [cabalMacros]
     mconcat [ arg "-i"
             , arg $ "-i" ++ path
             , arg $ "-i" ++ autogen
@@ -153,7 +155,7 @@ includeGhcArgs = do
             , cIncludeArgs
             , arg $      "-I" ++ root -/- generatedDir
             , arg $ "-optc-I" ++ root -/- generatedDir
-            , pure ["-optP-include", "-optP" ++ autogen -/- "cabal_macros.h"] ]
+            , pure ["-optP-include", "-optP" ++ cabalMacros] ]
 
 -- Check if building dynamically is required. GHC is a special case that needs
 -- to be built dynamically if any of the RTS ways is dynamic.
index bc8303f..9223a9d 100644 (file)
@@ -4,8 +4,7 @@ import Settings.Builders.Common
 
 ghcPkgBuilderArgs :: Args
 ghcPkgBuilderArgs = mconcat
-    [ builder (GhcPkg Init) ? mconcat [ arg "init", arg =<< getOutput ]
-    , builder (GhcPkg Copy) ? do
+    [ builder (GhcPkg Copy) ? do
         verbosity <- expr getVerbosity
         stage     <- getStage
         pkgDb     <- expr $ packageDbPath stage
index 0d5363d..e2b9e44 100644 (file)
@@ -40,6 +40,8 @@ getCFlags :: Expr [String]
 getCFlags = do
     context <- getContext
     autogen <- expr $ autogenPath context
+    let cabalMacros = autogen -/- "cabal_macros.h"
+    expr $ need [cabalMacros]
     mconcat [ remove ["-O"] (cArgs <> getStagedSettingList ConfCcArgs)
             , getStagedSettingList ConfCppArgs
             , cIncludeArgs
@@ -48,7 +50,7 @@ getCFlags = do
             , getContextData cppOpts
             , getContextData depCcOpts
             , cWarnings
-            , arg "-include", arg $ autogen -/- "cabal_macros.h" ]
+            , arg "-include", arg cabalMacros ]
 
 getLFlags :: Expr [String]
 getLFlags =
index cec1d66..de52613 100644 (file)
@@ -1,6 +1,6 @@
 module Settings.Default (
     -- * Packages that are build by default and for the testsuite
-    defaultPackages, testsuitePackages, getPackageByPath,
+    defaultPackages, testsuitePackages,
 
     -- * Default build ways
     defaultLibraryWays, defaultRtsWays,
@@ -139,13 +139,6 @@ testsuitePackages = do
              , unlit         ] ++
              [ timeout | win ]
 
-getPackageByPath :: FilePath -> Action Package
-getPackageByPath pkgpath = do
-  case filter (\p -> pkgPath p == pkgpath) knownPackages of
-    (p:_) -> return p
-    _     -> error $
-      "getPackageByPath: couldn't find a package with path: " ++ pkgpath
-
 -- | Default build ways for library packages:
 -- * We always build 'vanilla' way.
 -- * We build 'profiling' way when stage > Stage0.
index 377051e..b9195fc 100644 (file)
@@ -10,7 +10,7 @@ Description: XXX
 Category: Development
 build-type: Simple
 
-Executable unlit
+Executable touchy
     Default-Language: Haskell2010
     Main-Is: touchy.c
     C-Sources: touchy.c