diff options
author | Andrey Mokhov <andrey.mokhov@gmail.com> | 2019-02-14 14:29:50 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-02-20 09:59:16 -0500 |
commit | 1dad4fc27ea128a11ba0077f459494c2a1ca0d5c (patch) | |
tree | c5b569c56435e699c03fca5ad08cf03cb8b21b80 /hadrian | |
parent | 908b4b8659713f0b7a1704ce33c7fa30e3e0ffc3 (diff) | |
download | haskell-1dad4fc27ea128a11ba0077f459494c2a1ca0d5c.tar.gz |
Hadrian: Fix untracked dependencies
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).
Diffstat (limited to 'hadrian')
24 files changed, 368 insertions, 334 deletions
diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal index 6a4fff1321..56c68aa0c3 100644 --- a/hadrian/hadrian.cabal +++ b/hadrian/hadrian.cabal @@ -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 diff --git a/hadrian/src/Base.hs b/hadrian/src/Base.hs index 77eec0a48a..7949fcf4b2 100644 --- a/hadrian/src/Base.hs +++ b/hadrian/src/Base.hs @@ -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] diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs index d09af9942e..02edb199d3 100644 --- a/hadrian/src/Builder.hs +++ b/hadrian/src/Builder.hs @@ -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 diff --git a/hadrian/src/Context.hs b/hadrian/src/Context.hs index 7943e6dfce..f8a07d7263 100644 --- a/hadrian/src/Context.hs +++ b/hadrian/src/Context.hs @@ -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@. diff --git a/hadrian/src/Hadrian/Haskell/Cabal.hs b/hadrian/src/Hadrian/Haskell/Cabal.hs index 91de7b2bb2..de4dd18de6 100644 --- a/hadrian/src/Hadrian/Haskell/Cabal.hs +++ b/hadrian/src/Hadrian/Haskell/Cabal.hs @@ -11,8 +11,7 @@ ----------------------------------------------------------------------------- module Hadrian.Haskell.Cabal ( pkgVersion, pkgIdentifier, pkgSynopsis, pkgDescription, pkgDependencies, - pkgGenericDescription, - cabalArchString, cabalOsString, + pkgGenericDescription, cabalArchString, cabalOsString, ) where import Development.Shake diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs index 8df343b423..d53aabd5e1 100644 --- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs +++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs @@ -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. diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs index b2a7002d6c..2b5d51a719 100644 --- a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs +++ b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs @@ -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 diff --git a/hadrian/src/Hadrian/Oracles/Cabal/Rules.hs b/hadrian/src/Hadrian/Oracles/Cabal/Rules.hs index dcda3704a8..b7f0f93526 100644 --- a/hadrian/src/Hadrian/Oracles/Cabal/Rules.hs +++ b/hadrian/src/Hadrian/Oracles/Cabal/Rules.hs @@ -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 diff --git a/hadrian/src/Oracles/ModuleFiles.hs b/hadrian/src/Oracles/ModuleFiles.hs index 1e508c0090..d2f0299563 100644 --- a/hadrian/src/Oracles/ModuleFiles.hs +++ b/hadrian/src/Oracles/ModuleFiles.hs @@ -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 diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs index 02dc134387..8d2aef1c7b 100644 --- a/hadrian/src/Packages.hs +++ b/hadrian/src/Packages.hs @@ -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] diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs index f634f22828..c5be5a7ff9 100644 --- a/hadrian/src/Rules.hs +++ b/hadrian/src/Rules.hs @@ -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 diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs index 74570a1556..0a84e67e90 100644 --- a/hadrian/src/Rules/Compile.hs +++ b/hadrian/src/Rules/Compile.hs @@ -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 () diff --git a/hadrian/src/Rules/Configure.hs b/hadrian/src/Rules/Configure.hs index 909b3c3357..8395472a4b 100644 --- a/hadrian/src/Rules/Configure.hs +++ b/hadrian/src/Rules/Configure.hs @@ -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 diff --git a/hadrian/src/Rules/Dependencies.hs b/hadrian/src/Rules/Dependencies.hs index 8b09a82b56..9a2a23354f 100644 --- a/hadrian/src/Rules/Dependencies.hs +++ b/hadrian/src/Rules/Dependencies.hs @@ -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) diff --git a/hadrian/src/Rules/Documentation.hs b/hadrian/src/Rules/Documentation.hs index 2d7a4b1ef7..c9de3038ed 100644 --- a/hadrian/src/Rules/Documentation.hs +++ b/hadrian/src/Rules/Documentation.hs @@ -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 diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs index 9db5b198e4..13544f2a7d 100644 --- a/hadrian/src/Rules/Generate.hs +++ b/hadrian/src/Rules/Generate.hs @@ -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 diff --git a/hadrian/src/Rules/Gmp.hs b/hadrian/src/Rules/Gmp.hs index 8e0d338c51..a78170cf6a 100644 --- a/hadrian/src/Rules/Gmp.hs +++ b/hadrian/src/Rules/Gmp.hs @@ -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. diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs index 465065e7ce..1fe6174b1e 100644 --- a/hadrian/src/Rules/Libffi.hs +++ b/hadrian/src/Rules/Libffi.hs @@ -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 diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs index ef56da5eae..d215938385 100644 --- a/hadrian/src/Rules/Register.hs +++ b/hadrian/src/Rules/Register.hs @@ -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 diff --git a/hadrian/src/Settings.hs b/hadrian/src/Settings.hs index 519d1fc80c..fdbef1c359 100755 --- a/hadrian/src/Settings.hs +++ b/hadrian/src/Settings.hs @@ -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) diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs index 488e551cdc..f18832c1ef 100644 --- a/hadrian/src/Settings/Builders/Ghc.hs +++ b/hadrian/src/Settings/Builders/Ghc.hs @@ -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. diff --git a/hadrian/src/Settings/Builders/GhcPkg.hs b/hadrian/src/Settings/Builders/GhcPkg.hs index bc8303f5a1..9223a9d85a 100644 --- a/hadrian/src/Settings/Builders/GhcPkg.hs +++ b/hadrian/src/Settings/Builders/GhcPkg.hs @@ -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 diff --git a/hadrian/src/Settings/Builders/Hsc2Hs.hs b/hadrian/src/Settings/Builders/Hsc2Hs.hs index 0d5363d413..e2b9e44260 100644 --- a/hadrian/src/Settings/Builders/Hsc2Hs.hs +++ b/hadrian/src/Settings/Builders/Hsc2Hs.hs @@ -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 = diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs index cec1d6616a..de5261372a 100644 --- a/hadrian/src/Settings/Default.hs +++ b/hadrian/src/Settings/Default.hs @@ -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. |