Commit 0781e16f authored by Andrey Mokhov's avatar Andrey Mokhov

Refactor GHC/user packages, move builder-specific functions into Builder

See #403
parent fc564b8b
......@@ -14,7 +14,6 @@ module Base (
module Development.Shake.Util,
-- * Basic data types
module Builder,
module Hadrian.Package,
module Stage,
module Way,
......@@ -39,7 +38,6 @@ import Development.Shake.Util
import Hadrian.Utilities
import Hadrian.Package
import Builder
import Stage
import Way
......
module Builder (
CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..), isOptional
CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..),
builderProvenance, systemBuilderPath, builderPath, getBuilderPath,
isSpecified, needBuilder,
) where
import Development.Shake.Classes
import GHC.Generics
import Hadrian.Expression
import Hadrian.Oracles.Path
import Hadrian.Oracles.TextFile
import Stage
import Base
import Context
import GHC
-- | C compiler can be used in two different modes:
-- * Compile or preprocess a source file.
......@@ -72,6 +79,36 @@ instance Binary Builder
instance Hashable Builder
instance NFData Builder
-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
-- 'Stage' and GHC 'Package').
builderProvenance :: Builder -> Maybe Context
builderProvenance = \case
DeriveConstants -> context Stage0 deriveConstants
GenApply -> context Stage0 genapply
GenPrimopCode -> context Stage0 genprimopcode
Ghc _ Stage0 -> Nothing
Ghc _ stage -> context (pred stage) ghc
GhcCabal -> context Stage0 ghcCabal
GhcCabalHsColour -> builderProvenance $ GhcCabal
GhcPkg _ Stage0 -> Nothing
GhcPkg _ _ -> context Stage0 ghcPkg
Haddock -> context Stage2 haddock
Hpc -> context Stage1 hpcBin
Hsc2Hs -> context Stage0 hsc2hs
Unlit -> context Stage0 unlit
_ -> Nothing
where
context s p = Just $ vanillaContext s p
-- | Make sure a 'Builder' exists and rebuild it if out of date.
needBuilder :: Builder -> Action ()
needBuilder (Configure dir) = need [dir -/- "configure"]
needBuilder (Make dir) = need [dir -/- "Makefile"]
needBuilder builder = when (isJust $ builderProvenance builder) $ do
path <- builderPath builder
need [path]
-- TODO: Some builders are required only on certain platforms. For example,
-- Objdump is only required on OpenBSD and AIX, as mentioned in #211. Add
-- support for platform-specific optional builders as soon as we can reliably
......@@ -81,3 +118,53 @@ isOptional = \case
HsColour -> True
Objdump -> True
_ -> False
-- | Determine the location of a system 'Builder'.
systemBuilderPath :: Builder -> Action FilePath
systemBuilderPath builder = case builder of
Alex -> fromKey "alex"
Ar Stage0 -> fromKey "system-ar"
Ar _ -> fromKey "ar"
Cc _ Stage0 -> fromKey "system-cc"
Cc _ _ -> fromKey "cc"
-- We can't ask configure for the path to configure!
Configure _ -> return "sh configure"
Ghc _ Stage0 -> fromKey "system-ghc"
GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
Happy -> fromKey "happy"
HsColour -> fromKey "hscolour"
HsCpp -> fromKey "hs-cpp"
Ld -> fromKey "ld"
Make _ -> fromKey "make"
Nm -> fromKey "nm"
Objdump -> fromKey "objdump"
Patch -> fromKey "patch"
Perl -> fromKey "perl"
Ranlib -> fromKey "ranlib"
Tar -> fromKey "tar"
_ -> error $ "No entry for " ++ show builder ++ inCfg
where
inCfg = " in " ++ quote configFile ++ " file."
fromKey key = do
let unpack = fromMaybe . error $ "Cannot find path to builder "
++ quote key ++ inCfg ++ " Did you skip configure?"
path <- unpack <$> lookupValue configFile key
if null path
then do
unless (isOptional builder) . error $ "Non optional builder "
++ quote key ++ " is not specified" ++ inCfg
return "" -- TODO: Use a safe interface.
else fixAbsolutePathOnWindows =<< lookupInPath path
-- | Determine the location of a 'Builder'.
builderPath :: Builder -> Action FilePath
builderPath builder = case builderProvenance builder of
Nothing -> systemBuilderPath builder
Just context -> programPath context
-- | Was the path to a given system 'Builder' specified in configuration files?
isSpecified :: Builder -> Action Bool
isSpecified = fmap (not . null) . systemBuilderPath
getBuilderPath :: Builder -> Expr c Builder FilePath
getBuilderPath = expr . builderPath
......@@ -20,13 +20,15 @@ module Expression (
getPackage, getBuilder, getOutputs, getInputs, getWay, getInput, getOutput,
-- * Re-exports
module Base
module Base,
module Builder
) where
import qualified Hadrian.Expression as H
import Hadrian.Expression hiding (Expr, Predicate, Args)
import Base
import Builder
import Context (Context, vanillaContext, stageContext, getBuildPath, getStage, getPackage, getWay)
import Oracles.PackageData
import Target hiding (builder, inputs, outputs)
......
......@@ -8,18 +8,15 @@ module GHC (
hpc, hpcBin, integerGmp, integerSimple, iservBin, libffi, mtl, parsec,
parallel, pretty, primitive, process, rts, runGhc, stm, templateHaskell,
terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml,
defaultKnownPackages, defaultPackages,
ghcPackages, isGhcPackage, defaultPackages,
-- * Package information
builderProvenance, programName, nonCabalContext, nonHsMainPackage, autogenPath,
programName, nonCabalContext, nonHsMainPackage, autogenPath,
-- * Miscellaneous
systemBuilderPath, ghcSplitPath, stripCmdPath, inplaceInstallPath, buildDll0
programPath, ghcSplitPath, stripCmdPath, inplaceInstallPath, buildDll0
) where
import Hadrian.Oracles.Path
import Hadrian.Oracles.TextFile
import Base
import CommandLine
import Context
......@@ -27,11 +24,11 @@ import Oracles.Setting
-- | These are all GHC packages we know about. Build rules will be generated for
-- all of them. However, not all of these packages will be built. For example,
-- package 'win32' is built only on Windows. "Settings.Default" defines default
-- conditions for building each package, which can be overridden in
-- @hadrian/src/UserSettings.hs@.
defaultKnownPackages :: [Package]
defaultKnownPackages =
-- package 'win32' is built only on Windows. 'defaultPackages' defines default
-- conditions for building each package. Users can add their own packages and
-- modify build default build conditions in "UserSettings".
ghcPackages :: [Package]
ghcPackages =
[ array, base, binary, bytestring, cabal, checkApiAnnotations, compareSizes
, compiler, containers, deepseq, deriveConstants, directory, dllSplit
, filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCabal
......@@ -41,6 +38,10 @@ defaultKnownPackages =
, templateHaskell, terminfo, text, time, touchy, transformers, unlit, unix
, win32, xhtml ]
-- TODO: Optimise by switching to sets of packages.
isGhcPackage :: Package -> Bool
isGhcPackage = (`elem` ghcPackages)
-- | Package definitions, see 'Package'.
array = hsLib "array"
base = hsLib "base"
......@@ -202,65 +203,6 @@ stage2Packages = do
doc <- cmdBuildHaddock
return [ haddock | doc ]
-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
-- 'Stage' and GHC 'Package').
builderProvenance :: Builder -> Maybe Context
builderProvenance = \case
DeriveConstants -> context Stage0 deriveConstants
GenApply -> context Stage0 genapply
GenPrimopCode -> context Stage0 genprimopcode
Ghc _ Stage0 -> Nothing
Ghc _ stage -> context (pred stage) ghc
GhcCabal -> context Stage0 ghcCabal
GhcCabalHsColour -> builderProvenance $ GhcCabal
GhcPkg _ Stage0 -> Nothing
GhcPkg _ _ -> context Stage0 ghcPkg
Haddock -> context Stage2 haddock
Hpc -> context Stage1 hpcBin
Hsc2Hs -> context Stage0 hsc2hs
Unlit -> context Stage0 unlit
_ -> Nothing
where
context s p = Just $ vanillaContext s p
-- | Determine the location of a system 'Builder'.
systemBuilderPath :: Builder -> Action FilePath
systemBuilderPath builder = case builder of
Alex -> fromKey "alex"
Ar Stage0 -> fromKey "system-ar"
Ar _ -> fromKey "ar"
Cc _ Stage0 -> fromKey "system-cc"
Cc _ _ -> fromKey "cc"
-- We can't ask configure for the path to configure!
Configure _ -> return "sh configure"
Ghc _ Stage0 -> fromKey "system-ghc"
GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
Happy -> fromKey "happy"
HsColour -> fromKey "hscolour"
HsCpp -> fromKey "hs-cpp"
Ld -> fromKey "ld"
Make _ -> fromKey "make"
Nm -> fromKey "nm"
Objdump -> fromKey "objdump"
Patch -> fromKey "patch"
Perl -> fromKey "perl"
Ranlib -> fromKey "ranlib"
Tar -> fromKey "tar"
_ -> error $ "No entry for " ++ show builder ++ inCfg
where
inCfg = " in " ++ quote configFile ++ " file."
fromKey key = do
let unpack = fromMaybe . error $ "Cannot find path to builder "
++ quote key ++ inCfg ++ " Did you skip configure?"
path <- unpack <$> lookupValue configFile key
if null path
then do
unless (isOptional builder) . error $ "Non optional builder "
++ quote key ++ " is not specified" ++ inCfg
return "" -- TODO: Use a safe interface.
else fixAbsolutePathOnWindows =<< lookupInPath path
-- | Given a 'Context', compute the name of the program that is built in it
-- assuming that the corresponding package's type is 'Program'. For example, GHC
-- built in 'Stage0' is called @ghc-stage1@. If the given package is a
......@@ -273,6 +215,21 @@ programName Context {..}
| package == iservBin = "ghc-iserv"
| otherwise = pkgName package
isInstallContext :: Context -> Action Bool
isInstallContext Context {..}
| not (isGhcPackage package) = return False
| otherwise = do
stages <- filterM (fmap (package `elem`) . defaultPackages) [Stage0 ..]
return (null stages || package == ghc || stage == maximum stages)
-- | The 'FilePath' to a program executable in a given 'Context'.
programPath :: Context -> Action FilePath
programPath context@Context {..} = do
path <- buildPath context
install <- isInstallContext context
let contextPath = if install then inplaceInstallPath package else path
return $ contextPath -/- programName context <.> exe
-- | Some contexts are special: their packages do not have @.cabal@ metadata or
-- we cannot run @ghc-cabal@ on them, e.g. because the latter hasn't been built
-- yet (this is the case with the 'ghcCabal' package in 'Stage0').
......
......@@ -6,6 +6,7 @@ module Oracles.ModuleFiles (
import qualified Data.HashMap.Strict as Map
import Base
import Builder
import Context
import GHC
import Oracles.PackageData
......
......@@ -72,8 +72,10 @@ packageTargets includeGhciLib stage pkg = do
return $ [ setup | nonCabalContext context ]
++ [ haddock | docs && stage == Stage1 ]
++ libs ++ more
else -- The only target of a program package is the executable.
fmap maybeToList . programPath =<< programContext stage pkg
else do -- The only target of a program package is the executable.
prgContext <- programContext stage pkg
prgPath <- programPath prgContext
return [prgPath]
packageRules :: Rules ()
packageRules = do
......
......@@ -18,7 +18,7 @@ haddockDependencies context = do
path <- buildPath context
depNames <- pkgDataList $ DepNames path
sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg
| Just depPkg <- map findKnownPackage depNames, depPkg /= rts ]
| Just depPkg <- map findPackageByName depNames, depPkg /= rts ]
-- Note: this build rule creates plenty of files, not just the .haddock one.
-- All of them go into the 'doc' subdirectory. Pedantically tracking all built
......
module Rules.Perl (perlScriptRules) where
import Base
import Builder
import Utilities
-- TODO: Do we need this build rule?
-- | Build Perl scripts, such as @ghc-split@, from their literate Perl sources.
perlScriptRules :: Rules ()
perlScriptRules = do
......
......@@ -3,6 +3,7 @@ module Rules.SourceDist (sourceDistRules) where
import Hadrian.Oracles.DirectoryContents
import Base
import Builder
import Oracles.Setting
import Rules.Clean
import Utilities
......
module Settings (
getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
findKnownPackage, getPkgData, getPkgDataList, isLibrary, stagePackages,
builderPath, getBuilderPath, isSpecified, latestBuildStage, programPath,
programContext, integerLibraryName, getDestDir, stage1Only, buildDll0
findPackageByName, getPkgData, getPkgDataList, isLibrary, stagePackages,
latestBuildStage, programContext, integerLibraryName, getDestDir, stage1Only
) where
import Context
......@@ -57,28 +56,12 @@ programContext stage pkg = do
-- TODO: switch to Set Package as the order of packages should not matter?
-- Otherwise we have to keep remembering to sort packages from time to time.
knownPackages :: [Package]
knownPackages = sort $ defaultKnownPackages ++ userKnownPackages
knownPackages = sort $ ghcPackages ++ userPackages
-- TODO: Speed up? Switch to Set?
-- Note: this is slow but we keep it simple as there are just ~50 packages
findKnownPackage :: PackageName -> Maybe Package
findKnownPackage name = find (\pkg -> pkgName pkg == name) knownPackages
-- | Determine the location of a 'Builder'.
builderPath :: Builder -> Action FilePath
builderPath builder = case builderProvenance builder of
Nothing -> systemBuilderPath builder
Just context -> do
maybePath <- programPath context
let msg = error $ show builder ++ " is never built by Hadrian."
return $ fromMaybe msg maybePath
getBuilderPath :: Builder -> Expr FilePath
getBuilderPath = expr . builderPath
-- | Was the path to a given 'Builder' specified in configuration files?
isSpecified :: Builder -> Action Bool
isSpecified = fmap (not . null) . builderPath
findPackageByName :: PackageName -> Maybe Package
findPackageByName name = find (\pkg -> pkgName pkg == name) knownPackages
-- | Determine the latest 'Stage' in which a given 'Package' is built. Returns
-- Nothing if the package is never built.
......@@ -87,16 +70,6 @@ latestBuildStage pkg = do
stages <- filterM (fmap (pkg `elem`) . stagePackages) [Stage0 ..]
return $ if null stages then Nothing else Just $ maximum stages
-- | The 'FilePath' to a program executable in a given 'Context'.
programPath :: Context -> Action (Maybe FilePath)
programPath context@Context {..} = do
maybeLatest <- latestBuildStage package
path <- buildPath context
return $ do
install <- (\l -> l == stage || package == ghc) <$> maybeLatest
let installPath = if install then inplaceInstallPath package else path
return $ installPath -/- programName context <.> exe
-- TODO: Set this from command line
-- | Stage1Only flag.
stage1Only :: Bool
......
......@@ -20,9 +20,9 @@ ghcBuilderArgs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
, arg "-o", arg =<< getOutput ]
needTouchy :: Expr ()
needTouchy = notStage0 ? do
maybePath <- expr $ programPath (vanillaContext Stage0 touchy)
expr . whenJust maybePath $ \path -> need [path]
needTouchy = notStage0 ? windowsHost ? do
touchyPath <- expr $ programPath (vanillaContext Stage0 touchy)
expr $ need [touchyPath]
ghcCbuilderArgs :: Args
ghcCbuilderArgs =
......
......@@ -7,7 +7,6 @@ import Hadrian.Haskell.Cabal
import Context
import Flavour
import Settings.Builders.Common hiding (package)
import Utilities
ghcCabalBuilderArgs :: Args
ghcCabalBuilderArgs = builder GhcCabal ? do
......@@ -118,11 +117,12 @@ withBuilderKey b = case b of
-- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
with :: Builder -> Args
with b = isSpecified b ? do
top <- expr topDirectory
with b = do
path <- getBuilderPath b
expr $ needBuilder b
arg $ withBuilderKey b ++ unifyPath (top </> path)
if (null path) then mempty else do
top <- expr topDirectory
expr $ needBuilder b
arg $ withBuilderKey b ++ unifyPath (top </> path)
withStaged :: (Stage -> Builder) -> Args
withStaged sb = with . sb =<< getStage
......
module Target (
Target, target, context, builder, inputs, outputs, trackArgument
Target, target, context, builder, inputs, outputs, trackArgument,
module Builder
) where
import Data.Char
......
......@@ -3,7 +3,7 @@
-- If you don't copy the file your changes will be tracked by git and you can
-- accidentally commit them.
module UserSettings (
userBuildRoot, userFlavours, userKnownPackages, verboseCommands,
userBuildRoot, userFlavours, userPackages, verboseCommands,
buildProgressColour, successColour, defaultStage1Only
) where
......@@ -23,11 +23,11 @@ userBuildRoot = BuildRoot "_build"
userFlavours :: [Flavour]
userFlavours = []
-- | Add user defined packages. Note, this only let's Hadrian know about the
-- | Add user defined packages. Note, this only lets Hadrian know about the
-- existence of a new package; to actually build it you need to create a new
-- build flavour, modifying the list of packages that are built by default.
userKnownPackages :: [Package]
userKnownPackages = []
userPackages :: [Package]
userPackages = []
-- | Set to 'True' to print full command lines during the build process. Note:
-- this is a 'Predicate', hence you can enable verbose output only for certain
......
module Utilities (
build, buildWithCmdOptions, buildWithResources, applyPatch, runBuilder,
runBuilderWith, builderEnvironment, needBuilder, needLibrary,
runBuilderWith, builderEnvironment, needLibrary,
installDirectory, installData, installScript, installProgram, linkSymbolic,
contextDependencies, stage1Dependencies, libraryTargets, topsortPackages
) where
......@@ -153,17 +153,6 @@ linkSymbolic source target = do
putProgressInfo =<< renderAction "Create symbolic link" source target
quietly $ cmd lns source target
isInternal :: Builder -> Bool
isInternal = isJust . builderProvenance
-- | Make sure a 'Builder' exists and rebuild it if out of date.
needBuilder :: Builder -> Action ()
needBuilder (Configure dir) = need [dir -/- "configure"]
needBuilder (Make dir) = need [dir -/- "Makefile"]
needBuilder builder = when (isInternal builder) $ do
path <- builderPath builder
need [path]
-- | Write a Builder's path into a given environment variable.
builderEnvironment :: String -> Builder -> Action CmdOption
builderEnvironment variable builder = do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment