summaryrefslogtreecommitdiff
path: root/hadrian/src
diff options
context:
space:
mode:
authorAndrey Mokhov <andrey.mokhov@gmail.com>2017-11-06 22:59:38 +0000
committerAndrey Mokhov <andrey.mokhov@gmail.com>2017-11-06 22:59:38 +0000
commit5cee48036ed69ae298a599d43cf72e0fe73e3b4e (patch)
tree5fe732c738a769d02e732469f4ffecd4ac9e191a /hadrian/src
parent275ac8ef0a0081f16abbfb8934e10cf271573768 (diff)
parent7b0b9f603bb1215e2b7af23c2404d637b95a4988 (diff)
downloadhaskell-5cee48036ed69ae298a599d43cf72e0fe73e3b4e.tar.gz
Merge commit '7b0b9f603bb1215e2b7af23c2404d637b95a4988' as 'hadrian'
Diffstat (limited to 'hadrian/src')
-rw-r--r--hadrian/src/Base.hs121
-rw-r--r--hadrian/src/Builder.hs296
-rw-r--r--hadrian/src/CommandLine.hs137
-rw-r--r--hadrian/src/Context.hs158
-rw-r--r--hadrian/src/Environment.hs16
-rw-r--r--hadrian/src/Expression.hs123
-rw-r--r--hadrian/src/Flavour.hs34
-rw-r--r--hadrian/src/GHC.hs289
-rw-r--r--hadrian/src/Hadrian/Builder.hs125
-rw-r--r--hadrian/src/Hadrian/Builder/Ar.hs68
-rw-r--r--hadrian/src/Hadrian/Builder/Sphinx.hs39
-rw-r--r--hadrian/src/Hadrian/Builder/Tar.hs40
-rw-r--r--hadrian/src/Hadrian/Expression.hs153
-rw-r--r--hadrian/src/Hadrian/Haskell/Cabal.hs44
-rw-r--r--hadrian/src/Hadrian/Haskell/Cabal/Parse.hs63
-rw-r--r--hadrian/src/Hadrian/Oracles/ArgsHash.hs51
-rw-r--r--hadrian/src/Hadrian/Oracles/DirectoryContents.hs64
-rw-r--r--hadrian/src/Hadrian/Oracles/Path.hs62
-rw-r--r--hadrian/src/Hadrian/Oracles/TextFile.hs123
-rw-r--r--hadrian/src/Hadrian/Package.hs120
-rw-r--r--hadrian/src/Hadrian/Target.hs29
-rw-r--r--hadrian/src/Hadrian/Utilities.hs406
-rw-r--r--hadrian/src/Main.hs59
-rw-r--r--hadrian/src/Oracles/Flag.hs80
-rw-r--r--hadrian/src/Oracles/ModuleFiles.hs160
-rw-r--r--hadrian/src/Oracles/PackageData.hs66
-rw-r--r--hadrian/src/Oracles/Setting.hs236
-rw-r--r--hadrian/src/Rules.hs123
-rw-r--r--hadrian/src/Rules/Clean.hs23
-rw-r--r--hadrian/src/Rules/Compile.hs83
-rw-r--r--hadrian/src/Rules/Configure.hs42
-rw-r--r--hadrian/src/Rules/Dependencies.hs33
-rw-r--r--hadrian/src/Rules/Documentation.hs197
-rw-r--r--hadrian/src/Rules/Generate.hs482
-rw-r--r--hadrian/src/Rules/Gmp.hs119
-rw-r--r--hadrian/src/Rules/Install.hs336
-rw-r--r--hadrian/src/Rules/Libffi.hs108
-rw-r--r--hadrian/src/Rules/Library.hs103
-rw-r--r--hadrian/src/Rules/PackageData.hs119
-rw-r--r--hadrian/src/Rules/Program.hs116
-rw-r--r--hadrian/src/Rules/Register.hs44
-rw-r--r--hadrian/src/Rules/Selftest.hs92
-rw-r--r--hadrian/src/Rules/SourceDist.hs113
-rw-r--r--hadrian/src/Rules/Test.hs72
-rw-r--r--hadrian/src/Rules/Wrappers.hs162
-rw-r--r--hadrian/src/Settings.hs68
-rw-r--r--hadrian/src/Settings/Builders/Alex.hs8
-rw-r--r--hadrian/src/Settings/Builders/Cc.hs26
-rw-r--r--hadrian/src/Settings/Builders/Common.hs59
-rw-r--r--hadrian/src/Settings/Builders/Configure.hs25
-rw-r--r--hadrian/src/Settings/Builders/DeriveConstants.hs39
-rw-r--r--hadrian/src/Settings/Builders/GenPrimopCode.hs24
-rw-r--r--hadrian/src/Settings/Builders/Ghc.hs149
-rw-r--r--hadrian/src/Settings/Builders/GhcCabal.hs118
-rw-r--r--hadrian/src/Settings/Builders/GhcPkg.hs17
-rw-r--r--hadrian/src/Settings/Builders/Haddock.hs63
-rw-r--r--hadrian/src/Settings/Builders/Happy.hs9
-rw-r--r--hadrian/src/Settings/Builders/HsCpp.hs16
-rw-r--r--hadrian/src/Settings/Builders/Hsc2Hs.hs56
-rw-r--r--hadrian/src/Settings/Builders/Ld.hs9
-rw-r--r--hadrian/src/Settings/Builders/Make.hs16
-rw-r--r--hadrian/src/Settings/Builders/Xelatex.hs7
-rw-r--r--hadrian/src/Settings/Default.hs173
-rw-r--r--hadrian/src/Settings/Default.hs-boot20
-rw-r--r--hadrian/src/Settings/Flavours/Development.hs20
-rw-r--r--hadrian/src/Settings/Flavours/Performance.hs18
-rw-r--r--hadrian/src/Settings/Flavours/Profiled.hs19
-rw-r--r--hadrian/src/Settings/Flavours/Quick.hs22
-rw-r--r--hadrian/src/Settings/Flavours/QuickCross.hs24
-rw-r--r--hadrian/src/Settings/Flavours/Quickest.hs23
-rw-r--r--hadrian/src/Settings/Packages/Base.hs12
-rw-r--r--hadrian/src/Settings/Packages/Cabal.hs10
-rw-r--r--hadrian/src/Settings/Packages/Compiler.hs45
-rw-r--r--hadrian/src/Settings/Packages/Ghc.hs13
-rw-r--r--hadrian/src/Settings/Packages/GhcCabal.hs24
-rw-r--r--hadrian/src/Settings/Packages/GhcPkg.hs7
-rw-r--r--hadrian/src/Settings/Packages/GhcPrim.hs13
-rw-r--r--hadrian/src/Settings/Packages/Ghci.hs6
-rw-r--r--hadrian/src/Settings/Packages/Haddock.hs7
-rw-r--r--hadrian/src/Settings/Packages/Haskeline.hs8
-rw-r--r--hadrian/src/Settings/Packages/IntegerGmp.hs24
-rw-r--r--hadrian/src/Settings/Packages/Rts.hs218
-rw-r--r--hadrian/src/Settings/Packages/RunGhc.hs9
-rw-r--r--hadrian/src/Settings/Warnings.hs57
-rw-r--r--hadrian/src/Stage.hs31
-rw-r--r--hadrian/src/Target.hs26
-rw-r--r--hadrian/src/UserSettings.hs64
-rw-r--r--hadrian/src/Utilities.hs80
-rw-r--r--hadrian/src/Way.hs162
89 files changed, 7373 insertions, 0 deletions
diff --git a/hadrian/src/Base.hs b/hadrian/src/Base.hs
new file mode 100644
index 0000000000..38c879234a
--- /dev/null
+++ b/hadrian/src/Base.hs
@@ -0,0 +1,121 @@
+module Base (
+ -- * General utilities
+ module Control.Applicative,
+ module Control.Monad.Extra,
+ module Data.List.Extra,
+ module Data.Maybe,
+ module Data.Semigroup,
+ module Hadrian.Utilities,
+
+ -- * Shake
+ module Development.Shake,
+ module Development.Shake.Classes,
+ module Development.Shake.FilePath,
+ module Development.Shake.Util,
+
+ -- * Basic data types
+ module Hadrian.Package,
+ module Stage,
+ module Way,
+
+ -- * Paths
+ hadrianPath, configPath, configFile, sourcePath, configH, shakeFilesDir,
+ generatedDir, inplaceBinPath, inplaceLibBinPath, inplaceLibPath,
+ inplaceLibCopyTargets, templateHscPath, stage0PackageDbDir,
+ inplacePackageDbPath, packageDbPath, packageDbStamp
+ ) where
+
+import Control.Applicative
+import Control.Monad.Extra
+import Control.Monad.Reader
+import Data.List.Extra
+import Data.Maybe
+import Data.Semigroup
+import Development.Shake hiding (parallel, unit, (*>), Normal)
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import Development.Shake.Util
+import Hadrian.Utilities
+import Hadrian.Package
+
+import Stage
+import Way
+
+-- | Hadrian lives in the 'hadrianPath' directory of the GHC tree.
+hadrianPath :: FilePath
+hadrianPath = "hadrian"
+
+-- TODO: Move this to build directory?
+-- | Path to system configuration files, such as 'configFile'.
+configPath :: FilePath
+configPath = hadrianPath -/- "cfg"
+
+-- | Path to the system configuration file generated by the @configure@ script.
+configFile :: FilePath
+configFile = configPath -/- "system.config"
+
+-- | Path to source files of the build system, e.g. this file is located at
+-- @sourcePath -/- "Base.hs"@. We use this to track some of the source files.
+sourcePath :: FilePath
+sourcePath = hadrianPath -/- "src"
+
+-- TODO: Change @mk/config.h@ to @shake-build/cfg/config.h@.
+-- | Path to the generated @mk/config.h@ file.
+configH :: FilePath
+configH = "mk/config.h"
+
+-- | The directory in 'buildRoot' containing the Shake database and other
+-- auxiliary files generated by Hadrian.
+shakeFilesDir :: FilePath
+shakeFilesDir = "hadrian"
+
+-- | The directory in 'buildRoot' containing generated source files that are not
+-- package-specific, e.g. @ghcplatform.h@.
+generatedDir :: FilePath
+generatedDir = "generated"
+
+-- | The directory in 'buildRoot' containing the 'Stage0' package database.
+stage0PackageDbDir :: FilePath
+stage0PackageDbDir = "stage0/bootstrapping.conf"
+
+-- | Path to the inplace package database used in 'Stage1' and later.
+inplacePackageDbPath :: FilePath
+inplacePackageDbPath = "inplace/lib/package.conf.d"
+
+-- | Path to the package database used in a given 'Stage'.
+packageDbPath :: Stage -> Action FilePath
+packageDbPath Stage0 = buildRoot <&> (-/- stage0PackageDbDir)
+packageDbPath _ = return inplacePackageDbPath
+
+-- | We use a stamp file to track the existence of a package database.
+packageDbStamp :: FilePath
+packageDbStamp = ".stamp"
+
+-- | Directory for binaries that are built "in place".
+inplaceBinPath :: FilePath
+inplaceBinPath = "inplace/bin"
+
+-- | Directory for libraries that are built "in place".
+inplaceLibPath :: FilePath
+inplaceLibPath = "inplace/lib"
+
+-- | Directory for binary wrappers, and auxiliary binaries such as @touchy@.
+inplaceLibBinPath :: FilePath
+inplaceLibBinPath = "inplace/lib/bin"
+
+-- ref: ghc/ghc.mk:142
+-- ref: driver/ghc.mk
+-- ref: utils/hsc2hs/ghc.mk:35
+-- | Files that need to be copied over to 'inplaceLibPath'.
+inplaceLibCopyTargets :: [FilePath]
+inplaceLibCopyTargets = map (inplaceLibPath -/-)
+ [ "ghc-usage.txt"
+ , "ghci-usage.txt"
+ , "llvm-targets"
+ , "platformConstants"
+ , "settings"
+ , "template-hsc.h" ]
+
+-- | Path to hsc2hs template.
+templateHscPath :: FilePath
+templateHscPath = "inplace/lib/template-hsc.h"
diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs
new file mode 100644
index 0000000000..2b99c03992
--- /dev/null
+++ b/hadrian/src/Builder.hs
@@ -0,0 +1,296 @@
+{-# LANGUAGE InstanceSigs #-}
+module Builder (
+ -- * Data types
+ ArMode (..), CcMode (..), GhcMode (..), GhcPkgMode (..), HaddockMode (..),
+ SphinxMode (..), TarMode (..), Builder (..),
+
+ -- * Builder properties
+ builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder,
+ runBuilder, runBuilderWith, runBuilderWithCmdOptions, getBuilderPath,
+ builderEnvironment,
+
+ -- * Ad hoc builder invokation
+ applyPatch, installDirectory, installData, installScript, installProgram,
+ linkSymbolic
+ ) where
+
+import Development.Shake.Classes
+import GHC.Generics
+import qualified Hadrian.Builder as H
+import Hadrian.Builder hiding (Builder)
+import Hadrian.Builder.Ar
+import Hadrian.Builder.Sphinx
+import Hadrian.Builder.Tar
+import Hadrian.Oracles.Path
+import Hadrian.Oracles.TextFile
+import Hadrian.Utilities
+import qualified System.Directory.Extra as IO
+
+import Base
+import Context
+import GHC
+import Oracles.Flag
+import Oracles.Setting
+
+-- | C compiler can be used in two different modes:
+-- * Compile or preprocess a source file.
+-- * Extract source dependencies by passing @-MM@ command line argument.
+data CcMode = CompileC | FindCDependencies deriving (Eq, Generic, Show)
+
+instance Binary CcMode
+instance Hashable CcMode
+instance NFData CcMode
+
+-- | GHC can be used in four different modes:
+-- * Compile a Haskell source file.
+-- * Compile a C source file.
+-- * Extract source dependencies by passing @-M@ command line argument.
+-- * Link object files & static libraries into an executable.
+data GhcMode = CompileHs | CompileCWithGhc | FindHsDependencies | LinkHs
+ deriving (Eq, Generic, Show)
+
+instance Binary GhcMode
+instance Hashable GhcMode
+instance NFData GhcMode
+
+-- | GhcPkg can initialise a package database and register packages in it.
+data GhcPkgMode = Init | Update deriving (Eq, Generic, Show)
+
+instance Binary GhcPkgMode
+instance Hashable GhcPkgMode
+instance NFData GhcPkgMode
+
+-- | Haddock can be used in two different modes:
+-- * Generate documentation for a single package
+-- * Generate an index page for a collection of packages
+data HaddockMode = BuildPackage | BuildIndex deriving (Eq, Generic, Show)
+
+instance Binary HaddockMode
+instance Hashable HaddockMode
+instance NFData HaddockMode
+
+-- | A 'Builder' is an external command invoked in a separate process via 'cmd'.
+-- @Ghc Stage0@ is the bootstrapping compiler.
+-- @Ghc StageN@, N > 0, is the one built in stage (N - 1).
+-- @GhcPkg Stage0@ is the bootstrapping @GhcPkg@.
+-- @GhcPkg Stage1@ is the one built in Stage0.
+data Builder = Alex
+ | Ar ArMode Stage
+ | DeriveConstants
+ | Cc CcMode Stage
+ | Configure FilePath
+ | GenApply
+ | GenPrimopCode
+ | Ghc GhcMode Stage
+ | GhcCabal
+ | GhcPkg GhcPkgMode Stage
+ | Haddock HaddockMode
+ | Happy
+ | Hpc
+ | HsCpp
+ | Hsc2Hs
+ | Ld
+ | Make FilePath
+ | Nm
+ | Objdump
+ | Patch
+ | Perl
+ | Ranlib
+ | Sphinx SphinxMode
+ | Tar TarMode
+ | Unlit
+ | Xelatex
+ deriving (Eq, Generic, Show)
+
+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
+ 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
+
+instance H.Builder Builder where
+ builderPath :: Builder -> Action FilePath
+ builderPath builder = case builderProvenance builder of
+ Nothing -> systemBuilderPath builder
+ Just context -> programPath context
+
+ needBuilder :: Builder -> Action ()
+ needBuilder builder = do
+ path <- H.builderPath builder
+ case builder of
+ Configure dir -> need [dir -/- "configure"]
+ Hsc2Hs -> need [path, templateHscPath]
+ Make dir -> need [dir -/- "Makefile"]
+ _ -> when (isJust $ builderProvenance builder) $ need [path]
+
+ runBuilderWith :: Builder -> BuildInfo -> Action ()
+ runBuilderWith builder BuildInfo {..} = do
+ path <- builderPath builder
+ withResources buildResources $ do
+ verbosity <- getVerbosity
+ let input = fromSingleton msgIn buildInputs
+ msgIn = "[runBuilderWith] Exactly one input file expected."
+ output = fromSingleton msgOut buildOutputs
+ msgOut = "[runBuilderWith] Exactly one output file expected."
+ -- Suppress stdout depending on the Shake's verbosity setting.
+ echo = EchoStdout (verbosity >= Loud)
+ -- Capture stdout and write it to the output file.
+ captureStdout = do
+ Stdout stdout <- cmd [path] buildArgs
+ writeFileChanged output stdout
+ case builder of
+ Ar Pack _ -> do
+ useTempFile <- flag ArSupportsAtFile
+ if useTempFile then runAr path buildArgs
+ else runArWithoutTempFile path buildArgs
+
+ Ar Unpack _ -> cmd echo [Cwd output] [path] buildArgs
+
+ Configure dir -> do
+ -- Inject /bin/bash into `libtool`, instead of /bin/sh,
+ -- otherwise Windows breaks. TODO: Figure out why.
+ bash <- bashPath
+ let env = AddEnv "CONFIG_SHELL" bash
+ cmd echo env [Cwd dir] ["sh", path] buildOptions buildArgs
+
+ HsCpp -> captureStdout
+ GenApply -> captureStdout
+
+ GenPrimopCode -> do
+ stdin <- readFile' input
+ Stdout stdout <- cmd (Stdin stdin) [path] buildArgs
+ writeFileChanged output stdout
+
+ Make dir -> cmd echo path ["-C", dir] buildArgs
+
+ Xelatex -> do
+ unit $ cmd [Cwd output] [path] buildArgs
+ unit $ cmd [Cwd output] [path] buildArgs
+ unit $ cmd [Cwd output] [path] buildArgs
+ unit $ cmd [Cwd output] ["makeindex"] (input -<.> "idx")
+ unit $ cmd [Cwd output] [path] buildArgs
+ unit $ cmd [Cwd output] [path] buildArgs
+
+ _ -> cmd echo [path] buildArgs
+
+-- TODO: Some builders are required only on certain platforms. For example,
+-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
+-- specific optional builders as soon as we can reliably test this feature.
+-- See https://github.com/snowleopard/hadrian/issues/211.
+isOptional :: Builder -> Bool
+isOptional = \case
+ 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 "configure"
+ Ghc _ Stage0 -> fromKey "system-ghc"
+ GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
+ Happy -> fromKey "happy"
+ 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"
+ Sphinx _ -> fromKey "sphinx-build"
+ Tar _ -> fromKey "tar"
+ Xelatex -> fromKey "xelatex"
+ _ -> 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
+
+-- | Was the path to a given system 'Builder' specified in configuration files?
+isSpecified :: Builder -> Action Bool
+isSpecified = fmap (not . null) . systemBuilderPath
+
+-- | Apply a patch by executing the 'Patch' builder in a given directory.
+applyPatch :: FilePath -> FilePath -> Action ()
+applyPatch dir patch = do
+ let file = dir -/- patch
+ needBuilder Patch
+ path <- builderPath Patch
+ putBuild $ "| Apply patch " ++ file
+ quietly $ cmd [Cwd dir, FileStdin file] [path, "-p0"]
+
+-- | Install a directory.
+installDirectory :: FilePath -> Action ()
+installDirectory dir = do
+ path <- fixAbsolutePathOnWindows =<< setting InstallDir
+ putBuild $ "| Install directory " ++ dir
+ quietly $ cmd path dir
+
+-- | Install data files to a directory and track them.
+installData :: [FilePath] -> FilePath -> Action ()
+installData fs dir = do
+ path <- fixAbsolutePathOnWindows =<< setting InstallData
+ need fs
+ forM_ fs $ \f -> putBuild $ "| Install data " ++ f ++ " to " ++ dir
+ quietly $ cmd path fs dir
+
+-- | Install an executable file to a directory and track it.
+installProgram :: FilePath -> FilePath -> Action ()
+installProgram f dir = do
+ path <- fixAbsolutePathOnWindows =<< setting InstallProgram
+ need [f]
+ putBuild $ "| Install program " ++ f ++ " to " ++ dir
+ quietly $ cmd path f dir
+
+-- | Install an executable script to a directory and track it.
+installScript :: FilePath -> FilePath -> Action ()
+installScript f dir = do
+ path <- fixAbsolutePathOnWindows =<< setting InstallScript
+ need [f]
+ putBuild $ "| Install script " ++ f ++ " to " ++ dir
+ quietly $ cmd path f dir
+
+-- | Create a symbolic link from source file to target file (when symbolic links
+-- are supported) and track the source file.
+linkSymbolic :: FilePath -> FilePath -> Action ()
+linkSymbolic source target = do
+ lns <- setting LnS
+ unless (null lns) $ do
+ need [source] -- Guarantee source is built before printing progress info.
+ let dir = takeDirectory target
+ liftIO $ IO.createDirectoryIfMissing True dir
+ putProgressInfo =<< renderAction "Create symbolic link" source target
+ quietly $ cmd lns source target
diff --git a/hadrian/src/CommandLine.hs b/hadrian/src/CommandLine.hs
new file mode 100644
index 0000000000..1ba38c4850
--- /dev/null
+++ b/hadrian/src/CommandLine.hs
@@ -0,0 +1,137 @@
+module CommandLine (
+ optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple,
+ cmdProgressColour, cmdProgressInfo, cmdSkipConfigure, cmdSplitObjects,
+ cmdInstallDestDir
+ ) where
+
+import Data.Either
+import qualified Data.HashMap.Strict as Map
+import Data.List.Extra
+import Development.Shake hiding (Normal)
+import Hadrian.Utilities
+import System.Console.GetOpt
+import System.Environment
+
+-- | All arguments that can be passed to Hadrian via the command line.
+data CommandLineArgs = CommandLineArgs
+ { flavour :: Maybe String
+ , freeze1 :: Bool
+ , installDestDir :: Maybe String
+ , integerSimple :: Bool
+ , progressColour :: UseColour
+ , progressInfo :: ProgressInfo
+ , skipConfigure :: Bool
+ , splitObjects :: Bool }
+ deriving (Eq, Show)
+
+-- | Default values for 'CommandLineArgs'.
+defaultCommandLineArgs :: CommandLineArgs
+defaultCommandLineArgs = CommandLineArgs
+ { flavour = Nothing
+ , freeze1 = False
+ , installDestDir = Nothing
+ , integerSimple = False
+ , progressColour = Auto
+ , progressInfo = Brief
+ , skipConfigure = False
+ , splitObjects = False }
+
+readFreeze1 :: Either String (CommandLineArgs -> CommandLineArgs)
+readFreeze1 = Right $ \flags -> flags { freeze1 = True }
+
+readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }
+
+readInstallDestDir :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readInstallDestDir ms = Right $ \flags -> flags { installDestDir = ms }
+
+readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs)
+readIntegerSimple = Right $ \flags -> flags { integerSimple = True }
+
+readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readProgressColour ms =
+ maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
+ where
+ go :: String -> Maybe UseColour
+ go "never" = Just Never
+ go "auto" = Just Auto
+ go "always" = Just Always
+ go _ = Nothing
+ set :: UseColour -> CommandLineArgs -> CommandLineArgs
+ set flag flags = flags { progressColour = flag }
+
+readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readProgressInfo ms =
+ maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
+ where
+ go :: String -> Maybe ProgressInfo
+ go "none" = Just None
+ go "brief" = Just Brief
+ go "normal" = Just Normal
+ go "unicorn" = Just Unicorn
+ go _ = Nothing
+ set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
+ set flag flags = flags { progressInfo = flag }
+
+readSkipConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
+readSkipConfigure = Right $ \flags -> flags { skipConfigure = True }
+
+readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
+readSplitObjects = Right $ \flags -> flags { splitObjects = True }
+
+-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
+optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
+optDescrs =
+ [ Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
+ "Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)."
+ , Option [] ["freeze1"] (NoArg readFreeze1)
+ "Freeze Stage1 GHC."
+ , Option [] ["install-destdir"] (OptArg readInstallDestDir "DESTDIR")
+ "Installation destination directory."
+ , Option [] ["integer-simple"] (NoArg readIntegerSimple)
+ "Build GHC with integer-simple library."
+ , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
+ "Use colours in progress info (Never, Auto or Always)."
+ , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
+ "Progress info style (None, Brief, Normal or Unicorn)."
+ , Option [] ["skip-configure"] (NoArg readSkipConfigure)
+ "Skip the boot and configure scripts (if you want to run them manually)."
+ , Option [] ["split-objects"] (NoArg readSplitObjects)
+ "Generate split objects (requires a full clean rebuild)." ]
+
+-- | A type-indexed map containing Hadrian command line arguments to be passed
+-- to Shake via 'shakeExtra'.
+cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic)
+cmdLineArgsMap = do
+ (opts, _, _) <- getOpt Permute optDescrs <$> getArgs
+ let args = foldl (flip id) defaultCommandLineArgs (rights opts)
+ return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
+ $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
+ $ insertExtra args Map.empty
+
+cmdLineArgs :: Action CommandLineArgs
+cmdLineArgs = userSetting defaultCommandLineArgs
+
+cmdFlavour :: Action (Maybe String)
+cmdFlavour = flavour <$> cmdLineArgs
+
+lookupFreeze1 :: Map.HashMap TypeRep Dynamic -> Bool
+lookupFreeze1 = freeze1 . lookupExtra defaultCommandLineArgs
+
+cmdInstallDestDir :: Action (Maybe String)
+cmdInstallDestDir = installDestDir <$> cmdLineArgs
+
+cmdIntegerSimple :: Action Bool
+cmdIntegerSimple = integerSimple <$> cmdLineArgs
+
+cmdProgressColour :: Action UseColour
+cmdProgressColour = progressColour <$> cmdLineArgs
+
+cmdProgressInfo :: Action ProgressInfo
+cmdProgressInfo = progressInfo <$> cmdLineArgs
+
+cmdSkipConfigure :: Action Bool
+cmdSkipConfigure = skipConfigure <$> cmdLineArgs
+
+cmdSplitObjects :: Action Bool
+cmdSplitObjects = splitObjects <$> cmdLineArgs
diff --git a/hadrian/src/Context.hs b/hadrian/src/Context.hs
new file mode 100644
index 0000000000..ad1a2d7295
--- /dev/null
+++ b/hadrian/src/Context.hs
@@ -0,0 +1,158 @@
+module Context (
+ -- * Context
+ Context (..), vanillaContext, stageContext,
+
+ -- * Expressions
+ getStage, getPackage, getWay, getStagedSettingList, getBuildPath,
+ withHsPackage,
+
+ -- * Paths
+ contextDir, buildPath, pkgInplaceConfig, pkgDataFile, pkgSetupConfigFile,
+ pkgHaddockFile, pkgLibraryFile, pkgLibraryFile0, pkgGhciLibraryFile,
+ pkgConfFile, objectPath
+ ) where
+
+import GHC.Generics
+import Hadrian.Expression
+import Hadrian.Haskell.Cabal
+
+import Base
+import Oracles.Setting
+
+-- | Build context for a currently built 'Target'. We generate potentially
+-- different build rules for each 'Context'.
+data Context = Context
+ { stage :: Stage -- ^ Currently build Stage
+ , package :: Package -- ^ Currently build Package
+ , way :: Way -- ^ Currently build Way (usually 'vanilla')
+ } deriving (Eq, Generic, Show)
+
+instance Binary Context
+instance Hashable Context
+instance NFData Context
+
+-- | Most targets are built only one way, hence the notion of 'vanillaContext'.
+vanillaContext :: Stage -> Package -> Context
+vanillaContext s p = Context s p vanilla
+
+-- | Partial context with undefined 'Package' field. Useful for 'Packages'
+-- expressions that only read the environment and current 'Stage'.
+stageContext :: Stage -> Context
+stageContext s = vanillaContext s $ error "stageContext: package not set"
+
+-- | Get the 'Stage' of the current 'Context'.
+getStage :: Expr Context b Stage
+getStage = stage <$> getContext
+
+-- | Get the 'Package' of the current 'Context'.
+getPackage :: Expr Context b Package
+getPackage = package <$> getContext
+
+-- | Get the 'Way' of the current 'Context'.
+getWay :: Expr Context b Way
+getWay = way <$> getContext
+
+-- | Get a list of configuration settings for the current stage.
+getStagedSettingList :: (Stage -> SettingList) -> Args Context b
+getStagedSettingList f = getSettingList . f =<< getStage
+
+-- | Construct an expression that depends on the Cabal file of the current
+-- package and is empty in a non-Haskell context.
+withHsPackage :: (Monoid a, Semigroup a) => (FilePath -> Expr Context b a) -> Expr Context b a
+withHsPackage expr = do
+ pkg <- getPackage
+ case pkgCabalFile pkg of
+ Just file -> expr file
+ Nothing -> mempty
+
+-- | The directory in 'buildRoot' containing build artefacts of a given 'Context'.
+contextDir :: Context -> FilePath
+contextDir Context {..} = stageString stage -/- pkgPath package
+
+-- | Path to the directory containing build artefacts of a given 'Context'.
+buildPath :: Context -> Action FilePath
+buildPath context = buildRoot <&> (-/- contextDir context)
+
+-- | Get the build path of the current 'Context'.
+getBuildPath :: Expr Context b FilePath
+getBuildPath = expr . buildPath =<< getContext
+
+pkgId :: Package -> Action FilePath
+pkgId package = case pkgCabalFile package of
+ Just file -> pkgIdentifier file
+ Nothing -> return (pkgName package) -- Non-Haskell packages, e.g. rts
+
+pkgFile :: Context -> String -> String -> Action FilePath
+pkgFile context@Context {..} prefix suffix = do
+ path <- buildPath context
+ pid <- pkgId package
+ return $ path -/- prefix ++ pid ++ suffix
+
+-- | Path to inplace package configuration file of a given 'Context'.
+pkgInplaceConfig :: Context -> Action FilePath
+pkgInplaceConfig context = do
+ path <- buildPath context
+ return $ path -/- "inplace-pkg-config"
+
+-- | Path to the @package-data.mk@ of a given 'Context'.
+pkgDataFile :: Context -> Action FilePath
+pkgDataFile context = do
+ path <- buildPath context
+ return $ path -/- "package-data.mk"
+
+-- | Path to the @setup-config@ of a given 'Context'.
+pkgSetupConfigFile :: Context -> Action FilePath
+pkgSetupConfigFile context = do
+ path <- buildPath context
+ return $ path -/- "setup-config"
+
+-- | Path to the haddock file of a given 'Context', e.g.:
+-- @_build/stage1/libraries/array/doc/html/array/array.haddock@.
+pkgHaddockFile :: Context -> Action FilePath
+pkgHaddockFile Context {..} = do
+ root <- buildRoot
+ let name = pkgName package
+ return $ root -/- "docs/html/libraries" -/- name -/- name <.> "haddock"
+
+-- | Path to the library file of a given 'Context', e.g.:
+-- @_build/stage1/libraries/array/build/libHSarray-0.5.1.0.a@.
+pkgLibraryFile :: Context -> Action FilePath
+pkgLibraryFile context@Context {..} = do
+ extension <- libsuf way
+ pkgFile context "libHS" extension
+
+-- | Path to the auxiliary library file of a given 'Context', e.g.:
+-- @_build/stage1/compiler/build/libHSghc-8.1-0.a@.
+pkgLibraryFile0 :: Context -> Action FilePath
+pkgLibraryFile0 context@Context {..} = do
+ extension <- libsuf way
+ pkgFile context "libHS" ("-0" ++ extension)
+
+-- | Path to the GHCi library file of a given 'Context', e.g.:
+-- @_build/stage1/libraries/array/build/HSarray-0.5.1.0.o@.
+pkgGhciLibraryFile :: Context -> Action FilePath
+pkgGhciLibraryFile context = pkgFile context "HS" ".o"
+
+-- | Path to the configuration file of a given 'Context'.
+pkgConfFile :: Context -> Action FilePath
+pkgConfFile Context {..} = do
+ root <- buildRoot
+ pid <- pkgId package
+ let dbDir | stage == Stage0 = root -/- stage0PackageDbDir
+ | otherwise = inplacePackageDbPath
+ return $ dbDir -/- pid <.> "conf"
+
+-- | Given a 'Context' and a 'FilePath' to a source file, compute the 'FilePath'
+-- to its object file. For example:
+-- * "Task.c" -> "_build/stage1/rts/Task.thr_o"
+-- * "_build/stage1/rts/cmm/AutoApply.cmm" -> "_build/stage1/rts/cmm/AutoApply.o"
+objectPath :: Context -> FilePath -> Action FilePath
+objectPath context@Context {..} src = do
+ isGenerated <- isGeneratedSource src
+ path <- buildPath context
+ let extension = drop 1 $ takeExtension src
+ obj = src -<.> osuf way
+ result | isGenerated = obj
+ | "*hs*" ?== extension = path -/- obj
+ | otherwise = path -/- extension -/- obj
+ return result
diff --git a/hadrian/src/Environment.hs b/hadrian/src/Environment.hs
new file mode 100644
index 0000000000..de43efa924
--- /dev/null
+++ b/hadrian/src/Environment.hs
@@ -0,0 +1,16 @@
+module Environment (setupEnvironment) where
+
+import System.Environment
+
+-- | The build system invokes many external builders whose behaviour is
+-- influenced by the environment variables. We need to modify some of them
+-- for better robustness of the build system.
+setupEnvironment :: IO ()
+setupEnvironment = do
+ -- ghc-cabal refuses to work when GHC_PACKAGE_PATH is set (e.g. by Stack)
+ unsetEnv "GHC_PACKAGE_PATH"
+
+ -- in MinGW if PWD is set to a Windows "C:\\" style path then configure
+ -- `pwd` will return the Windows path, and then modifying $PATH will fail.
+ -- See https://github.com/snowleopard/hadrian/issues/189 for details.
+ unsetEnv "PWD"
diff --git a/hadrian/src/Expression.hs b/hadrian/src/Expression.hs
new file mode 100644
index 0000000000..7e8220e675
--- /dev/null
+++ b/hadrian/src/Expression.hs
@@ -0,0 +1,123 @@
+module Expression (
+ -- * Expressions
+ Expr, Predicate, Args, Ways,
+
+ -- ** Construction and modification
+ expr, exprIO, arg, remove,
+
+ -- ** Predicates
+ (?), stage, stage0, stage1, stage2, notStage0, package, notPackage,
+ libraryPackage, builder, way, input, inputs, output, outputs,
+
+ -- ** Evaluation
+ interpret, interpretInContext,
+
+ -- * Convenient accessors
+ getBuildRoot, getContext, getPkgData, getPkgDataList, getOutputs, getInputs,
+ getInput, getOutput,
+
+ -- * Re-exports
+ module Base,
+ module Builder,
+ module Context,
+ module GHC
+ ) where
+
+import qualified Hadrian.Expression as H
+import Hadrian.Expression hiding (Expr, Predicate, Args)
+
+import Base
+import Builder
+import GHC
+import Context hiding (stage, package, way)
+import Oracles.PackageData
+
+-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
+-- read parameters of the current build 'Target'.
+type Expr a = H.Expr Context Builder a
+
+-- | The following expressions are used throughout the build system for
+-- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
+-- and 'Packages'.
+type Predicate = H.Predicate Context Builder
+type Args = H.Args Context Builder
+type Ways = Expr [Way]
+
+-- | Get a value from the @package-data.mk@ file of the current context.
+getPkgData :: (FilePath -> PackageData) -> Expr String
+getPkgData key = expr . pkgData . key =<< getBuildPath
+
+-- | Get a list of values from the @package-data.mk@ file of the current context.
+getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
+getPkgDataList key = expr . pkgDataList . key =<< getBuildPath
+
+-- | Is the build currently in the provided stage?
+stage :: Stage -> Predicate
+stage s = (s ==) <$> getStage
+
+-- | Is a particular package being built?
+package :: Package -> Predicate
+package p = (p ==) <$> getPackage
+
+-- | This type class allows the user to construct both precise builder
+-- predicates, such as @builder (Ghc CompileHs Stage1)@, as well as predicates
+-- covering a set of similar builders. For example, @builder (Ghc CompileHs)@
+-- matches any stage, and @builder Ghc@ matches any stage and any GHC mode.
+class BuilderPredicate a where
+ -- | Is a particular builder being used?
+ builder :: a -> Predicate
+
+instance BuilderPredicate Builder where
+ builder b = (b ==) <$> getBuilder
+
+instance BuilderPredicate a => BuilderPredicate (Stage -> a) where
+ builder f = builder . f =<< getStage
+
+instance BuilderPredicate a => BuilderPredicate (CcMode -> a) where
+ builder f = do
+ b <- getBuilder
+ case b of
+ Cc c _ -> builder (f c)
+ _ -> return False
+
+instance BuilderPredicate a => BuilderPredicate (GhcMode -> a) where
+ builder f = do
+ b <- getBuilder
+ case b of
+ Ghc c _ -> builder (f c)
+ _ -> return False
+
+instance BuilderPredicate a => BuilderPredicate (FilePath -> a) where
+ builder f = do
+ b <- getBuilder
+ case b of
+ Configure path -> builder (f path)
+ _ -> return False
+
+-- | Is the current build 'Way' equal to a certain value?
+way :: Way -> Predicate
+way w = (w ==) <$> getWay
+
+-- | Is the build currently in stage 0?
+stage0 :: Predicate
+stage0 = stage Stage0
+
+-- | Is the build currently in stage 1?
+stage1 :: Predicate
+stage1 = stage Stage1
+
+-- | Is the build currently in stage 2?
+stage2 :: Predicate
+stage2 = stage Stage2
+
+-- | Is the build /not/ in stage 0 right now?
+notStage0 :: Predicate
+notStage0 = notM stage0
+
+-- | Is a certain package /not/ built right now?
+notPackage :: Package -> Predicate
+notPackage = notM . package
+
+-- | Is a library package currently being built?
+libraryPackage :: Predicate
+libraryPackage = isLibrary <$> getPackage
diff --git a/hadrian/src/Flavour.hs b/hadrian/src/Flavour.hs
new file mode 100644
index 0000000000..fcbbb70d45
--- /dev/null
+++ b/hadrian/src/Flavour.hs
@@ -0,0 +1,34 @@
+module Flavour (Flavour (..)) where
+
+import Expression
+
+-- Please update doc/{flavours.md, user-settings.md} when changing this file.
+-- | 'Flavour' is a collection of build settings that fully define a GHC build.
+-- Note the following type semantics:
+-- * @Bool@: a plain Boolean flag whose value is known at compile time.
+-- * @Action Bool@: a flag whose value can depend on the build environment.
+-- * @Predicate@: a flag whose value can depend on the build environment and
+-- on the current build target.
+data Flavour = Flavour {
+ -- | Flavour name, to select this flavour from command line.
+ name :: String,
+ -- | Use these command line arguments.
+ args :: Args,
+ -- | Build these packages.
+ packages :: Stage -> Action [Package],
+ -- | Either 'integerGmp' or 'integerSimple'.
+ integerLibrary :: Action Package,
+ -- | Build libraries these ways.
+ libraryWays :: Ways,
+ -- | Build RTS these ways.
+ rtsWays :: Ways,
+ -- | Build split objects.
+ splitObjects :: Predicate,
+ -- | Build dynamic GHC programs.
+ dynamicGhcPrograms :: Bool,
+ -- | Enable GHCi debugger.
+ ghciWithDebugger :: Bool,
+ -- | Build profiled GHC.
+ ghcProfiled :: Bool,
+ -- | Build GHC with debug information.
+ ghcDebugged :: Bool }
diff --git a/hadrian/src/GHC.hs b/hadrian/src/GHC.hs
new file mode 100644
index 0000000000..baae940959
--- /dev/null
+++ b/hadrian/src/GHC.hs
@@ -0,0 +1,289 @@
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+module GHC (
+ -- * GHC packages
+ array, base, binary, bytestring, cabal, compareSizes, compiler, containers,
+ deepseq, deriveConstants, directory, filepath, genapply, genprimopcode, ghc,
+ ghcBoot, ghcBootTh, ghcCabal, ghcCompact, ghci, ghcPkg, ghcPrim, ghcTags,
+ ghcSplit, haddock, haskeline, hsc2hs, hp2ps, 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, ghcPackages, isGhcPackage,
+ defaultPackages,
+
+ -- * Package information
+ programName, nonCabalContext, nonHsMainPackage, autogenPath, installStage,
+
+ -- * Miscellaneous
+ programPath, ghcSplitPath, stripCmdPath, buildDll0
+ ) where
+
+import Base
+import CommandLine
+import Context
+import Oracles.Flag
+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. '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, compareSizes, compiler, containers
+ , deepseq, deriveConstants, directory, filepath, genapply, genprimopcode
+ , ghc, ghcBoot, ghcBootTh, ghcCabal, ghcCompact, ghci, ghcPkg, ghcPrim
+ , ghcTags, haddock, haskeline, hsc2hs, hp2ps, 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 ]
+
+-- TODO: Optimise by switching to sets of packages.
+isGhcPackage :: Package -> Bool
+isGhcPackage = (`elem` ghcPackages)
+
+-- | Package definitions, see 'Package'.
+array = hsLib "array"
+base = hsLib "base"
+binary = hsLib "binary"
+bytestring = hsLib "bytestring"
+cabal = hsLib "Cabal" `setPath` "libraries/Cabal/Cabal"
+compareSizes = hsUtil "compareSizes" `setPath` "utils/compare_sizes"
+compiler = hsTop "ghc" `setPath` "compiler"
+containers = hsLib "containers"
+deepseq = hsLib "deepseq"
+deriveConstants = hsUtil "deriveConstants"
+directory = hsLib "directory"
+filepath = hsLib "filepath"
+genapply = hsUtil "genapply"
+genprimopcode = hsUtil "genprimopcode"
+ghc = hsPrg "ghc-bin" `setPath` "ghc"
+ghcBoot = hsLib "ghc-boot"
+ghcBootTh = hsLib "ghc-boot-th"
+ghcCabal = hsUtil "ghc-cabal"
+ghcCompact = hsLib "ghc-compact"
+ghci = hsLib "ghci"
+ghcPkg = hsUtil "ghc-pkg"
+ghcPrim = hsLib "ghc-prim"
+ghcTags = hsUtil "ghctags"
+ghcSplit = hsUtil "ghc-split"
+haddock = hsUtil "haddock"
+haskeline = hsLib "haskeline"
+hsc2hs = hsUtil "hsc2hs"
+hp2ps = cUtil "hp2ps"
+hpc = hsLib "hpc"
+hpcBin = hsUtil "hpc-bin" `setPath` "utils/hpc"
+integerGmp = hsLib "integer-gmp"
+integerSimple = hsLib "integer-simple"
+iservBin = hsPrg "iserv-bin" `setPath` "iserv"
+libffi = cTop "libffi"
+mtl = hsLib "mtl"
+parsec = hsLib "parsec"
+parallel = hsLib "parallel"
+pretty = hsLib "pretty"
+primitive = hsLib "primitive"
+process = hsLib "process"
+rts = cTop "rts"
+runGhc = hsUtil "runghc"
+stm = hsLib "stm"
+templateHaskell = hsLib "template-haskell"
+terminfo = hsLib "terminfo"
+text = hsLib "text"
+time = hsLib "time"
+touchy = cUtil "touchy"
+transformers = hsLib "transformers"
+unlit = cUtil "unlit"
+unix = hsLib "unix"
+win32 = hsLib "Win32"
+xhtml = hsLib "xhtml"
+
+-- | Construct a Haskell library package, e.g. @array@.
+hsLib :: PackageName -> Package
+hsLib name = hsLibrary name ("libraries" -/- name)
+
+-- | Construct a top-level Haskell library package, e.g. @compiler@.
+hsTop :: PackageName -> Package
+hsTop name = hsLibrary name name
+
+-- | Construct a top-level C library package, e.g. @rts@.
+cTop :: PackageName -> Package
+cTop name = cLibrary name name
+
+-- | Construct a top-level Haskell program package, e.g. @ghc@.
+hsPrg :: PackageName -> Package
+hsPrg name = hsProgram name name
+
+-- | Construct a Haskell utility package, e.g. @haddock@.
+hsUtil :: PackageName -> Package
+hsUtil name = hsProgram name ("utils" -/- name)
+
+-- | Construct a C utility package, e.g. @haddock@.
+cUtil :: PackageName -> Package
+cUtil name = cProgram name ("utils" -/- name)
+
+-- | Amend a package path if it doesn't conform to a typical pattern.
+setPath :: Package -> FilePath -> Package
+setPath pkg path = pkg { pkgPath = path }
+
+-- | Packages that are built by default. You can change this in "UserSettings".
+defaultPackages :: Stage -> Action [Package]
+defaultPackages Stage0 = stage0Packages
+defaultPackages Stage1 = stage1Packages
+defaultPackages Stage2 = stage2Packages
+defaultPackages Stage3 = return []
+
+stage0Packages :: Action [Package]
+stage0Packages = do
+ win <- windowsHost
+ ios <- iosHost
+ cross <- crossCompiling
+ return $ [ binary
+ , cabal
+ , compareSizes
+ , compiler
+ , deriveConstants
+ , genapply
+ , genprimopcode
+ , ghc
+ , ghcBoot
+ , ghcBootTh
+ , ghcCabal
+ , ghci
+ , ghcPkg
+ , ghcTags
+ , hsc2hs
+ , hp2ps
+ , hpc
+ , mtl
+ , parsec
+ , templateHaskell
+ , text
+ , transformers
+ , unlit ]
+ ++ [ terminfo | not win, not ios, not cross ]
+ ++ [ touchy | win ]
+
+stage1Packages :: Action [Package]
+stage1Packages = do
+ win <- windowsHost
+ intSimple <- cmdIntegerSimple
+ libraries0 <- filter isLibrary <$> stage0Packages
+ return $ libraries0 -- Build all Stage0 libraries in Stage1
+ ++ [ array
+ , base
+ , bytestring
+ , containers
+ , deepseq
+ , directory
+ , filepath
+ , ghc
+ , ghcCabal
+ , ghcCompact
+ , ghcPrim
+ , haskeline
+ , hpcBin
+ , hsc2hs
+ , if intSimple then integerSimple else integerGmp
+ , pretty
+ , process
+ , rts
+ , runGhc
+ , stm
+ , time
+ , xhtml ]
+ ++ [ iservBin | not win ]
+ ++ [ unix | not win ]
+ ++ [ win32 | win ]
+
+stage2Packages :: Action [Package]
+stage2Packages = return [haddock]
+
+-- | 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
+-- 'Library', the function simply returns its name.
+programName :: Context -> String
+programName Context {..}
+ | package == ghc = "ghc-stage" ++ show (fromEnum stage + 1)
+ | package == hpcBin = "hpc"
+ | package == runGhc = "runhaskell"
+ | package == iservBin = "ghc-iserv"
+ | otherwise = pkgName package
+
+-- | The build stage whose results are used when installing a package, or
+-- @Nothing@ if the package is not installed, e.g. because it is a user package.
+-- The current implementation installs the /latest/ build stage of a package.
+installStage :: Package -> Action (Maybe Stage)
+installStage pkg
+ | not (isGhcPackage pkg) = return Nothing -- Only GHC packages are installed
+ | otherwise = do
+ stages <- filterM (fmap (pkg `elem`) . defaultPackages) [Stage0 ..]
+ return $ if null stages then Nothing else Just (maximum stages)
+
+-- | Is the program corresponding to a given context built 'inplace', i.e. in
+-- the @inplace/bin@ directory? For most programs, only their /latest/ build
+-- stages are built 'inplace'. The only exception is the GHC itself, which is
+-- built 'inplace' in all stages. The function returns @False@ for libraries and
+-- all user packages.
+isBuiltInplace :: Context -> Action Bool
+isBuiltInplace Context {..}
+ | isLibrary package = return False
+ | not (isGhcPackage package) = return False
+ | package == ghc = return True
+ | otherwise = (Just stage ==) <$> installStage package
+
+-- | The 'FilePath' to a program executable in a given 'Context'.
+programPath :: Context -> Action FilePath
+programPath context@Context {..} = do
+ path <- buildPath context
+ inplace <- isBuiltInplace context
+ let contextPath = if inplace then inplacePath else path
+ return $ contextPath -/- programName context <.> exe
+ where
+ inplacePath | package `elem` [touchy, unlit, iservBin] = inplaceLibBinPath
+ | otherwise = inplaceBinPath
+
+-- | 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').
+nonCabalContext :: Context -> Bool
+nonCabalContext Context {..} = (package `elem` [hp2ps, rts, touchy, unlit])
+ || package == ghcCabal && stage == Stage0
+
+-- | Some program packages should not be linked with Haskell main function.
+nonHsMainPackage :: Package -> Bool
+nonHsMainPackage = (`elem` [ghc, hp2ps, iservBin, touchy, unlit])
+
+-- | Path to the autogen directory generated by @ghc-cabal@ of a given 'Context'.
+autogenPath :: Context -> Action FilePath
+autogenPath context@Context {..}
+ | isLibrary package = autogen "build"
+ | package == ghc = autogen "build/ghc"
+ | package == hpcBin = autogen "build/hpc"
+ | package == iservBin = autogen "build/iserv"
+ | otherwise = autogen $ "build" -/- pkgName package
+ where
+ autogen dir = buildPath context <&> (-/- dir -/- "autogen")
+
+-- | @ghc-split@ is a Perl script used by GHC with @-split-objs@ flag. It is
+-- generated in "Rules.Generators.GhcSplit".
+ghcSplitPath :: FilePath
+ghcSplitPath = inplaceLibBinPath -/- "ghc-split"
+
+-- ref: mk/config.mk
+-- | Command line tool for stripping.
+stripCmdPath :: Action FilePath
+stripCmdPath = do
+ targetPlatform <- setting TargetPlatform
+ top <- topDirectory
+ case targetPlatform of
+ "x86_64-unknown-mingw32" ->
+ return (top -/- "inplace/mingw/bin/strip.exe")
+ "arm-unknown-linux" ->
+ return ":" -- HACK: from the make-based system, see the ref above
+ _ -> return "strip"
+
+buildDll0 :: Context -> Action Bool
+buildDll0 Context {..} = do
+ windows <- windowsHost
+ return $ windows && stage == Stage1 && package == compiler
diff --git a/hadrian/src/Hadrian/Builder.hs b/hadrian/src/Hadrian/Builder.hs
new file mode 100644
index 0000000000..4de658edc3
--- /dev/null
+++ b/hadrian/src/Hadrian/Builder.hs
@@ -0,0 +1,125 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hadrian.Builder
+-- Copyright : (c) Andrey Mokhov 2014-2017
+-- License : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability : experimental
+--
+-- A typical build system invokes several build tools, or /builders/, such as
+-- compilers, linkers, etc., some of which may be built by the build system
+-- itself. This module defines the 'Builder' type class and a few associated
+-- functions that can be used to invoke builders.
+-----------------------------------------------------------------------------
+module Hadrian.Builder (
+ Builder (..), BuildInfo (..), runBuilder, runBuilderWithCmdOptions,
+ build, buildWithResources, buildWithCmdOptions, getBuilderPath,
+ builderEnvironment
+ ) where
+
+import Data.List
+import Development.Shake
+
+import Hadrian.Expression hiding (inputs, outputs)
+import Hadrian.Oracles.ArgsHash
+import Hadrian.Target
+import Hadrian.Utilities
+
+-- | This data structure captures all information relevant to invoking a builder.
+data BuildInfo = BuildInfo {
+ -- | Command line arguments.
+ buildArgs :: [String],
+ -- | Input files.
+ buildInputs :: [FilePath],
+ -- | Output files.
+ buildOutputs :: [FilePath],
+ -- | Options to be passed to Shake's 'cmd' function.
+ buildOptions :: [CmdOption],
+ -- | Resources to be aquired.
+ buildResources :: [(Resource, Int)] }
+
+class ShakeValue b => Builder b where
+ -- | The path to a builder.
+ builderPath :: b -> Action FilePath
+
+ -- | Make sure a builder exists and rebuild it if out of date.
+ needBuilder :: b -> Action ()
+ needBuilder builder = do
+ path <- builderPath builder
+ need [path]
+
+ -- | Run a builder with a given 'BuildInfo'. Also see 'runBuilder'.
+ runBuilderWith :: b -> BuildInfo -> Action ()
+ runBuilderWith builder buildInfo = do
+ let args = buildArgs buildInfo
+ needBuilder builder
+ path <- builderPath builder
+ let msg = if null args then "" else " (" ++ intercalate ", " args ++ ")"
+ putBuild $ "| Run " ++ show builder ++ msg
+ quietly $ cmd (buildOptions buildInfo) [path] args
+
+-- | Run a builder with a specified list of command line arguments, reading a
+-- list of input files and writing a list of output files. A lightweight version
+-- of 'runBuilderWith'.
+runBuilder :: Builder b => b -> [String] -> [FilePath] -> [FilePath] -> Action ()
+runBuilder = runBuilderWithCmdOptions []
+
+-- | Like 'runBuilder' but passes given options to Shake's 'cmd'.
+runBuilderWithCmdOptions :: Builder b => [CmdOption] -> b -> [String] -> [FilePath] -> [FilePath] -> Action ()
+runBuilderWithCmdOptions opts builder args inputs outputs =
+ runBuilderWith builder $ BuildInfo { buildArgs = args
+ , buildInputs = inputs
+ , buildOutputs = outputs
+ , buildOptions = opts
+ , buildResources = [] }
+
+-- | Build a 'Target' using the list of command line arguments computed from a
+-- given 'Args' expression. Force a rebuild if the argument list has changed
+-- since the last build.
+build :: (Builder b, ShakeValue c) => Target c b -> Args c b -> Action ()
+build = buildWith [] []
+
+-- | Like 'build' but acquires necessary resources.
+buildWithResources :: (Builder b, ShakeValue c) => [(Resource, Int)] -> Target c b -> Args c b -> Action ()
+buildWithResources rs = buildWith rs []
+
+-- | Like 'build' but passes given options to Shake's 'cmd'.
+buildWithCmdOptions :: (Builder b, ShakeValue c) => [CmdOption] -> Target c b -> Args c b -> Action ()
+buildWithCmdOptions = buildWith []
+
+buildWith :: (Builder b, ShakeValue c) => [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action ()
+buildWith rs opts target args = do
+ needBuilder (builder target)
+ argList <- interpret target args
+ trackArgsHash target -- Rerun the rule if the hash of argList has changed.
+ putInfo target
+ verbose <- interpret target verboseCommand
+ let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
+ quietlyUnlessVerbose $ runBuilderWith (builder target) $
+ BuildInfo { buildArgs = argList
+ , buildInputs = inputs target
+ , buildOutputs = outputs target
+ , buildOptions = opts
+ , buildResources = rs }
+
+-- | Print out information about the command being executed.
+putInfo :: Show b => Target c b -> Action ()
+putInfo t = putProgressInfo =<< renderAction
+ ("Run " ++ show (builder t)) -- TODO: Bring back contextInfo.
+ (digest $ inputs t)
+ (digest $ outputs t)
+ where
+ digest [] = "none"
+ digest [x] = x
+ digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
+
+-- | Get the path to the current builder.
+getBuilderPath :: Builder b => b -> Expr c b FilePath
+getBuilderPath = expr . builderPath
+
+-- | Write a builder path into a given environment variable.
+builderEnvironment :: Builder b => String -> b -> Action CmdOption
+builderEnvironment variable builder = do
+ needBuilder builder
+ path <- builderPath builder
+ return $ AddEnv variable path
diff --git a/hadrian/src/Hadrian/Builder/Ar.hs b/hadrian/src/Hadrian/Builder/Ar.hs
new file mode 100644
index 0000000000..ad74653db0
--- /dev/null
+++ b/hadrian/src/Hadrian/Builder/Ar.hs
@@ -0,0 +1,68 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hadrian.Builder.Ar
+-- Copyright : (c) Andrey Mokhov 2014-2017
+-- License : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability : experimental
+--
+-- Support for invoking the archiving utility @ar@. We take care not to exceed
+-- the limit on command line length, which differs across supported operating
+-- systems (see 'cmdLineLengthLimit'). We need to handle @ar@ in a special way
+-- because we sometimes archive __a lot__ of files (in the Cabal library, for
+-- example, command line length can reach 2MB!). To work around the limit on the
+-- command line length we pass the list of files to be archived via a temporary
+-- file (see 'runAr'), or alternatively, we split the argument list into chunks
+-- and call @ar@ multiple times, e.g. when passing arguments via a temporary
+-- file is not supported (see 'runArWithoutTempFile').
+-----------------------------------------------------------------------------
+module Hadrian.Builder.Ar (ArMode (..), args, runAr, runArWithoutTempFile) where
+
+import Control.Monad
+import Development.Shake
+import Development.Shake.Classes
+import GHC.Generics
+import Hadrian.Expression
+import Hadrian.Utilities
+
+-- | We support packing and unpacking archives with @ar@.
+data ArMode = Pack | Unpack deriving (Eq, Generic, Show)
+
+instance Binary ArMode
+instance Hashable ArMode
+instance NFData ArMode
+
+-- NOTE: Make sure to appropriately update 'arFlagsCount' when changing 'args'.
+-- | Default command line arguments for invoking the archiving utility @ar@.
+args :: (ShakeValue c, ShakeValue b) => ArMode -> Args c b
+args Pack = mconcat [ arg "q", arg =<< getOutput, getInputs ]
+args Unpack = mconcat [ arg "x", arg =<< getInput ]
+
+-- This count includes "q" and the output file argumentes in 'args'. This is
+-- only relevant for the 'Pack' @ar@ mode.
+arFlagsCount :: Int
+arFlagsCount = 2
+
+-- | Invoke @ar@ given a path to it and a list of arguments. The list of files
+-- to be archived is passed via a temporary file. Passing arguments via a
+-- temporary file is not supported by some versions of @ar@, in which case you
+-- should use 'runArWithoutTempFile' instead.
+runAr :: FilePath -> [String] -> Action ()
+runAr arPath argList = withTempFile $ \tmp -> do
+ writeFile' tmp $ unwords fileArgs
+ cmd [arPath] flagArgs ('@' : tmp)
+ where
+ flagArgs = take arFlagsCount argList
+ fileArgs = drop arFlagsCount argList
+
+-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
+-- will be called multiple times if the list of files to be archived is too
+-- long and doesn't fit into the command line length limit. This function is
+-- typically much slower than 'runAr'.
+runArWithoutTempFile :: FilePath -> [String] -> Action ()
+runArWithoutTempFile arPath argList =
+ forM_ (chunksOfSize cmdLineLengthLimit fileArgs) $ \argsChunk ->
+ unit . cmd [arPath] $ flagArgs ++ argsChunk
+ where
+ flagArgs = take arFlagsCount argList
+ fileArgs = drop arFlagsCount argList
diff --git a/hadrian/src/Hadrian/Builder/Sphinx.hs b/hadrian/src/Hadrian/Builder/Sphinx.hs
new file mode 100644
index 0000000000..44b522c4d3
--- /dev/null
+++ b/hadrian/src/Hadrian/Builder/Sphinx.hs
@@ -0,0 +1,39 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hadrian.Builder.Sphinx
+-- Copyright : (c) Andrey Mokhov 2014-2017
+-- License : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability : experimental
+--
+-- Support for invoking the documentation utility Sphinx.
+-----------------------------------------------------------------------------
+module Hadrian.Builder.Sphinx (SphinxMode (..), args) where
+
+import Development.Shake
+import Development.Shake.Classes
+import GHC.Generics
+import Hadrian.Expression
+import Hadrian.Utilities
+
+-- | Sphinx can be used in three different modes to convert reStructuredText
+-- documents into HTML, LaTeX or Man pages.
+data SphinxMode = Html | Latex | Man deriving (Eq, Generic, Show)
+
+instance Binary SphinxMode
+instance Hashable SphinxMode
+instance NFData SphinxMode
+
+-- | Default command line arguments for invoking the archiving utility @tar@.
+args :: (ShakeValue c, ShakeValue b) => SphinxMode -> Args c b
+args mode = do
+ outPath <- getOutput
+ mconcat [ arg "-b", arg modeString
+ , arg "-d", arg $ outPath -/- (".doctrees-" ++ modeString)
+ , arg =<< getInput
+ , arg outPath ]
+ where
+ modeString = case mode of
+ Html -> "html"
+ Latex -> "latex"
+ Man -> "man"
diff --git a/hadrian/src/Hadrian/Builder/Tar.hs b/hadrian/src/Hadrian/Builder/Tar.hs
new file mode 100644
index 0000000000..d51e3c7bee
--- /dev/null
+++ b/hadrian/src/Hadrian/Builder/Tar.hs
@@ -0,0 +1,40 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hadrian.Builder.Tar
+-- Copyright : (c) Andrey Mokhov 2014-2017
+-- License : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability : experimental
+--
+-- Support for invoking the archiving utility @tar@.
+-----------------------------------------------------------------------------
+module Hadrian.Builder.Tar (TarMode (..), args) where
+
+import Development.Shake
+import Development.Shake.Classes
+import GHC.Generics
+import Hadrian.Expression
+
+-- | Tar can be used to 'Create' an archive or 'Extract' from it.
+data TarMode = Create | Extract deriving (Eq, Generic, Show)
+
+instance Binary TarMode
+instance Hashable TarMode
+instance NFData TarMode
+
+-- | Default command line arguments for invoking the archiving utility @tar@.
+args :: (ShakeValue c, ShakeValue b) => TarMode -> Args c b
+args Create = mconcat
+ [ arg "-c"
+ , output "//*.gz" ? arg "--gzip"
+ , output "//*.bz2" ? arg "--bzip2"
+ , output "//*.xz" ? arg "--xz"
+ , arg "-f", arg =<< getOutput
+ , getInputs ]
+args Extract = mconcat
+ [ arg "-x"
+ , input "*.gz" ? arg "--gzip"
+ , input "*.bz2" ? arg "--bzip2"
+ , input "*.xz" ? arg "--xz"
+ , arg "-f", arg =<< getInput
+ , arg "-C", arg =<< getOutput ]
diff --git a/hadrian/src/Hadrian/Expression.hs b/hadrian/src/Hadrian/Expression.hs
new file mode 100644
index 0000000000..e5c01f8935
--- /dev/null
+++ b/hadrian/src/Hadrian/Expression.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
+module Hadrian.Expression (
+ -- * Expressions
+ Expr, Predicate, Args,
+
+ -- ** Construction and modification
+ expr, exprIO, arg, remove,
+
+ -- ** Predicates
+ (?), input, inputs, output, outputs, VerboseCommand (..), verboseCommand,
+
+ -- ** Evaluation
+ interpret, interpretInContext,
+
+ -- * Convenient accessors
+ getBuildRoot, getContext, getBuilder, getOutputs, getInputs, getInput, getOutput
+ ) where
+
+import Control.Monad.Extra
+import Control.Monad.Trans
+import Control.Monad.Trans.Reader
+import Data.Semigroup
+import Development.Shake
+import Development.Shake.Classes
+
+import qualified Hadrian.Target as Target
+import Hadrian.Target (Target, target)
+import Hadrian.Utilities
+
+-- | 'Expr' @c b a@ is a computation that produces a value of type 'Action' @a@
+-- and can read parameters of the current build 'Target' @c b@.
+newtype Expr c b a = Expr (ReaderT (Target c b) Action a)
+ deriving (Applicative, Functor, Monad)
+
+instance Semigroup a => Semigroup (Expr c b a) where
+ Expr x <> Expr y = Expr $ (<>) <$> x <*> y
+
+-- TODO: The 'Semigroup a' constraint will at some point become redundant.
+instance (Semigroup a, Monoid a) => Monoid (Expr c b a) where
+ mempty = pure mempty
+ mappend = (<>)
+
+-- | Expressions that compute a Boolean value.
+type Predicate c b = Expr c b Bool
+
+-- | Expressions that compute lists of arguments to be passed to builders.
+type Args c b = Expr c b [String]
+
+-- | Lift actions independent from the current build 'Target' into the 'Expr'
+-- monad.
+expr :: Action a -> Expr c b a
+expr = Expr . lift
+
+-- | Lift IO computations independent from the current build 'Target' into the
+-- 'Expr' monad.
+exprIO :: IO a -> Expr c b a
+exprIO = Expr . liftIO
+
+-- | Remove given elements from a list expression.
+remove :: Eq a => [a] -> Expr c b [a] -> Expr c b [a]
+remove xs e = filter (`notElem` xs) <$> e
+
+-- | Add a single argument to 'Args'.
+arg :: String -> Args c b
+arg = pure . pure
+
+-- | Values that can be converted to a 'Predicate'.
+class ToPredicate p c b where
+ toPredicate :: p -> Predicate c b
+
+infixr 3 ?
+
+-- | Apply a predicate to an expression.
+(?) :: (Monoid a, Semigroup a, ToPredicate p c b) => p -> Expr c b a -> Expr c b a
+p ? e = do
+ bool <- toPredicate p
+ if bool then e else mempty
+
+instance ToPredicate Bool c b where
+ toPredicate = pure
+
+instance ToPredicate p c b => ToPredicate (Action p) c b where
+ toPredicate = toPredicate . expr
+
+instance (c ~ c', b ~ b', ToPredicate p c' b') => ToPredicate (Expr c b p) c' b' where
+ toPredicate p = toPredicate =<< p
+
+-- | Interpret a given expression according to the given 'Target'.
+interpret :: Target c b -> Expr c b a -> Action a
+interpret target (Expr e) = runReaderT e target
+
+-- | Interpret a given expression by looking only at the given 'Context'.
+interpretInContext :: c -> Expr c b a -> Action a
+interpretInContext c = interpret $ target c
+ (error "contextOnlyTarget: builder not set")
+ (error "contextOnlyTarget: inputs not set" )
+ (error "contextOnlyTarget: outputs not set")
+
+-- | Get the directory of build results.
+getBuildRoot :: Expr c b FilePath
+getBuildRoot = expr buildRoot
+
+-- | Get the current build 'Context'.
+getContext :: Expr c b c
+getContext = Expr $ asks Target.context
+
+-- | Get the 'Builder' for the current 'Target'.
+getBuilder :: Expr c b b
+getBuilder = Expr $ asks Target.builder
+
+-- | Get the input files of the current 'Target'.
+getInputs :: Expr c b [FilePath]
+getInputs = Expr $ asks Target.inputs
+
+-- | Run 'getInputs' and check that the result contains one input file only.
+getInput :: (Show b, Show c) => Expr c b FilePath
+getInput = Expr $ do
+ target <- ask
+ fromSingleton ("Exactly one input file expected in " ++ show target) <$>
+ asks Target.inputs
+
+-- | Get the files produced by the current 'Target'.
+getOutputs :: Expr c b [FilePath]
+getOutputs = Expr $ asks Target.outputs
+
+-- | Run 'getOutputs' and check that the result contains one output file only.
+getOutput :: (Show b, Show c) => Expr c b FilePath
+getOutput = Expr $ do
+ target <- ask
+ fromSingleton ("Exactly one output file expected in " ++ show target) <$>
+ asks Target.outputs
+
+-- | Does any of the input files match a given pattern?
+input :: FilePattern -> Predicate c b
+input f = any (f ?==) <$> getInputs
+
+-- | Does any of the input files match any of the given patterns?
+inputs :: [FilePattern] -> Predicate c b
+inputs = anyM input
+
+-- | Does any of the output files match a given pattern?
+output :: FilePattern -> Predicate c b
+output f = any (f ?==) <$> getOutputs
+
+-- | Does any of the output files match any of the given patterns?
+outputs :: [FilePattern] -> Predicate c b
+outputs = anyM output
+
+newtype VerboseCommand c b = VerboseCommand { predicate :: Predicate c b }
+ deriving Typeable
+
+verboseCommand :: (ShakeValue c, ShakeValue b) => Predicate c b
+verboseCommand = predicate =<< expr (userSetting . VerboseCommand $ return False)
diff --git a/hadrian/src/Hadrian/Haskell/Cabal.hs b/hadrian/src/Hadrian/Haskell/Cabal.hs
new file mode 100644
index 0000000000..ab5f334f9b
--- /dev/null
+++ b/hadrian/src/Hadrian/Haskell/Cabal.hs
@@ -0,0 +1,44 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hadrian.Haskell.Cabal
+-- Copyright : (c) Andrey Mokhov 2014-2017
+-- License : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability : experimental
+--
+-- Basic functionality for extracting Haskell package metadata stored in
+-- Cabal files.
+-----------------------------------------------------------------------------
+module Hadrian.Haskell.Cabal (
+ pkgVersion, pkgIdentifier, pkgDependencies, pkgSynopsis
+ ) where
+
+import Development.Shake
+
+import Hadrian.Haskell.Cabal.Parse
+import Hadrian.Package
+import Hadrian.Oracles.TextFile
+
+-- | Read a Cabal file and return the package version. The Cabal file is tracked.
+pkgVersion :: FilePath -> Action String
+pkgVersion cabalFile = version <$> readCabalFile cabalFile
+
+-- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0@.
+-- The Cabal file is tracked.
+pkgIdentifier :: FilePath -> Action String
+pkgIdentifier cabalFile = do
+ cabal <- readCabalFile cabalFile
+ return $ if null (version cabal)
+ then name cabal
+ else name cabal ++ "-" ++ version cabal
+
+-- | Read a Cabal file and return the sorted list of the package dependencies.
+-- The current version does not take care of Cabal conditionals and therefore
+-- returns a crude overapproximation of actual dependencies. The Cabal file is
+-- tracked.
+pkgDependencies :: FilePath -> Action [PackageName]
+pkgDependencies cabalFile = dependencies <$> readCabalFile cabalFile
+
+-- | Read a Cabal file and return the package synopsis. The Cabal file is tracked.
+pkgSynopsis :: FilePath -> Action String
+pkgSynopsis cabalFile = synopsis <$> readCabalFile cabalFile
diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
new file mode 100644
index 0000000000..578eeacc52
--- /dev/null
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
@@ -0,0 +1,63 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hadrian.Haskell.Cabal.Parse
+-- Copyright : (c) Andrey Mokhov 2014-2017
+-- License : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability : experimental
+--
+-- Extracting Haskell package metadata stored in Cabal files.
+-----------------------------------------------------------------------------
+module Hadrian.Haskell.Cabal.Parse (Cabal (..), parseCabal) where
+
+import Data.List.Extra
+import Development.Shake
+import Development.Shake.Classes
+import qualified Distribution.Package as C
+import qualified Distribution.PackageDescription as C
+import qualified Distribution.PackageDescription.Parse as C
+import qualified Distribution.Text as C
+import qualified Distribution.Types.CondTree as C
+import qualified Distribution.Verbosity as C
+
+import Hadrian.Package
+
+-- TODO: Use fine-grain tracking instead of tracking the whole Cabal file.
+-- | Haskell package metadata extracted from a Cabal file.
+data Cabal = Cabal
+ { dependencies :: [PackageName]
+ , name :: PackageName
+ , synopsis :: String
+ , version :: String
+ } deriving (Eq, Read, Show, Typeable)
+
+instance Binary Cabal where
+ put = put . show
+ get = fmap read get
+
+instance Hashable Cabal where
+ hashWithSalt salt = hashWithSalt salt . show
+
+instance NFData Cabal where
+ rnf (Cabal a b c d) = a `seq` b `seq` c `seq` d `seq` ()
+
+-- | Parse a Cabal file.
+parseCabal :: FilePath -> IO Cabal
+parseCabal file = do
+ gpd <- liftIO $ C.readGenericPackageDescription C.silent file
+ let pd = C.packageDescription gpd
+ pkgId = C.package pd
+ name = C.unPackageName (C.pkgName pkgId)
+ version = C.display (C.pkgVersion pkgId)
+ libDeps = collectDeps (C.condLibrary gpd)
+ exeDeps = map (collectDeps . Just . snd) (C.condExecutables gpd)
+ allDeps = concat (libDeps : exeDeps)
+ sorted = sort [ C.unPackageName p | C.Dependency p _ <- allDeps ]
+ deps = nubOrd sorted \\ [name]
+ return $ Cabal deps name (C.synopsis pd) version
+
+collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency]
+collectDeps Nothing = []
+collectDeps (Just (C.CondNode _ deps ifs)) = deps ++ concatMap f ifs
+ where
+ f (C.CondBranch _ t mt) = collectDeps (Just t) ++ collectDeps mt
diff --git a/hadrian/src/Hadrian/Oracles/ArgsHash.hs b/hadrian/src/Hadrian/Oracles/ArgsHash.hs
new file mode 100644
index 0000000000..bae2fdbd80
--- /dev/null
+++ b/hadrian/src/Hadrian/Oracles/ArgsHash.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Oracles.ArgsHash (
+ TrackArgument, trackAllArguments, trackArgsHash, argsHashOracle
+ ) where
+
+import Control.Monad
+import Development.Shake
+import Development.Shake.Classes
+
+import Hadrian.Expression hiding (inputs, outputs)
+import Hadrian.Target
+
+-- | 'TrackArgument' is used to specify the arguments that should be tracked by
+-- the @ArgsHash@ oracle. The safest option is to track all arguments, but some
+-- arguments, such as @-jN@, do not change the build results, hence there is no
+-- need to initiate unnecessary rebuild if they are added to or removed from a
+-- command line. If all arguments should be tracked, use 'trackAllArguments'.
+type TrackArgument c b = Target c b -> String -> Bool
+
+-- | Returns 'True' for all targets and arguments, hence can be used a safe
+-- default for 'argsHashOracle'.
+trackAllArguments :: TrackArgument c b
+trackAllArguments _ _ = True
+
+-- | Given a 'Target' this 'Action' determines the corresponding argument list
+-- and computes its hash. The resulting value is tracked in a Shake oracle,
+-- hence initiating rebuilds when the hash changes (a hash change indicates
+-- changes in the build command for the given target).
+-- Note: for efficiency we replace the list of input files with its hash to
+-- avoid storing long lists of source files passed to some builders (e.g. ar)
+-- in the Shake database. This optimisation is normally harmless, because
+-- argument list constructors are assumed not to examine target sources, but
+-- only append them to argument lists where appropriate.
+trackArgsHash :: (ShakeValue c, ShakeValue b) => Target c b -> Action ()
+trackArgsHash t = do
+ let hashedInputs = [ show $ hash (inputs t) ]
+ hashedTarget = target (context t) (builder t) hashedInputs (outputs t)
+ void (askOracle $ ArgsHash hashedTarget :: Action Int)
+
+newtype ArgsHash c b = ArgsHash (Target c b)
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult (ArgsHash c b) = Int
+
+-- | This oracle stores per-target argument list hashes in the Shake database,
+-- allowing the user to track them between builds using 'trackArgsHash' queries.
+argsHashOracle :: (ShakeValue c, ShakeValue b) => TrackArgument c b -> Args c b -> Rules ()
+argsHashOracle trackArgument args = void $
+ addOracle $ \(ArgsHash target) -> do
+ argList <- interpret target args
+ let trackedArgList = filter (trackArgument target) argList
+ return $ hash trackedArgList
diff --git a/hadrian/src/Hadrian/Oracles/DirectoryContents.hs b/hadrian/src/Hadrian/Oracles/DirectoryContents.hs
new file mode 100644
index 0000000000..f302af9da0
--- /dev/null
+++ b/hadrian/src/Hadrian/Oracles/DirectoryContents.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Oracles.DirectoryContents (
+ directoryContents, copyDirectoryContents, directoryContentsOracle, copyDirectoryContentsUntracked,
+ Match (..), matches, matchAll
+ ) where
+
+import Control.Monad
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import GHC.Generics
+
+import Hadrian.Utilities
+
+import qualified System.Directory.Extra as IO
+
+data Match = Test FilePattern | Not Match | And [Match] | Or [Match]
+ deriving (Generic, Eq, Show, Typeable)
+
+instance Binary Match
+instance Hashable Match
+instance NFData Match
+
+-- | A 'Match' expression that always evaluates to 'True' (i.e. always matches).
+matchAll :: Match
+matchAll = And []
+
+-- | Check if a file name matches a given 'Match' expression.
+matches :: Match -> FilePath -> Bool
+matches (Test p) f = p ?== f
+matches (Not m) f = not $ matches m f
+matches (And ms) f = all (`matches` f) ms
+matches (Or ms) f = any (`matches` f) ms
+
+-- | Given a 'Match' expression and a directory, recursively traverse it and all
+-- its subdirectories to find and return all matching contents.
+directoryContents :: Match -> FilePath -> Action [FilePath]
+directoryContents expr dir = askOracle $ DirectoryContents (expr, dir)
+
+-- | Copy the contents of the source directory that matches a given 'Match'
+-- expression into the target directory. The copied contents is tracked.
+copyDirectoryContents :: Match -> FilePath -> FilePath -> Action ()
+copyDirectoryContents expr source target = do
+ putProgressInfo =<< renderAction "Copy directory contents" source target
+ let cp file = copyFile file $ target -/- makeRelative source file
+ mapM_ cp =<< directoryContents expr source
+
+-- | Copy the contents of the source directory that matches a given 'Match'
+-- expression into the target directory. The copied contents is untracked.
+copyDirectoryContentsUntracked :: Match -> FilePath -> FilePath -> Action ()
+copyDirectoryContentsUntracked expr source target = do
+ putProgressInfo =<< renderAction "Copy directory contents (untracked)" source target
+ let cp file = copyFileUntracked file $ target -/- makeRelative source file
+ mapM_ cp =<< directoryContents expr source
+
+newtype DirectoryContents = DirectoryContents (Match, FilePath)
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult DirectoryContents = [FilePath]
+
+-- | This oracle answers 'directoryContents' queries and tracks the results.
+directoryContentsOracle :: Rules ()
+directoryContentsOracle = void $
+ addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath .
+ filter (matches expr) <$> IO.listFilesInside (return . matches expr) dir
diff --git a/hadrian/src/Hadrian/Oracles/Path.hs b/hadrian/src/Hadrian/Oracles/Path.hs
new file mode 100644
index 0000000000..ceccc23db2
--- /dev/null
+++ b/hadrian/src/Hadrian/Oracles/Path.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Oracles.Path (
+ lookupInPath, bashPath, fixAbsolutePathOnWindows, pathOracle
+ ) where
+
+import Control.Monad
+import Data.Maybe
+import Data.Char
+import Data.List.Extra
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import System.Directory
+import System.Info.Extra
+
+import Hadrian.Utilities
+
+-- | Lookup a specified 'FilePath' in the system @PATH@.
+lookupInPath :: FilePath -> Action FilePath
+lookupInPath name
+ | name == takeFileName name = askOracle $ LookupInPath name
+ | otherwise = return name
+
+-- | Lookup the path to the @bash@ interpreter.
+bashPath :: Action FilePath
+bashPath = lookupInPath "bash"
+
+-- | Fix an absolute path on Windows:
+-- * "/c/" => "C:/"
+-- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
+fixAbsolutePathOnWindows :: FilePath -> Action FilePath
+fixAbsolutePathOnWindows path =
+ if isWindows
+ then do
+ let (dir, file) = splitFileName path
+ winDir <- askOracle $ WindowsPath dir
+ return $ winDir -/- file
+ else
+ return path
+
+newtype LookupInPath = LookupInPath String
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult LookupInPath = String
+
+newtype WindowsPath = WindowsPath FilePath
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult WindowsPath = String
+
+-- | Oracles for looking up paths. These are slow and require caching.
+pathOracle :: Rules ()
+pathOracle = do
+ void $ addOracle $ \(WindowsPath path) -> do
+ Stdout out <- quietly $ cmd ["cygpath", "-m", path]
+ let windowsPath = unifyPath $ dropWhileEnd isSpace out
+ putLoud $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath
+ return windowsPath
+
+ void $ addOracle $ \(LookupInPath name) -> do
+ let unpack = fromMaybe . error $ "Cannot find executable " ++ quote name
+ path <- unifyPath . unpack <$> liftIO (findExecutable name)
+ putLoud $ "| Executable found: " ++ name ++ " => " ++ path
+ return path
diff --git a/hadrian/src/Hadrian/Oracles/TextFile.hs b/hadrian/src/Hadrian/Oracles/TextFile.hs
new file mode 100644
index 0000000000..6d4f048c7d
--- /dev/null
+++ b/hadrian/src/Hadrian/Oracles/TextFile.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hadrian.Oracles.TextFile
+-- Copyright : (c) Andrey Mokhov 2014-2017
+-- License : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability : experimental
+--
+-- Read and parse text files, tracking their contents. This oracle can be used
+-- to read configuration or package metadata files and cache the parsing.
+-----------------------------------------------------------------------------
+module Hadrian.Oracles.TextFile (
+ readTextFile, lookupValue, lookupValueOrEmpty, lookupValueOrError,
+ lookupValues, lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies,
+ readCabalFile, textFileOracle
+ ) where
+
+import Control.Monad
+import qualified Data.HashMap.Strict as Map
+import Data.Maybe
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.Config
+
+import Hadrian.Haskell.Cabal.Parse
+import Hadrian.Utilities
+
+newtype TextFile = TextFile FilePath
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult TextFile = String
+
+newtype CabalFile = CabalFile FilePath
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult CabalFile = Cabal
+
+newtype KeyValue = KeyValue (FilePath, String)
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult KeyValue = Maybe String
+
+newtype KeyValues = KeyValues (FilePath, String)
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult KeyValues = Maybe [String]
+
+-- | Read a text file, caching and tracking the result. To read and track
+-- individual lines of a text file use 'lookupValue' and its derivatives.
+readTextFile :: FilePath -> Action String
+readTextFile = askOracle . TextFile
+
+-- | Lookup a value in a text file, tracking the result. Each line of the file
+-- is expected to have @key = value@ format.
+lookupValue :: FilePath -> String -> Action (Maybe String)
+lookupValue file key = askOracle $ KeyValue (file, key)
+
+-- | Like 'lookupValue' but returns the empty string if the key is not found.
+lookupValueOrEmpty :: FilePath -> String -> Action String
+lookupValueOrEmpty file key = fromMaybe "" <$> lookupValue file key
+
+-- | Like 'lookupValue' but raises an error if the key is not found.
+lookupValueOrError :: FilePath -> String -> Action String
+lookupValueOrError file key = fromMaybe (error msg) <$> lookupValue file key
+ where
+ msg = "Key " ++ quote key ++ " not found in file " ++ quote file
+
+-- | Lookup a list of values in a text file, tracking the result. Each line of
+-- the file is expected to have @key value1 value2 ...@ format.
+lookupValues :: FilePath -> String -> Action (Maybe [String])
+lookupValues file key = askOracle $ KeyValues (file, key)
+
+-- | Like 'lookupValues' but returns the empty list if the key is not found.
+lookupValuesOrEmpty :: FilePath -> String -> Action [String]
+lookupValuesOrEmpty file key = fromMaybe [] <$> lookupValues file key
+
+-- | Like 'lookupValues' but raises an error if the key is not found.
+lookupValuesOrError :: FilePath -> String -> Action [String]
+lookupValuesOrError file key = fromMaybe (error msg) <$> lookupValues file key
+ where
+ msg = "Key " ++ quote key ++ " not found in file " ++ quote file
+
+-- | The 'Action' @lookupDependencies depFile file@ looks up dependencies of a
+-- @file@ in a (typically generated) dependency file @depFile@. The action
+-- returns a pair @(source, files)@, such that the @file@ can be produced by
+-- compiling @source@, which in turn also depends on a number of other @files@.
+lookupDependencies :: FilePath -> FilePath -> Action (FilePath, [FilePath])
+lookupDependencies depFile file = do
+ deps <- lookupValues depFile file
+ case deps of
+ Nothing -> error $ "No dependencies found for file " ++ quote file
+ Just [] -> error $ "No source file found for file " ++ quote file
+ Just (source : files) -> return (source, files)
+
+-- | Read and parse a @.cabal@ file, caching and tracking the result.
+readCabalFile :: FilePath -> Action Cabal
+readCabalFile = askOracle . CabalFile
+
+-- | This oracle reads and parses text files to answer 'readTextFile' and
+-- 'lookupValue' queries, as well as their derivatives, tracking the results.
+textFileOracle :: Rules ()
+textFileOracle = do
+ text <- newCache $ \file -> do
+ need [file]
+ putLoud $ "| TextFile oracle: reading " ++ quote file ++ "..."
+ liftIO $ readFile file
+ void $ addOracle $ \(TextFile file) -> text file
+
+ kv <- newCache $ \file -> do
+ need [file]
+ putLoud $ "| KeyValue oracle: reading " ++ quote file ++ "..."
+ liftIO $ readConfigFile file
+ void $ addOracle $ \(KeyValue (file, key)) -> Map.lookup key <$> kv file
+
+ kvs <- newCache $ \file -> do
+ need [file]
+ putLoud $ "| KeyValues oracle: reading " ++ quote file ++ "..."
+ contents <- map words <$> readFileLines file
+ return $ Map.fromList [ (key, values) | (key:values) <- contents ]
+ void $ addOracle $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file
+
+ cabal <- newCache $ \file -> do
+ need [file]
+ putLoud $ "| CabalFile oracle: reading " ++ quote file ++ "..."
+ liftIO $ parseCabal file
+ void $ addOracle $ \(CabalFile file) -> cabal file
diff --git a/hadrian/src/Hadrian/Package.hs b/hadrian/src/Hadrian/Package.hs
new file mode 100644
index 0000000000..11a6998f65
--- /dev/null
+++ b/hadrian/src/Hadrian/Package.hs
@@ -0,0 +1,120 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hadrian.Package
+-- Copyright : (c) Andrey Mokhov 2014-2017
+-- License : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability : experimental
+--
+-- A /package/ is a collection of files. We currently only support C and Haskell
+-- packages and treat a package as either a library or a program. The latter is
+-- a gross oversimplification as, for example, Haskell packages can be both.
+-- This works for now, but should be improved in future.
+-----------------------------------------------------------------------------
+module Hadrian.Package (
+ -- * Data types
+ Package (..), PackageName, PackageLanguage, PackageType,
+
+ -- * Construction and properties
+ cLibrary, cProgram, hsLibrary, hsProgram,
+ isLibrary, isProgram, isCPackage, isHsPackage,
+
+ -- * Package directory structure
+ pkgCabalFile, unsafePkgCabalFile
+ ) where
+
+import Data.Maybe
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import GHC.Generics
+import GHC.Stack
+import Hadrian.Utilities
+
+data PackageLanguage = C | Haskell deriving (Generic, Show)
+
+-- TODO: Make PackageType more precise.
+-- See https://github.com/snowleopard/hadrian/issues/12.
+data PackageType = Library | Program deriving (Generic, Show)
+
+type PackageName = String
+
+-- TODO: Consider turning Package into a GADT indexed with language and type.
+data Package = Package {
+ -- | The package language. 'C' and 'Haskell' packages are supported.
+ pkgLanguage :: PackageLanguage,
+ -- | The package type. 'Library' and 'Program' packages are supported.
+ pkgType :: PackageType,
+ -- | The package name. We assume that all packages have different names,
+ -- hence two packages with the same name are considered equal.
+ pkgName :: PackageName,
+ -- | The path to the package source code relative to the root of the build
+ -- system. For example, @libraries/Cabal/Cabal@ and @ghc@ are paths to the
+ -- @Cabal@ and @ghc-bin@ packages in GHC.
+ pkgPath :: FilePath
+ } deriving (Generic, Show)
+
+instance Eq Package where
+ p == q = pkgName p == pkgName q
+
+instance Ord Package where
+ compare p q = compare (pkgName p) (pkgName q)
+
+instance Binary PackageLanguage
+instance Hashable PackageLanguage
+instance NFData PackageLanguage
+
+instance Binary PackageType
+instance Hashable PackageType
+instance NFData PackageType
+
+instance Binary Package
+instance Hashable Package
+instance NFData Package
+
+-- | Construct a C library package.
+cLibrary :: PackageName -> FilePath -> Package
+cLibrary = Package C Library
+
+-- | Construct a C program package.
+cProgram :: PackageName -> FilePath -> Package
+cProgram = Package C Program
+
+-- | Construct a Haskell library package.
+hsLibrary :: PackageName -> FilePath -> Package
+hsLibrary = Package Haskell Library
+
+-- | Construct a Haskell program package.
+hsProgram :: PackageName -> FilePath -> Package
+hsProgram = Package Haskell Program
+
+-- | Is this a library package?
+isLibrary :: Package -> Bool
+isLibrary (Package _ Library _ _) = True
+isLibrary _ = False
+
+-- | Is this a program package?
+isProgram :: Package -> Bool
+isProgram (Package _ Program _ _) = True
+isProgram _ = False
+
+-- | Is this a C package?
+isCPackage :: Package -> Bool
+isCPackage (Package C _ _ _) = True
+isCPackage _ = False
+
+-- | Is this a Haskell package?
+isHsPackage :: Package -> Bool
+isHsPackage (Package Haskell _ _ _) = True
+isHsPackage _ = False
+
+-- | The path to the Cabal file of a Haskell package, e.g. @ghc/ghc-bin.cabal@,
+-- or @Nothing@ if the argument is not a Haskell package.
+pkgCabalFile :: Package -> Maybe FilePath
+pkgCabalFile p | isHsPackage p = Just $ pkgPath p -/- pkgName p <.> "cabal"
+ | otherwise = Nothing
+
+-- | Like 'pkgCabalFile' but raises an error on a non-Haskell package.
+unsafePkgCabalFile :: HasCallStack => Package -> FilePath
+unsafePkgCabalFile p = fromMaybe (error msg) (pkgCabalFile p)
+ where
+ msg = "[unsafePkgCabalFile] Not a Haskell package: " ++ show p
diff --git a/hadrian/src/Hadrian/Target.hs b/hadrian/src/Hadrian/Target.hs
new file mode 100644
index 0000000000..88489776c0
--- /dev/null
+++ b/hadrian/src/Hadrian/Target.hs
@@ -0,0 +1,29 @@
+module Hadrian.Target (Target, target, context, builder, inputs, outputs) where
+
+import Development.Shake.Classes
+import GHC.Generics
+
+-- | Each invocation of a builder is fully described by a 'Target', which
+-- comprises a build context (type variable @c@), a builder (type variable @b@),
+-- a list of input files and a list of output files. For example:
+--
+-- @
+-- preludeTarget = Target (GHC.Context) (GHC.Builder)
+-- { context = Context Stage1 base profiling
+-- , builder = Ghc Stage1
+-- , inputs = ["libraries/base/Prelude.hs"]
+-- , outputs = ["build/stage1/libraries/base/Prelude.p_o"] }
+-- @
+data Target c b = Target
+ { context :: c -- ^ Current build context
+ , builder :: b -- ^ Builder to be invoked
+ , inputs :: [FilePath] -- ^ Input files for the builder
+ , outputs :: [FilePath] -- ^ Files to be produced
+ } deriving (Eq, Generic, Show)
+
+target :: c -> b -> [FilePath] -> [FilePath] -> Target c b
+target = Target
+
+instance (Binary c, Binary b) => Binary (Target c b)
+instance (Hashable c, Hashable b) => Hashable (Target c b)
+instance (NFData c, NFData b) => NFData (Target c b)
diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs
new file mode 100644
index 0000000000..1cd22b1179
--- /dev/null
+++ b/hadrian/src/Hadrian/Utilities.hs
@@ -0,0 +1,406 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Utilities (
+ -- * List manipulation
+ fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
+
+ -- * String manipulation
+ quote, yesNo,
+
+ -- * FilePath manipulation
+ unifyPath, (-/-),
+
+ -- * Accessing Shake's type-indexed map
+ insertExtra, lookupExtra, userSetting,
+
+ -- * Paths
+ BuildRoot (..), buildRoot, isGeneratedSource,
+
+ -- * File system operations
+ copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
+ createDirectory, copyDirectory, moveDirectory, removeDirectory,
+
+ -- * Diagnostic info
+ UseColour (..), putColoured, BuildProgressColour (..), putBuild,
+ SuccessColour (..), putSuccess, ProgressInfo (..),
+ putProgressInfo, renderAction, renderProgram, renderLibrary, renderBox,
+ renderUnicorn,
+
+ -- * Miscellaneous
+ (<&>), (%%>), cmdLineLengthLimit,
+
+ -- * Useful re-exports
+ Dynamic, fromDynamic, toDyn, TypeRep, typeOf
+ ) where
+
+import Control.Monad.Extra
+import Data.Char
+import Data.Dynamic (Dynamic, fromDynamic, toDyn)
+import Data.HashMap.Strict (HashMap)
+import Data.List.Extra
+import Data.Maybe
+import Data.Typeable (TypeRep, typeOf)
+import Development.Shake hiding (Normal)
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import System.Console.ANSI
+import System.Info.Extra
+
+import qualified Control.Exception.Base as IO
+import qualified Data.HashMap.Strict as Map
+import qualified System.Directory.Extra as IO
+import qualified System.Info.Extra as IO
+import qualified System.IO as IO
+
+-- | Extract a value from a singleton list, or terminate with an error message
+-- if the list does not contain exactly one value.
+fromSingleton :: String -> [a] -> a
+fromSingleton _ [res] = res
+fromSingleton msg _ = error msg
+
+-- | Find and replace all occurrences of a value in a list.
+replaceEq :: Eq a => a -> a -> [a] -> [a]
+replaceEq from to = map (\cur -> if cur == from then to else cur)
+
+-- Explicit definition to avoid dependency on Data.List.Ordered
+-- | Difference of two ordered lists.
+minusOrd :: Ord a => [a] -> [a] -> [a]
+minusOrd [] _ = []
+minusOrd xs [] = xs
+minusOrd (x:xs) (y:ys) = case compare x y of
+ LT -> x : minusOrd xs (y:ys)
+ EQ -> minusOrd xs ys
+ GT -> minusOrd (x:xs) ys
+
+-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
+-- | Intersection of two ordered lists by a predicate.
+intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
+intersectOrd cmp = loop
+ where
+ loop [] _ = []
+ loop _ [] = []
+ loop (x:xs) (y:ys) = case cmp x y of
+ LT -> loop xs (y:ys)
+ EQ -> x : loop xs (y:ys)
+ GT -> loop (x:xs) ys
+
+-- | Lookup all elements of a given sorted list in a given sorted dictionary.
+-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
+-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
+--
+-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
+-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
+lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
+lookupAll [] _ = []
+lookupAll (_:xs) [] = Nothing : lookupAll xs []
+lookupAll (x:xs) (y:ys) = case compare x (fst y) of
+ LT -> Nothing : lookupAll xs (y:ys)
+ EQ -> Just (snd y) : lookupAll xs (y:ys)
+ GT -> lookupAll (x:xs) ys
+
+-- | @chunksOfSize size strings@ splits a given list of strings into chunks not
+-- exceeding the given @size@. If that is impossible, it uses singleton chunks.
+chunksOfSize :: Int -> [String] -> [[String]]
+chunksOfSize n = repeatedly f
+ where
+ f xs = splitAt (max 1 $ length $ takeWhile (<= n) $ scanl1 (+) $ map length xs) xs
+
+-- | Add single quotes around a String.
+quote :: String -> String
+quote s = "'" ++ s ++ "'"
+
+-- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string.
+yesNo :: Bool -> String
+yesNo True = "YES"
+yesNo False = "NO"
+
+-- | Normalise a path and convert all path separators to @/@, even on Windows.
+unifyPath :: FilePath -> FilePath
+unifyPath = toStandard . normaliseEx
+
+-- | Combine paths with a forward slash regardless of platform.
+(-/-) :: FilePath -> FilePath -> FilePath
+"" -/- b = b
+a -/- b
+ | last a == '/' = a ++ b
+ | otherwise = a ++ '/' : b
+
+infixr 6 -/-
+
+-- | Like Shake's '%>' but gives higher priority to longer patterns. Useful
+-- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@
+-- can be matched by the same file, such as @library_p.a@. We break the tie
+-- by preferring longer matches, which correpond to longer patterns.
+(%%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
+p %%> a = priority (fromIntegral (length p) + 1) $ p %> a
+
+infix 1 %%>
+
+-- | Build command lines can get very long; for example, when building the Cabal
+-- library, they can reach 2MB! Some operating systems do not support command
+-- lines of such length, and this function can be used to obtain a reasonable
+-- approximation of the limit. On Windows, it is theoretically 32768 characters
+-- (since Windows 7). In practice we use 31000 to leave some breathing space for
+-- the builder path & name, auxiliary flags, and other overheads. On Mac OS X,
+-- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over
+-- 20000. Hence, 200000 seems like a sensible limit. On other operating systems
+-- we currently use the 4194304 setting.
+cmdLineLengthLimit :: Int
+cmdLineLengthLimit | isWindows = 31000
+ | isMac = 200000
+ | otherwise = 4194304
+
+-- | Insert a value into Shake's type-indexed map.
+insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
+insertExtra value = Map.insert (typeOf value) (toDyn value)
+
+-- | Lookup a value in Shake's type-indexed map.
+lookupExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> a
+lookupExtra defaultValue extra = fromMaybe defaultValue maybeValue
+ where
+ maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra
+
+-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
+-- setting is not found, return the provided default value instead.
+userSetting :: Typeable a => a -> Action a
+userSetting defaultValue = do
+ extra <- shakeExtra <$> getShakeOptions
+ return $ lookupExtra defaultValue extra
+
+newtype BuildRoot = BuildRoot FilePath deriving Typeable
+
+-- | All build results are put into the 'buildRoot' directory.
+buildRoot :: Action FilePath
+buildRoot = do
+ BuildRoot path <- userSetting (BuildRoot "")
+ return path
+
+-- | A version of 'fmap' with flipped arguments. Useful for manipulating values
+-- in context, e.g. 'buildRoot', as in the example below.
+--
+-- @
+-- buildRoot <&> (-/- "dir") == fmap (-/- "dir") buildRoot
+-- @
+(<&>) :: Functor f => f a -> (a -> b) -> f b
+(<&>) = flip fmap
+
+infixl 1 <&>
+
+-- | Given a 'FilePath' to a source file, return 'True' if it is generated.
+-- The current implementation simply assumes that a file is generated if it
+-- lives in the 'buildRoot' directory. Since most files are not generated the
+-- test is usually very fast.
+isGeneratedSource :: FilePath -> Action Bool
+isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
+
+-- | Copy a file tracking the source. Create the target directory if missing.
+copyFile :: FilePath -> FilePath -> Action ()
+copyFile source target = do
+ need [source] -- Guarantee the source is built before printing progress info.
+ let dir = takeDirectory target
+ liftIO $ IO.createDirectoryIfMissing True dir
+ putProgressInfo =<< renderAction "Copy file" source target
+ quietly $ copyFileChanged source target
+
+-- | Copy a file without tracking the source. Create the target directory if missing.
+copyFileUntracked :: FilePath -> FilePath -> Action ()
+copyFileUntracked source target = do
+ let dir = takeDirectory target
+ liftIO $ IO.createDirectoryIfMissing True dir
+ putProgressInfo =<< renderAction "Copy file (untracked)" source target
+ liftIO $ IO.copyFile source target
+
+-- | Transform a given file by applying a function to its contents.
+fixFile :: FilePath -> (String -> String) -> Action ()
+fixFile file f = do
+ putProgressInfo $ "| Fix " ++ file
+ contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
+ old <- IO.hGetContents h
+ let new = f old
+ IO.evaluate $ rnf new
+ return new
+ liftIO $ writeFile file contents
+
+-- | Make a given file executable by running the @chmod +x@ command.
+makeExecutable :: FilePath -> Action ()
+makeExecutable file = do
+ putProgressInfo $ "| Make " ++ quote file ++ " executable."
+ quietly $ cmd "chmod +x " [file]
+
+-- | Move a file. Note that we cannot track the source, because it is moved.
+moveFile :: FilePath -> FilePath -> Action ()
+moveFile source target = do
+ putProgressInfo =<< renderAction "Move file" source target
+ quietly $ cmd ["mv", source, target]
+
+-- | Remove a file that doesn't necessarily exist.
+removeFile :: FilePath -> Action ()
+removeFile file = do
+ putProgressInfo $ "| Remove file " ++ file
+ liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file
+
+-- | Create a directory if it does not already exist.
+createDirectory :: FilePath -> Action ()
+createDirectory dir = do
+ putProgressInfo $ "| Create directory " ++ dir
+ liftIO $ IO.createDirectoryIfMissing True dir
+
+-- | Copy a directory. The contents of the source directory is untracked.
+copyDirectory :: FilePath -> FilePath -> Action ()
+copyDirectory source target = do
+ putProgressInfo =<< renderAction "Copy directory" source target
+ quietly $ cmd ["cp", "-r", source, target]
+
+-- | Move a directory. The contents of the source directory is untracked.
+moveDirectory :: FilePath -> FilePath -> Action ()
+moveDirectory source target = do
+ putProgressInfo =<< renderAction "Move directory" source target
+ quietly $ cmd ["mv", source, target]
+
+-- | Remove a directory that doesn't necessarily exist.
+removeDirectory :: FilePath -> Action ()
+removeDirectory dir = do
+ putProgressInfo $ "| Remove directory " ++ dir
+ liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
+
+data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
+
+-- | A more colourful version of Shake's 'putNormal'.
+putColoured :: ColorIntensity -> Color -> String -> Action ()
+putColoured intensity colour msg = do
+ useColour <- userSetting Never
+ supported <- liftIO $ hSupportsANSI IO.stdout
+ let c Never = False
+ c Auto = supported || IO.isWindows -- Colours do work on Windows
+ c Always = True
+ when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour]
+ putNormal msg
+ when (c useColour) . liftIO $ setSGR [] >> IO.hFlush IO.stdout
+
+newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color)
+ deriving Typeable
+
+-- | Default 'BuildProgressColour'.
+magenta :: BuildProgressColour
+magenta = BuildProgressColour (Dull, Magenta)
+
+-- | Print a build progress message (e.g. executing a build command).
+putBuild :: String -> Action ()
+putBuild msg = do
+ BuildProgressColour (intensity, colour) <- userSetting magenta
+ putColoured intensity colour msg
+
+newtype SuccessColour = SuccessColour (ColorIntensity, Color)
+ deriving Typeable
+
+-- | Default 'SuccessColour'.
+green :: SuccessColour
+green = SuccessColour (Dull, Green)
+
+-- | Print a success message (e.g. a package is built successfully).
+putSuccess :: String -> Action ()
+putSuccess msg = do
+ SuccessColour (intensity, colour) <- userSetting green
+ putColoured intensity colour msg
+
+data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)
+
+-- | Version of 'putBuild' controlled by @--progress-info@ command line argument.
+putProgressInfo :: String -> Action ()
+putProgressInfo msg = do
+ progressInfo <- userSetting None
+ when (progressInfo /= None) $ putBuild msg
+
+-- | Render an action.
+renderAction :: String -> FilePath -> FilePath -> Action String
+renderAction what input output = do
+ progressInfo <- userSetting Brief
+ return $ case progressInfo of
+ None -> ""
+ Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
+ Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ]
+ Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ]
+ where
+ i = unifyPath input
+ o = unifyPath output
+
+-- | Render the successful build of a program.
+renderProgram :: String -> String -> Maybe String -> String
+renderProgram name bin synopsis = renderBox $
+ [ "Successfully built program " ++ name
+ , "Executable: " ++ bin ] ++
+ [ "Program synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
+
+-- | Render the successful build of a library.
+renderLibrary :: String -> String -> Maybe String -> String
+renderLibrary name lib synopsis = renderBox $
+ [ "Successfully built library " ++ name
+ , "Library: " ++ lib ] ++
+ [ "Library synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
+
+prettySynopsis :: Maybe String -> String
+prettySynopsis Nothing = ""
+prettySynopsis (Just s) = dropWhileEnd isPunctuation s ++ "."
+
+-- | Render the given set of lines in an ASCII box. The minimum width and
+-- whether to use Unicode symbols are hardcoded in the function's body.
+--
+-- >>> renderBox (words "lorem ipsum")
+-- /----------\
+-- | lorem |
+-- | ipsum |
+-- \----------/
+renderBox :: [String] -> String
+renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
+ where
+ -- Minimum total width of the box in characters
+ minimumBoxWidth = 32
+
+ -- TODO: Make this setting configurable? Setting to True by default seems
+ -- to work poorly with many fonts.
+ useUnicode = False
+
+ -- Characters to draw the box
+ (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
+ | useUnicode = ('─', '│', '╭', '╮', '╰', '╯', ' ')
+ | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
+
+ -- Box width, taking minimum desired length and content into account.
+ -- The -4 is for the beginning and end pipe/padding symbols, as
+ -- in "| xxx |".
+ boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
+ where
+ maxContentLength = maximum (map length ls)
+
+ renderLine l = concat
+ [ [pipe, padding]
+ , padToLengthWith boxContentWidth padding l
+ , [padding, pipe] ]
+ where
+ padToLengthWith n filler x = x ++ replicate (n - length x) filler
+
+ (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
+ , botLeft : dashes ++ [botRight] )
+ where
+ -- +1 for each non-dash (= corner) char
+ dashes = replicate (boxContentWidth + 2) dash
+
+-- | Render the given set of lines next to our favorite unicorn Robert.
+renderUnicorn :: [String] -> String
+renderUnicorn ls =
+ unlines $ take (max (length ponyLines) (length boxLines)) $
+ zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
+ where
+ ponyLines :: [String]
+ ponyLines = [ " ,;,,;'"
+ , " ,;;'( Robert the spitting unicorn"
+ , " __ ,;;' ' \\ wants you to know"
+ , " /' '\\'~~'~' \\ /'\\.) that a task "
+ , " ,;( ) / |. / just finished! "
+ , " ,;' \\ /-.,,( ) \\ "
+ , " ^ ) / ) / )| Almost there! "
+ , " || || \\) "
+ , " (_\\ (_\\ " ]
+ ponyPadding :: String
+ ponyPadding = " "
+ boxLines :: [String]
+ boxLines = ["", "", ""] ++ (lines . renderBox $ ls)
diff --git a/hadrian/src/Main.hs b/hadrian/src/Main.hs
new file mode 100644
index 0000000000..52af0adf7c
--- /dev/null
+++ b/hadrian/src/Main.hs
@@ -0,0 +1,59 @@
+module Main (main) where
+
+import Development.Shake
+import Hadrian.Expression
+import Hadrian.Utilities
+
+import qualified Base
+import qualified CommandLine
+import qualified Environment
+import qualified Rules
+import qualified Rules.Clean
+import qualified Rules.Documentation
+import qualified Rules.Install
+import qualified Rules.SourceDist
+import qualified Rules.Selftest
+import qualified Rules.Test
+import qualified UserSettings
+
+main :: IO ()
+main = do
+ -- Provide access to command line arguments and some user settings through
+ -- Shake's type-indexed map 'shakeExtra'.
+ argsMap <- CommandLine.cmdLineArgsMap
+ let extra = insertExtra UserSettings.buildProgressColour
+ $ insertExtra UserSettings.successColour
+ $ insertExtra UserSettings.userBuildRoot
+ $ insertExtra (VerboseCommand UserSettings.verboseCommand) argsMap
+
+ BuildRoot buildRoot = UserSettings.userBuildRoot
+
+ rebuild = [ (RebuildLater, buildRoot -/- "stage0//*")
+ | CommandLine.lookupFreeze1 argsMap ]
+
+ options :: ShakeOptions
+ options = shakeOptions
+ { shakeChange = ChangeModtimeAndDigest
+ , shakeFiles = buildRoot -/- Base.shakeFilesDir
+ , shakeProgress = progressSimple
+ , shakeRebuild = rebuild
+ , shakeTimings = True
+ , shakeExtra = extra }
+
+ rules :: Rules ()
+ rules = do
+ Rules.buildRules
+ Rules.Documentation.documentationRules
+ Rules.Clean.cleanRules
+ Rules.Install.installRules
+ Rules.oracleRules
+ Rules.Selftest.selftestRules
+ Rules.SourceDist.sourceDistRules
+ Rules.Test.testRules
+ Rules.topLevelTargets
+
+ shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do
+ Environment.setupEnvironment
+ return . Just $ if null targets
+ then rules
+ else want targets >> withoutActions rules
diff --git a/hadrian/src/Oracles/Flag.hs b/hadrian/src/Oracles/Flag.hs
new file mode 100644
index 0000000000..447f0bc076
--- /dev/null
+++ b/hadrian/src/Oracles/Flag.hs
@@ -0,0 +1,80 @@
+module Oracles.Flag (
+ Flag (..), flag, crossCompiling, platformSupportsSharedLibs,
+ ghcWithSMP, ghcWithNativeCodeGen, supportsSplitObjects
+ ) where
+
+import Hadrian.Oracles.TextFile
+
+import Base
+import Oracles.Setting
+
+data Flag = ArSupportsAtFile
+ | CrossCompiling
+ | GccIsClang
+ | GccLt34
+ | GccLt44
+ | GccLt46
+ | GhcUnregisterised
+ | LeadingUnderscore
+ | SolarisBrokenShld
+ | SplitObjectsBroken
+ | WithLibdw
+ | HaveLibMingwEx
+ | UseSystemFfi
+
+-- Note, if a flag is set to empty string we treat it as set to NO. This seems
+-- fragile, but some flags do behave like this, e.g. GccIsClang.
+flag :: Flag -> Action Bool
+flag f = do
+ let key = case f of
+ ArSupportsAtFile -> "ar-supports-at-file"
+ CrossCompiling -> "cross-compiling"
+ GccIsClang -> "gcc-is-clang"
+ GccLt34 -> "gcc-lt-34"
+ GccLt44 -> "gcc-lt-44"
+ GccLt46 -> "gcc-lt-46"
+ GhcUnregisterised -> "ghc-unregisterised"
+ LeadingUnderscore -> "leading-underscore"
+ SolarisBrokenShld -> "solaris-broken-shld"
+ SplitObjectsBroken -> "split-objects-broken"
+ WithLibdw -> "with-libdw"
+ HaveLibMingwEx -> "have-lib-mingw-ex"
+ UseSystemFfi -> "use-system-ffi"
+ value <- lookupValueOrError configFile key
+ when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag "
+ ++ quote (key ++ " = " ++ value) ++ " cannot be parsed."
+ return $ value == "YES"
+
+crossCompiling :: Action Bool
+crossCompiling = flag CrossCompiling
+
+platformSupportsSharedLibs :: Action Bool
+platformSupportsSharedLibs = do
+ badPlatform <- anyTargetPlatform [ "powerpc-unknown-linux"
+ , "x86_64-unknown-mingw32"
+ , "i386-unknown-mingw32" ]
+ solaris <- anyTargetPlatform [ "i386-unknown-solaris2" ]
+ solarisBroken <- flag SolarisBrokenShld
+ return $ not (badPlatform || solaris && solarisBroken)
+
+ghcWithSMP :: Action Bool
+ghcWithSMP = do
+ goodArch <- anyTargetArch ["i386", "x86_64", "sparc", "powerpc", "arm"]
+ ghcUnreg <- flag GhcUnregisterised
+ return $ goodArch && not ghcUnreg
+
+ghcWithNativeCodeGen :: Action Bool
+ghcWithNativeCodeGen = do
+ goodArch <- anyTargetArch ["i386", "x86_64", "sparc", "powerpc"]
+ badOs <- anyTargetOs ["ios", "aix"]
+ ghcUnreg <- flag GhcUnregisterised
+ return $ goodArch && not badOs && not ghcUnreg
+
+supportsSplitObjects :: Action Bool
+supportsSplitObjects = do
+ broken <- flag SplitObjectsBroken
+ ghcUnreg <- flag GhcUnregisterised
+ goodArch <- anyTargetArch [ "i386", "x86_64", "powerpc", "sparc" ]
+ goodOs <- anyTargetOs [ "mingw32", "cygwin32", "linux", "darwin", "solaris2"
+ , "freebsd", "dragonfly", "netbsd", "openbsd" ]
+ return $ not broken && not ghcUnreg && goodArch && goodOs
diff --git a/hadrian/src/Oracles/ModuleFiles.hs b/hadrian/src/Oracles/ModuleFiles.hs
new file mode 100644
index 0000000000..c7175dbc1c
--- /dev/null
+++ b/hadrian/src/Oracles/ModuleFiles.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE TypeFamilies #-}
+module Oracles.ModuleFiles (
+ decodeModule, encodeModule, findGenerator, hsSources, hsObjects, moduleFilesOracle
+ ) where
+
+import qualified Data.HashMap.Strict as Map
+
+import Base
+import Builder
+import Context
+import GHC
+import Oracles.PackageData
+
+newtype ModuleFiles = ModuleFiles (Stage, Package)
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult ModuleFiles = [Maybe FilePath]
+
+newtype Generator = Generator (Stage, Package, FilePath)
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult Generator = Maybe FilePath
+
+-- | We scan for the following Haskell source extensions when looking for module
+-- files. Note, we do not list "*.(l)hs-boot" files here, as they can never
+-- appear by themselves and always have accompanying "*.(l)hs" master files.
+haskellExtensions :: [String]
+haskellExtensions = [".hs", ".lhs"]
+
+-- | Non-Haskell source extensions and corresponding builders.
+otherExtensions :: [(String, Builder)]
+otherExtensions = [ (".x" , Alex )
+ , (".y" , Happy )
+ , (".ly" , Happy )
+ , (".hsc", Hsc2Hs) ]
+
+-- | We match the following file patterns when looking for module files.
+moduleFilePatterns :: [FilePattern]
+moduleFilePatterns = map ("*" ++) $ haskellExtensions ++ map fst otherExtensions
+
+-- | Given a FilePath determine the corresponding builder.
+determineBuilder :: FilePath -> Maybe Builder
+determineBuilder file = lookup (takeExtension file) otherExtensions
+
+-- | Given a module name extract the directory and file name, e.g.:
+--
+-- > decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
+-- > decodeModule "Prelude" == ("", "Prelude")
+decodeModule :: String -> (FilePath, String)
+decodeModule modName = (intercalate "/" (init xs), last xs)
+ where
+ xs = words $ replaceEq '.' ' ' modName
+
+-- | Given the directory and file name find the corresponding module name, e.g.:
+--
+-- > encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
+-- > encodeModule "" "Prelude" == "Prelude"
+-- > uncurry encodeModule (decodeModule name) == name
+encodeModule :: FilePath -> String -> String
+encodeModule dir file
+ | dir == "" = takeBaseName file
+ | otherwise = replaceEq '/' '.' dir ++ '.' : takeBaseName file
+
+-- | Find the generator for a given 'Context' and a source file. For example:
+-- findGenerator (Context Stage1 compiler vanilla)
+-- "_build/stage1/compiler/build/Lexer.hs"
+-- == Just ("compiler/parser/Lexer.x", Alex)
+-- findGenerator (Context Stage1 base vanilla)
+-- "_build/stage1/base/build/Prelude.hs"
+-- == Nothing
+findGenerator :: Context -> FilePath -> Action (Maybe (FilePath, Builder))
+findGenerator Context {..} file = do
+ maybeSource <- askOracle $ Generator (stage, package, file)
+ return $ do
+ source <- maybeSource
+ builder <- determineBuilder source
+ return (source, builder)
+
+-- | Find all Haskell source files for a given 'Context'.
+hsSources :: Context -> Action [FilePath]
+hsSources context = do
+ let modFile (m, Nothing ) = generatedFile context m
+ modFile (m, Just file )
+ | takeExtension file `elem` haskellExtensions = return file
+ | otherwise = generatedFile context m
+ mapM modFile =<< contextFiles context
+
+-- | Find all Haskell object files for a given 'Context'. Note: this is a much
+-- simpler function compared to 'hsSources', because all object files live in
+-- the build directory regardless of whether they are generated or not.
+hsObjects :: Context -> Action [FilePath]
+hsObjects context = do
+ path <- buildPath context
+ modules <- pkgDataList (Modules path)
+ -- GHC.Prim module is only for documentation, we do not actually build it.
+ mapM (objectPath context . moduleSource) (filter (/= "GHC.Prim") modules)
+
+-- | Generated module files live in the 'Context' specific build directory.
+generatedFile :: Context -> String -> Action FilePath
+generatedFile context moduleName = do
+ path <- buildPath context
+ return $ path -/- moduleSource moduleName
+
+moduleSource :: String -> FilePath
+moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs"
+
+-- | Module files for a given 'Context'.
+contextFiles :: Context -> Action [(String, Maybe FilePath)]
+contextFiles context@Context {..} = do
+ path <- buildPath context
+ modules <- fmap sort . pkgDataList $ Modules path
+ zip modules <$> askOracle (ModuleFiles (stage, package))
+
+-- | This is an important oracle whose role is to find and cache module source
+-- files. It takes a 'Stage' and a 'Package', looks up corresponding source
+-- directories @dirs@ and a sorted list of module names @modules@, and for each
+-- module, e.g. @A.B.C@, returns a 'FilePath' of the form @dir/A/B/C.extension@,
+-- such that @dir@ belongs to @dirs@, and file @dir/A/B/C.extension@ exists, or
+-- 'Nothing' if there is no such file. If more than one matching file is found
+-- an error is raised. For example, for 'Stage1' and 'compiler', @dirs@ will
+-- contain ["compiler/codeGen", "compiler/parser"], and @modules@ will contain
+-- ["CodeGen.Platform.ARM", "Config", "Lexer"]; the oracle will produce a list
+-- containing [Just "compiler/codeGen/CodeGen/Platform/ARM.hs", Nothing,
+-- Just "compiler/parser/Lexer.x"]. The oracle ignores @.(l)hs-boot@ files.
+moduleFilesOracle :: Rules ()
+moduleFilesOracle = void $ do
+ void . addOracle $ \(ModuleFiles (stage, package)) -> do
+ let context = vanillaContext stage package
+ path <- buildPath context
+ srcDirs <- pkgDataList $ SrcDirs path
+ modules <- fmap sort . pkgDataList $ Modules path
+ autogen <- autogenPath context
+ let dirs = autogen : map (pkgPath package -/-) srcDirs
+ modDirFiles = groupSort $ map decodeModule modules
+ result <- concatForM dirs $ \dir -> do
+ todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
+ forM todo $ \(mDir, mFiles) -> do
+ let fullDir = unifyPath $ dir -/- mDir
+ files <- getDirectoryFiles fullDir moduleFilePatterns
+ let cmp f = compare (dropExtension f)
+ found = intersectOrd cmp files mFiles
+ return (map (fullDir -/-) found, mDir)
+ let pairs = sort [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
+ multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
+ unless (null multi) $ do
+ let (m, f1, f2) = head multi
+ error $ "Module " ++ m ++ " has more than one source file: "
+ ++ f1 ++ " and " ++ f2 ++ "."
+ return $ lookupAll modules pairs
+
+ -- Optimisation: we discard Haskell files here, because they are never used
+ -- as generators, and hence would be discarded in 'findGenerator' anyway.
+ generators <- newCache $ \(stage, package) -> do
+ let context = vanillaContext stage package
+ files <- contextFiles context
+ list <- sequence [ (,src) <$> generatedFile context modName
+ | (modName, Just src) <- files
+ , takeExtension src `notElem` haskellExtensions ]
+ return $ Map.fromList list
+
+ addOracle $ \(Generator (stage, package, file)) ->
+ Map.lookup file <$> generators (stage, package)
diff --git a/hadrian/src/Oracles/PackageData.hs b/hadrian/src/Oracles/PackageData.hs
new file mode 100644
index 0000000000..cdfe9bfb48
--- /dev/null
+++ b/hadrian/src/Oracles/PackageData.hs
@@ -0,0 +1,66 @@
+module Oracles.PackageData (
+ PackageData (..), PackageDataList (..), pkgData, pkgDataList
+ ) where
+
+import Hadrian.Oracles.TextFile
+
+import Base
+
+newtype PackageData = BuildGhciLib FilePath
+
+data PackageDataList = AsmSrcs FilePath
+ | CcArgs FilePath
+ | CSrcs FilePath
+ | CmmSrcs FilePath
+ | CppArgs FilePath
+ | DepCcArgs FilePath
+ | DepExtraLibs FilePath
+ | DepIds FilePath
+ | DepIncludeDirs FilePath
+ | DepLdArgs FilePath
+ | DepLibDirs FilePath
+ | DepNames FilePath
+ | Deps FilePath
+ | HiddenModules FilePath
+ | HsArgs FilePath
+ | IncludeDirs FilePath
+ | LdArgs FilePath
+ | Modules FilePath
+ | SrcDirs FilePath
+
+askPackageData :: FilePath -> String -> Action String
+askPackageData path = lookupValueOrEmpty (path -/- "package-data.mk")
+
+-- | For each @PackageData path@ the file 'path/package-data.mk' contains a line
+-- of the form 'path_VERSION = 1.2.3.4'. @pkgData (PackageData path)@ is an
+-- Action that consults the file and returns "1.2.3.4".
+pkgData :: PackageData -> Action String
+pkgData packageData = case packageData of
+ BuildGhciLib path -> askPackageData path "BUILD_GHCI_LIB"
+
+-- | @PackageDataList path@ is used for multiple string options separated by
+-- spaces, such as @path_MODULES = Data.Array Data.Array.Base ...@.
+-- @pkgListData Modules@ therefore returns ["Data.Array", "Data.Array.Base", ...]
+pkgDataList :: PackageDataList -> Action [String]
+pkgDataList packageData = fmap (map unquote . words) $ case packageData of
+ AsmSrcs path -> askPackageData path "S_SRCS"
+ CcArgs path -> askPackageData path "CC_OPTS"
+ CSrcs path -> askPackageData path "C_SRCS"
+ CmmSrcs path -> askPackageData path "CMM_SRCS"
+ CppArgs path -> askPackageData path "CPP_OPTS"
+ DepCcArgs path -> askPackageData path "DEP_CC_OPTS"
+ DepExtraLibs path -> askPackageData path "DEP_EXTRA_LIBS"
+ DepIds path -> askPackageData path "DEP_IPIDS"
+ DepIncludeDirs path -> askPackageData path "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
+ DepLibDirs path -> askPackageData path "DEP_LIB_DIRS_SINGLE_QUOTED"
+ DepLdArgs path -> askPackageData path "DEP_LD_OPTS"
+ DepNames path -> askPackageData path "DEP_NAMES"
+ Deps path -> askPackageData path "DEPS"
+ HiddenModules path -> askPackageData path "HIDDEN_MODULES"
+ HsArgs path -> askPackageData path "HC_OPTS"
+ IncludeDirs path -> askPackageData path "INCLUDE_DIRS"
+ LdArgs path -> askPackageData path "LD_OPTS"
+ Modules path -> askPackageData path "MODULES"
+ SrcDirs path -> askPackageData path "HS_SRC_DIRS"
+ where
+ unquote = dropWhile (== '\'') . dropWhileEnd (== '\'')
diff --git a/hadrian/src/Oracles/Setting.hs b/hadrian/src/Oracles/Setting.hs
new file mode 100644
index 0000000000..aa49011e1e
--- /dev/null
+++ b/hadrian/src/Oracles/Setting.hs
@@ -0,0 +1,236 @@
+module Oracles.Setting (
+ configFile, Setting (..), SettingList (..), setting, settingList, getSetting,
+ getSettingList, anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs,
+ ghcWithInterpreter, ghcEnableTablesNextToCode, useLibFFIForAdjustors,
+ ghcCanonVersion, cmdLineLengthLimit, iosHost, osxHost, windowsHost,
+ topDirectory, relocatableBuild, installDocDir, installGhcLibDir, libsuf
+ ) where
+
+import Hadrian.Expression
+import Hadrian.Oracles.TextFile
+import Hadrian.Oracles.Path
+
+import Base
+
+-- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions).
+-- | Each 'Setting' comes from @system.config@ file, e.g. 'target-os = mingw32'.
+-- @setting TargetOs@ looks up the config file and returns "mingw32".
+-- 'SettingList' is used for multiple string values separated by spaces, such
+-- as @gmp-include-dirs = a b@.
+-- @settingList GmpIncludeDirs@ therefore returns a list of strings ["a", "b"].
+data Setting = BuildArch
+ | BuildOs
+ | BuildPlatform
+ | BuildVendor
+ | CcClangBackend
+ | CcLlvmBackend
+ | DynamicExtension
+ | GhcMajorVersion
+ | GhcMinorVersion
+ | GhcPatchLevel
+ | GhcVersion
+ | GhcSourcePath
+ | HostArch
+ | HostOs
+ | HostPlatform
+ | HostVendor
+ | ProjectGitCommitId
+ | ProjectName
+ | ProjectVersion
+ | ProjectVersionInt
+ | ProjectPatchLevel
+ | ProjectPatchLevel1
+ | ProjectPatchLevel2
+ | TargetArch
+ | TargetOs
+ | TargetPlatform
+ | TargetPlatformFull
+ | TargetVendor
+ | LlvmTarget
+ | FfiIncludeDir
+ | FfiLibDir
+ | GmpIncludeDir
+ | GmpLibDir
+ | IconvIncludeDir
+ | IconvLibDir
+ | CursesLibDir
+ -- Paths to where GHC is installed (ref: mk/install.mk)
+ | InstallPrefix
+ | InstallBinDir
+ | InstallLibDir
+ | InstallDataRootDir
+ -- Command lines for invoking the @install@ utility
+ | Install
+ | InstallData
+ | InstallProgram
+ | InstallScript
+ | InstallDir
+ -- Command line for creating a symbolic link
+ | LnS
+
+data SettingList = ConfCcArgs Stage
+ | ConfCppArgs Stage
+ | ConfGccLinkerArgs Stage
+ | ConfLdLinkerArgs Stage
+ | HsCppArgs
+
+-- | Maps 'Setting's to names in @cfg/system.config.in@.
+setting :: Setting -> Action String
+setting key = lookupValueOrError configFile $ case key of
+ BuildArch -> "build-arch"
+ BuildOs -> "build-os"
+ BuildPlatform -> "build-platform"
+ BuildVendor -> "build-vendor"
+ CcClangBackend -> "cc-clang-backend"
+ CcLlvmBackend -> "cc-llvm-backend"
+ DynamicExtension -> "dynamic-extension"
+ GhcMajorVersion -> "ghc-major-version"
+ GhcMinorVersion -> "ghc-minor-version"
+ GhcPatchLevel -> "ghc-patch-level"
+ GhcVersion -> "ghc-version"
+ GhcSourcePath -> "ghc-source-path"
+ HostArch -> "host-arch"
+ HostOs -> "host-os"
+ HostPlatform -> "host-platform"
+ HostVendor -> "host-vendor"
+ ProjectGitCommitId -> "project-git-commit-id"
+ ProjectName -> "project-name"
+ ProjectVersion -> "project-version"
+ ProjectVersionInt -> "project-version-int"
+ ProjectPatchLevel -> "project-patch-level"
+ ProjectPatchLevel1 -> "project-patch-level1"
+ ProjectPatchLevel2 -> "project-patch-level2"
+ TargetArch -> "target-arch"
+ TargetOs -> "target-os"
+ TargetPlatform -> "target-platform"
+ TargetPlatformFull -> "target-platform-full"
+ TargetVendor -> "target-vendor"
+ LlvmTarget -> "llvm-target"
+ FfiIncludeDir -> "ffi-include-dir"
+ FfiLibDir -> "ffi-lib-dir"
+ GmpIncludeDir -> "gmp-include-dir"
+ GmpLibDir -> "gmp-lib-dir"
+ IconvIncludeDir -> "iconv-include-dir"
+ IconvLibDir -> "iconv-lib-dir"
+ CursesLibDir -> "curses-lib-dir"
+ InstallPrefix -> "install-prefix"
+ InstallBinDir -> "install-bindir"
+ InstallLibDir -> "install-libdir"
+ InstallDataRootDir -> "install-datarootdir"
+ Install -> "install"
+ InstallDir -> "install-dir"
+ InstallProgram -> "install-program"
+ InstallScript -> "install-script"
+ InstallData -> "install-data"
+ LnS -> "ln-s"
+
+settingList :: SettingList -> Action [String]
+settingList key = fmap words $ lookupValueOrError configFile $ case key of
+ ConfCcArgs stage -> "conf-cc-args-" ++ stageString stage
+ ConfCppArgs stage -> "conf-cpp-args-" ++ stageString stage
+ ConfGccLinkerArgs stage -> "conf-gcc-linker-args-" ++ stageString stage
+ ConfLdLinkerArgs stage -> "conf-ld-linker-args-" ++ stageString stage
+ HsCppArgs -> "hs-cpp-args"
+
+-- | Get a configuration setting.
+getSetting :: Setting -> Expr c b String
+getSetting = expr . setting
+
+-- | Get a list of configuration settings.
+getSettingList :: SettingList -> Args c b
+getSettingList = expr . settingList
+
+matchSetting :: Setting -> [String] -> Action Bool
+matchSetting key values = (`elem` values) <$> setting key
+
+anyTargetPlatform :: [String] -> Action Bool
+anyTargetPlatform = matchSetting TargetPlatformFull
+
+anyTargetOs :: [String] -> Action Bool
+anyTargetOs = matchSetting TargetOs
+
+anyTargetArch :: [String] -> Action Bool
+anyTargetArch = matchSetting TargetArch
+
+anyHostOs :: [String] -> Action Bool
+anyHostOs = matchSetting HostOs
+
+iosHost :: Action Bool
+iosHost = anyHostOs ["ios"]
+
+osxHost :: Action Bool
+osxHost = anyHostOs ["darwin"]
+
+windowsHost :: Action Bool
+windowsHost = anyHostOs ["mingw32", "cygwin32"]
+
+ghcWithInterpreter :: Action Bool
+ghcWithInterpreter = do
+ goodOs <- anyTargetOs [ "mingw32", "cygwin32", "linux", "solaris2"
+ , "freebsd", "dragonfly", "netbsd", "openbsd"
+ , "darwin", "kfreebsdgnu" ]
+ goodArch <- anyTargetArch [ "i386", "x86_64", "powerpc", "sparc"
+ , "sparc64", "arm" ]
+ return $ goodOs && goodArch
+
+ghcEnableTablesNextToCode :: Action Bool
+ghcEnableTablesNextToCode = notM $ anyTargetArch ["ia64", "powerpc64", "powerpc64le"]
+
+useLibFFIForAdjustors :: Action Bool
+useLibFFIForAdjustors = notM $ anyTargetArch ["i386", "x86_64"]
+
+-- | Canonicalised GHC version number, used for integer version comparisons. We
+-- expand GhcMinorVersion to two digits by adding a leading zero if necessary.
+ghcCanonVersion :: Action String
+ghcCanonVersion = do
+ ghcMajorVersion <- setting GhcMajorVersion
+ ghcMinorVersion <- setting GhcMinorVersion
+ let leadingZero = [ '0' | length ghcMinorVersion == 1 ]
+ return $ ghcMajorVersion ++ leadingZero ++ ghcMinorVersion
+
+-- ref: https://ghc.haskell.org/trac/ghc/wiki/Building/Installing#HowGHCfindsitsfiles
+-- | On Windows we normally build a relocatable installation, which assumes that
+-- the library directory @libdir@ is in a fixed location relative to the GHC
+-- binary, namely @../lib@.
+relocatableBuild :: Action Bool
+relocatableBuild = windowsHost
+
+installDocDir :: Action String
+installDocDir = do
+ version <- setting ProjectVersion
+ dataDir <- setting InstallDataRootDir
+ return $ dataDir -/- ("doc/ghc-" ++ version)
+
+-- | Path to the GHC source tree.
+topDirectory :: Action FilePath
+topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
+
+-- ref: mk/install.mk:101
+-- TODO: CroosCompilePrefix
+-- | Unix: override @libdir@ and @datadir@ to put GHC-specific files in a
+-- subdirectory with the version number included.
+installGhcLibDir :: Action String
+installGhcLibDir = do
+ rBuild <- relocatableBuild
+ libdir <- setting InstallLibDir
+ if rBuild then return libdir
+ else do
+ version <- setting ProjectVersion
+ return $ libdir -/- ("ghc-" ++ version)
+
+-- TODO: find out why we need version number in the dynamic suffix
+-- The current theory: dynamic libraries are eventually placed in a single
+-- giant directory in the load path of the dynamic linker, and hence we must
+-- distinguish different versions of GHC. In contrast static libraries live
+-- in their own per-package directory and hence do not need a unique filename.
+-- We also need to respect the system's dynamic extension, e.g. .dll or .so.
+libsuf :: Way -> Action String
+libsuf way =
+ if not (wayUnit Dynamic way)
+ then return $ waySuffix way ++ ".a" -- e.g., _p.a
+ else do
+ extension <- setting DynamicExtension -- e.g., .dll or .so
+ version <- setting ProjectVersion -- e.g., 7.11.20141222
+ let prefix = wayPrefix $ removeWayUnit Dynamic way
+ -- e.g., p_ghc7.11.20141222.dll (the result)
+ return $ prefix ++ "-ghc" ++ version ++ extension
diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs
new file mode 100644
index 0000000000..d5c26e8e94
--- /dev/null
+++ b/hadrian/src/Rules.hs
@@ -0,0 +1,123 @@
+module Rules (buildRules, oracleRules, packageTargets, topLevelTargets) where
+
+import qualified Hadrian.Oracles.ArgsHash
+import qualified Hadrian.Oracles.DirectoryContents
+import qualified Hadrian.Oracles.Path
+import qualified Hadrian.Oracles.TextFile
+
+import Expression
+import qualified Oracles.ModuleFiles
+import qualified Rules.Compile
+import qualified Rules.PackageData
+import qualified Rules.Dependencies
+import qualified Rules.Documentation
+import qualified Rules.Generate
+import qualified Rules.Configure
+import qualified Rules.Gmp
+import qualified Rules.Libffi
+import qualified Rules.Library
+import qualified Rules.Program
+import qualified Rules.Register
+import Settings
+import Target
+import UserSettings
+import Utilities
+
+allStages :: [Stage]
+allStages = [minBound ..]
+
+-- | This rule calls 'need' on all top-level build targets, respecting the
+-- 'Stage1Only' flag.
+topLevelTargets :: Rules ()
+topLevelTargets = action $ do
+ let libraryPackages = filter isLibrary (knownPackages \\ [libffi])
+ need =<< if stage1Only
+ then do
+ libs <- concatForM [Stage0, Stage1] $ \stage ->
+ concatForM libraryPackages $ packageTargets False stage
+ prgs <- concatForM programsStage1Only $ packageTargets False Stage0
+ return $ libs ++ prgs ++ inplaceLibCopyTargets
+ else do
+ targets <- concatForM allStages $ \stage ->
+ concatForM (knownPackages \\ [libffi]) $
+ packageTargets False stage
+ return $ targets ++ inplaceLibCopyTargets
+
+-- TODO: Get rid of the @includeGhciLib@ hack.
+-- | Return the list of targets associated with a given 'Stage' and 'Package'.
+-- By setting the Boolean parameter to False it is possible to exclude the GHCi
+-- library from the targets, and avoid running @ghc-cabal@ to determine wether
+-- GHCi library needs to be built for this package. We typically want to set
+-- this parameter to True, however it is important to set it to False when
+-- computing 'topLevelTargets', as otherwise the whole build gets sequentialised
+-- because we need to run @ghc-cabal@ in the order respecting package dependencies.
+packageTargets :: Bool -> Stage -> Package -> Action [FilePath]
+packageTargets includeGhciLib stage pkg = do
+ let context = vanillaContext stage pkg
+ activePackages <- stagePackages stage
+ if pkg `notElem` activePackages
+ then return [] -- Skip inactive packages.
+ else if isLibrary pkg
+ then do -- Collect all targets of a library package.
+ let pkgWays = if pkg == rts then getRtsWays else getLibraryWays
+ ways <- interpretInContext context pkgWays
+ libs <- mapM (pkgLibraryFile . Context stage pkg) ways
+ more <- libraryTargets includeGhciLib context
+ setup <- pkgSetupConfigFile context
+ return $ [ setup | not (nonCabalContext context) ] ++ libs ++ more
+ 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
+ -- We cannot register multiple GHC packages in parallel. Also we cannot run
+ -- GHC when the package database is being mutated by "ghc-pkg". This is a
+ -- classic concurrent read exclusive write (CREW) conflict.
+ let maxConcurrentReaders = 1000
+ packageDb <- newResource "package-db" maxConcurrentReaders
+ let readPackageDb = [(packageDb, 1)]
+ writePackageDb = [(packageDb, maxConcurrentReaders)]
+
+ let contexts = liftM3 Context allStages knownPackages allWays
+ vanillaContexts = liftM2 vanillaContext allStages knownPackages
+
+ forM_ contexts $ mconcat
+ [ Rules.Compile.compilePackage readPackageDb
+ , Rules.Library.buildPackageLibrary ]
+
+ let dynamicContexts = liftM3 Context [Stage1 ..] knownPackages [dynamic]
+ forM_ dynamicContexts Rules.Library.buildDynamicLib
+
+ forM_ (filter isProgram knownPackages) $
+ Rules.Program.buildProgram readPackageDb
+
+ forM_ vanillaContexts $ mconcat
+ [ Rules.PackageData.buildPackageData
+ , Rules.Dependencies.buildPackageDependencies readPackageDb
+ , Rules.Documentation.buildPackageDocumentation
+ , Rules.Library.buildPackageGhciLibrary
+ , Rules.Generate.generatePackageCode
+ , Rules.Register.registerPackage writePackageDb ]
+
+buildRules :: Rules ()
+buildRules = do
+ Rules.Configure.configureRules
+ Rules.Generate.copyRules
+ Rules.Generate.generateRules
+ Rules.Gmp.gmpRules
+ Rules.Libffi.libffiRules
+ packageRules
+
+oracleRules :: Rules ()
+oracleRules = do
+ Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
+ Hadrian.Oracles.DirectoryContents.directoryContentsOracle
+ Hadrian.Oracles.Path.pathOracle
+ Hadrian.Oracles.TextFile.textFileOracle
+ Oracles.ModuleFiles.moduleFilesOracle
+
+programsStage1Only :: [Package]
+programsStage1Only = [ deriveConstants, genapply, genprimopcode, ghc, ghcCabal
+ , ghcPkg, hp2ps, hpc, hsc2hs, runGhc ]
diff --git a/hadrian/src/Rules/Clean.hs b/hadrian/src/Rules/Clean.hs
new file mode 100644
index 0000000000..d11cbf5e53
--- /dev/null
+++ b/hadrian/src/Rules/Clean.hs
@@ -0,0 +1,23 @@
+module Rules.Clean (clean, cleanSourceTree, cleanRules) where
+
+import Base
+
+clean :: Action ()
+clean = do
+ cleanSourceTree
+ putBuild "| Remove Hadrian files..."
+ path <- buildRoot
+ removeDirectory $ path -/- generatedDir
+ removeFilesAfter path ["//*"]
+ putSuccess "| Done. "
+
+cleanSourceTree :: Action ()
+cleanSourceTree = do
+ path <- buildRoot
+ forM_ [Stage0 ..] $ removeDirectory . (path -/-) . stageString
+ removeDirectory inplaceBinPath
+ removeDirectory inplaceLibPath
+ removeDirectory "sdistprep"
+
+cleanRules :: Rules ()
+cleanRules = "clean" ~> clean
diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs
new file mode 100644
index 0000000000..a4b1278660
--- /dev/null
+++ b/hadrian/src/Rules/Compile.hs
@@ -0,0 +1,83 @@
+module Rules.Compile (compilePackage) where
+
+import Hadrian.Oracles.TextFile
+
+import Base
+import Context
+import Expression
+import Rules.Generate
+import Target
+import Utilities
+
+compilePackage :: [(Resource, Int)] -> Context -> Rules ()
+compilePackage rs context@Context {..} = do
+ let dir = "//" ++ contextDir context
+ nonHs extension = dir -/- extension <//> "*" <.> osuf way
+ compile compiler obj2src obj = do
+ src <- obj2src context obj
+ need [src]
+ needDependencies context src $ obj <.> "d"
+ buildWithResources rs $ target context (compiler stage) [src] [obj]
+ compileHs = \[obj, _hi] -> do
+ path <- buildPath context
+ (src, deps) <- lookupDependencies (path -/- ".dependencies") obj
+ need $ src : deps
+ when (isLibrary package) $ need =<< return <$> pkgConfFile context
+ needLibrary =<< contextDependencies context
+ buildWithResources rs $ target context (Ghc CompileHs stage) [src] [obj]
+
+ priority 2.0 $ do
+ nonHs "c" %> compile (Ghc CompileCWithGhc) (obj2src "c" isGeneratedCFile )
+ nonHs "cmm" %> compile (Ghc CompileHs) (obj2src "cmm" isGeneratedCmmFile)
+ nonHs "s" %> compile (Ghc CompileHs) (obj2src "S" $ const False )
+
+ -- TODO: Add dependencies for #include of .h and .hs-incl files (gcc -MM?).
+ [ dir <//> "*" <.> suf way | suf <- [ osuf, hisuf] ] &%> compileHs
+ [ dir <//> "*" <.> suf way | suf <- [obootsuf, hibootsuf] ] &%> compileHs
+
+-- | Discover dependencies of a given source file by iteratively calling @gcc@
+-- in the @-MM -MG@ mode and building generated dependencies if they are missing
+-- until reaching a fixed point.
+needDependencies :: Context -> FilePath -> FilePath -> Action ()
+needDependencies context@Context {..} src depFile = discover
+ where
+ discover = do
+ build $ target context (Cc FindCDependencies stage) [src] [depFile]
+ deps <- parseFile depFile
+ -- Generated dependencies, if not yet built, will not be found and hence
+ -- will be referred to simply by their file names.
+ let notFound = filter (\file -> file == takeFileName file) deps
+ -- We find the full paths to generated dependencies, so we can request
+ -- to build them by calling 'need'.
+ todo <- catMaybes <$> mapM (fullPathIfGenerated context) notFound
+
+ if null todo
+ then need deps -- The list of dependencies is final, need all
+ else do
+ need todo -- Build newly discovered generated dependencies
+ discover -- Continue the discovery process
+
+ parseFile :: FilePath -> Action [String]
+ parseFile file = do
+ input <- liftIO $ readFile file
+ case parseMakefile input of
+ [(_file, deps)] -> return deps
+ _ -> return []
+
+-- | Find a given 'FilePath' in the list of generated files in the given
+-- 'Context' and return its full path.
+fullPathIfGenerated :: Context -> FilePath -> Action (Maybe FilePath)
+fullPathIfGenerated context file = interpretInContext context $ do
+ generated <- generatedDependencies
+ return $ find ((== file) . takeFileName) generated
+
+obj2src :: String -> (FilePath -> Bool) -> Context -> FilePath -> Action FilePath
+obj2src extension isGenerated context@Context {..} obj
+ | isGenerated src = return src
+ | otherwise = (pkgPath package ++) <$> suffix
+ where
+ src = obj -<.> extension
+ suffix = do
+ path <- buildPath context
+ return $ fromMaybe ("Cannot determine source for " ++ obj)
+ $ stripPrefix (path -/- extension) src
diff --git a/hadrian/src/Rules/Configure.hs b/hadrian/src/Rules/Configure.hs
new file mode 100644
index 0000000000..dd016c149f
--- /dev/null
+++ b/hadrian/src/Rules/Configure.hs
@@ -0,0 +1,42 @@
+module Rules.Configure (configureRules) where
+
+import qualified System.Info.Extra as System
+
+import Base
+import Builder
+import CommandLine
+import Context
+import GHC
+import Target
+import Utilities
+
+configureRules :: Rules ()
+configureRules = do
+ [configFile, "settings", configH] &%> \outs -> do
+ skip <- cmdSkipConfigure
+ if skip
+ then unlessM (doesFileExist configFile) $
+ error $ "Configuration file " ++ configFile ++ " is missing."
+ ++ "\nRun the configure script manually or do not use the "
+ ++ "--skip-configure flag."
+ else do
+ -- We cannot use windowsHost here due to a cyclic dependency.
+ when System.isWindows $ do
+ putBuild "| Checking for Windows tarballs..."
+ quietly $ cmd ["bash", "mk/get-win32-tarballs.sh", "download", System.arch]
+ let srcs = map (<.> "in") outs
+ context = vanillaContext Stage0 compiler
+ need srcs
+ build $ target context (Configure ".") srcs outs
+
+ ["configure", configH <.> "in"] &%> \_ -> do
+ skip <- cmdSkipConfigure
+ if skip
+ then unlessM (doesFileExist "configure") $
+ error $ "The configure script is missing.\nRun the boot script"
+ ++ " manually or do not use the --skip-configure flag."
+ else do
+ need ["configure.ac"]
+ putBuild "| Running boot..."
+ verbosity <- getVerbosity
+ quietly $ cmd [EchoStdout (verbosity >= Loud)] "python3 boot"
diff --git a/hadrian/src/Rules/Dependencies.hs b/hadrian/src/Rules/Dependencies.hs
new file mode 100644
index 0000000000..f27ef0d912
--- /dev/null
+++ b/hadrian/src/Rules/Dependencies.hs
@@ -0,0 +1,33 @@
+module Rules.Dependencies (buildPackageDependencies) where
+
+import Data.Bifunctor
+import Data.Function
+
+import Base
+import Context
+import Expression
+import Oracles.ModuleFiles
+import Rules.Generate
+import Target
+import Utilities
+
+buildPackageDependencies :: [(Resource, Int)] -> Context -> Rules ()
+buildPackageDependencies rs context@Context {..} =
+ "//" ++ contextDir context -/- ".dependencies" %> \deps -> do
+ srcs <- hsSources context
+ need srcs
+ orderOnly =<< interpretInContext context generatedDependencies
+ let mk = deps <.> "mk"
+ if null srcs
+ then writeFileChanged mk ""
+ else buildWithResources rs $
+ target context (Ghc FindHsDependencies stage) srcs [mk]
+ removeFile $ mk <.> "bak"
+ mkDeps <- readFile' mk
+ writeFileChanged deps . unlines
+ . map (\(src, deps) -> unwords $ src : deps)
+ . map (bimap unifyPath (map unifyPath))
+ . map (bimap head concat . unzip)
+ . groupBy ((==) `on` fst)
+ . sortBy (compare `on` fst)
+ $ parseMakefile mkDeps
diff --git a/hadrian/src/Rules/Documentation.hs b/hadrian/src/Rules/Documentation.hs
new file mode 100644
index 0000000000..5a5698c995
--- /dev/null
+++ b/hadrian/src/Rules/Documentation.hs
@@ -0,0 +1,197 @@
+module Rules.Documentation (
+ -- * Rules
+ buildPackageDocumentation, documentationRules,
+
+ -- * Utilities
+ haddockDependencies
+ ) where
+
+import Base
+import Context
+import Flavour
+import GHC
+import Oracles.ModuleFiles
+import Oracles.PackageData
+import Settings
+import Target
+import Utilities
+
+-- | Build all documentation
+documentationRules :: Rules ()
+documentationRules = do
+ buildHtmlDocumentation
+ buildPdfDocumentation
+ buildDocumentationArchives
+ buildManPage
+ "//docs//gen_contents_index" %> copyFile "libraries/gen_contents_index"
+ "//docs//prologue.txt" %> copyFile "libraries/prologue.txt"
+ "docs" ~> do
+ root <- buildRoot
+ let html = htmlRoot -/- "index.html"
+ archives = map pathArchive docPaths
+ pdfs = map pathPdf $ docPaths \\ [ "libraries" ]
+ need $ map (root -/-) $ [html] ++ archives ++ pdfs
+ need [ root -/- htmlRoot -/- "libraries" -/- "gen_contents_index" ]
+ need [ root -/- htmlRoot -/- "libraries" -/- "prologue.txt" ]
+ need [manPagePath]
+
+manPagePath :: FilePath
+manPagePath = "_build/docs/users_guide/build-man/ghc.1"
+
+-- TODO: Add support for Documentation Packages so we can
+-- run the builders without this hack.
+docPackage :: Package
+docPackage = hsLibrary "Documentation" "docs"
+
+docPaths :: [FilePath]
+docPaths = [ "libraries", "users_guide", "Haddock" ]
+
+docRoot :: FilePath
+docRoot = "docs"
+
+htmlRoot :: FilePath
+htmlRoot = docRoot -/- "html"
+
+pdfRoot :: FilePath
+pdfRoot = docRoot -/- "pdfs"
+
+archiveRoot :: FilePath
+archiveRoot = docRoot -/- "archives"
+
+pathPdf :: FilePath -> FilePath
+pathPdf path = pdfRoot -/- path <.> ".pdf"
+
+pathIndex :: FilePath -> FilePath
+pathIndex path = htmlRoot -/- path -/- "index.html"
+
+pathArchive :: FilePath -> FilePath
+pathArchive path = archiveRoot -/- path <.> "html.tar.xz"
+
+-- TODO: Replace this with pkgPath when support is added
+-- for Documentation Packages.
+pathPath :: FilePath -> FilePath
+pathPath "users_guide" = "docs/users_guide"
+pathPath "Haddock" = "utils/haddock/doc"
+pathPath _ = ""
+
+----------------------------------------------------------------------
+-- HTML
+
+-- | Build all HTML documentation
+buildHtmlDocumentation :: Rules ()
+buildHtmlDocumentation = do
+ mapM_ buildSphinxHtml $ docPaths \\ [ "libraries" ]
+ buildLibraryDocumentation
+ "//" ++ htmlRoot -/- "index.html" %> \file -> do
+ root <- buildRoot
+ need $ map ((root -/-) . pathIndex) docPaths
+ copyFileUntracked "docs/index.html" file
+
+-----------------------------
+-- Sphinx
+
+-- | Compile a Sphinx ReStructured Text package to HTML
+buildSphinxHtml :: FilePath -> Rules ()
+buildSphinxHtml path = do
+ "//" ++ htmlRoot -/- path -/- "index.html" %> \file -> do
+ let dest = takeDirectory file
+ context = vanillaContext Stage0 docPackage
+ build $ target context (Sphinx Html) [pathPath path] [dest]
+
+-----------------------------
+-- Haddock
+
+-- | Build the haddocks for GHC's libraries
+buildLibraryDocumentation :: Rules ()
+buildLibraryDocumentation = do
+ "//" ++ htmlRoot -/- "libraries/index.html" %> \file -> do
+ haddocks <- allHaddocks
+ need haddocks
+ let libDocs = filter (\x -> takeFileName x /= "ghc.haddock") haddocks
+ context = vanillaContext Stage2 docPackage
+ build $ target context (Haddock BuildIndex) libDocs [file]
+
+allHaddocks :: Action [FilePath]
+allHaddocks = do
+ pkgs <- stagePackages Stage1
+ sequence [ pkgHaddockFile $ vanillaContext Stage1 pkg
+ | pkg <- pkgs, isLibrary pkg, isHsPackage pkg ]
+
+haddockHtmlLib :: FilePath
+haddockHtmlLib = "inplace/lib/html/haddock-util.js"
+
+-- | Find the haddock files for the dependencies of the current library
+haddockDependencies :: Context -> Action [FilePath]
+haddockDependencies context = do
+ path <- buildPath context
+ depNames <- pkgDataList $ DepNames path
+ sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg
+ | 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
+-- files in the Shake database seems fragile and unnecessary.
+buildPackageDocumentation :: Context -> Rules ()
+buildPackageDocumentation context@Context {..} = when (stage == Stage1) $ do
+
+ -- Js and Css files for haddock output
+ when (package == haddock) $ haddockHtmlLib %> \_ -> do
+ let dir = takeDirectory haddockHtmlLib
+ liftIO $ removeFiles dir ["//*"]
+ copyDirectory "utils/haddock/haddock-api/resources/html" dir
+
+ -- Per-package haddocks
+ "//" ++ pkgName package <.> "haddock" %> \file -> do
+ haddocks <- haddockDependencies context
+ srcs <- hsSources context
+ need $ srcs ++ haddocks ++ [haddockHtmlLib]
+
+ -- Build Haddock documentation
+ -- TODO: pass the correct way from Rules via Context
+ dynamicPrograms <- dynamicGhcPrograms <$> flavour
+ let haddockWay = if dynamicPrograms then dynamic else vanilla
+ build $ target (context {way = haddockWay}) (Haddock BuildPackage)
+ srcs [file]
+
+----------------------------------------------------------------------
+-- PDF
+
+-- | Build all PDF documentation
+buildPdfDocumentation :: Rules ()
+buildPdfDocumentation = mapM_ buildSphinxPdf docPaths
+
+-- | Compile a Sphinx ReStructured Text package to LaTeX
+buildSphinxPdf :: FilePath -> Rules ()
+buildSphinxPdf path = do
+ "//" ++ path <.> "pdf" %> \file -> do
+ let context = vanillaContext Stage0 docPackage
+ withTempDir $ \dir -> do
+ build $ target context (Sphinx Latex) [pathPath path] [dir]
+ build $ target context Xelatex [path <.> "tex"] [dir]
+ copyFileUntracked (dir -/- path <.> "pdf") file
+
+----------------------------------------------------------------------
+-- Archive
+
+-- | Build archives of documentation
+buildDocumentationArchives :: Rules ()
+buildDocumentationArchives = mapM_ buildArchive docPaths
+
+buildArchive :: FilePath -> Rules ()
+buildArchive path = do
+ "//" ++ pathArchive path %> \file -> do
+ root <- buildRoot
+ let context = vanillaContext Stage0 docPackage
+ src = root -/- pathIndex path
+ need [src]
+ build $ target context (Tar Create) [takeDirectory src] [file]
+
+-- | build man page
+buildManPage :: Rules ()
+buildManPage = do
+ manPagePath %> \file -> do
+ need ["docs/users_guide/ghc.rst"]
+ let context = vanillaContext Stage0 docPackage
+ withTempDir $ \dir -> do
+ build $ target context (Sphinx Man) ["docs/users_guide"] [dir]
+ copyFileUntracked (dir -/- "ghc.1") file
diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
new file mode 100644
index 0000000000..8e2b65d183
--- /dev/null
+++ b/hadrian/src/Rules/Generate.hs
@@ -0,0 +1,482 @@
+module Rules.Generate (
+ isGeneratedCFile, isGeneratedCmmFile, generatePackageCode, generateRules,
+ copyRules, includesDependencies, generatedDependencies
+ ) where
+
+import Base
+import Expression
+import Flavour
+import Oracles.Flag
+import Oracles.ModuleFiles
+import Oracles.Setting
+import Rules.Gmp
+import Rules.Libffi
+import Target
+import Settings
+import Settings.Packages.Rts
+import Utilities
+
+-- | Track this file to rebuild generated files whenever it changes.
+trackGenerateHs :: Expr ()
+trackGenerateHs = expr $ need [sourcePath -/- "Rules/Generate.hs"]
+
+primopsSource :: FilePath
+primopsSource = "compiler/prelude/primops.txt.pp"
+
+primopsTxt :: Stage -> FilePath
+primopsTxt stage = contextDir (vanillaContext stage compiler) -/- "primops.txt"
+
+platformH :: Stage -> FilePath
+platformH stage = contextDir (vanillaContext stage compiler) -/- "ghc_boot_platform.h"
+
+isGeneratedCFile :: FilePath -> Bool
+isGeneratedCFile file = takeBaseName file `elem` ["Evac_thr", "Scav_thr"]
+
+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
+ path <- expr $ buildPath (vanillaContext stage ghcPrim)
+ return [path -/- "GHC/Prim.hs", path -/- "GHC/PrimopWrappers.hs"]
+
+derivedConstantsDependencies :: [FilePath]
+derivedConstantsDependencies = fmap (generatedDir -/-)
+ [ "DerivedConstants.h"
+ , "GHCConstantsHaskellExports.hs"
+ , "GHCConstantsHaskellType.hs"
+ , "GHCConstantsHaskellWrappers.hs" ]
+
+compilerDependencies :: Expr [FilePath]
+compilerDependencies = do
+ root <- getBuildRoot
+ stage <- getStage
+ isGmp <- (== integerGmp) <$> getIntegerPackage
+ ghcPath <- expr $ buildPath (vanillaContext stage compiler)
+ gmpPath <- expr gmpBuildPath
+ rtsPath <- expr rtsBuildPath
+ mconcat [ return [root -/- platformH stage]
+ , return ((root -/-) <$> includesDependencies)
+ , return ((root -/-) <$> derivedConstantsDependencies)
+ , notStage0 ? isGmp ? return [gmpPath -/- gmpLibraryH]
+ , notStage0 ? return ((rtsPath -/-) <$> libffiDependencies)
+ , return $ fmap (ghcPath -/-)
+ [ "primop-can-fail.hs-incl"
+ , "primop-code-size.hs-incl"
+ , "primop-commutable.hs-incl"
+ , "primop-data-decl.hs-incl"
+ , "primop-fixity.hs-incl"
+ , "primop-has-side-effects.hs-incl"
+ , "primop-list.hs-incl"
+ , "primop-out-of-line.hs-incl"
+ , "primop-primop-info.hs-incl"
+ , "primop-strictness.hs-incl"
+ , "primop-tag.hs-incl"
+ , "primop-vector-tycons.hs-incl"
+ , "primop-vector-tys-exports.hs-incl"
+ , "primop-vector-tys.hs-incl"
+ , "primop-vector-uniques.hs-incl" ] ]
+
+generatedDependencies :: Expr [FilePath]
+generatedDependencies = do
+ root <- getBuildRoot
+ rtsPath <- expr rtsBuildPath
+ mconcat [ package compiler ? compilerDependencies
+ , package ghcPrim ? ghcPrimDependencies
+ , package rts ? return (fmap (rtsPath -/-) libffiDependencies
+ ++ fmap (root -/-) includesDependencies
+ ++ fmap (root -/-) derivedConstantsDependencies)
+ , stage0 ? return (fmap (root -/-) includesDependencies) ]
+
+generate :: FilePath -> Context -> Expr String -> Action ()
+generate file context expr = do
+ contents <- interpretInContext context expr
+ writeFileChanged file contents
+ putSuccess $ "| Successfully generated " ++ file ++ "."
+
+generatePackageCode :: Context -> Rules ()
+generatePackageCode context@(Context stage pkg _) =
+ let dir = contextDir context
+ generated f = ("//" ++ dir ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
+ go gen file = generate file context gen
+ in do
+ generated ?> \file -> do
+ let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
+ (src, builder) <- unpack <$> findGenerator context file
+ need [src]
+ build $ target context builder [src] [file]
+ let boot = src -<.> "hs-boot"
+ whenM (doesFileExist boot) . copyFile boot $ file -<.> "hs-boot"
+
+ priority 2.0 $ do
+ when (pkg == compiler) $ "//" -/- dir -/- "Config.hs" %> go generateConfigHs
+ when (pkg == ghcPkg) $ "//" -/- dir -/- "Version.hs" %> go generateVersionHs
+
+ -- TODO: needing platformH is ugly and fragile
+ when (pkg == compiler) $ do
+ "//" ++ primopsTxt stage %> \file -> do
+ root <- buildRoot
+ need $ [root -/- platformH stage, primopsSource]
+ ++ fmap (root -/-) includesDependencies
+ build $ target context HsCpp [primopsSource] [file]
+
+ "//" ++ platformH stage %> go generateGhcBootPlatformH
+
+ -- TODO: why different folders for generated files?
+ priority 2.0 $ fmap (("//" ++ dir) -/-)
+ [ "GHC/Prim.hs"
+ , "GHC/PrimopWrappers.hs"
+ , "*.hs-incl" ] |%> \file -> do
+ root <- buildRoot
+ need [root -/- primopsTxt stage]
+ build $ target context GenPrimopCode [root -/- primopsTxt stage] [file]
+
+ when (pkg == rts) $ "//" ++ dir -/- "cmm/AutoApply.cmm" %> \file ->
+ build $ target context GenApply [] [file]
+
+copyRules :: Rules ()
+copyRules = do
+ (inplaceLibPath -/- "ghc-usage.txt") <~ return "driver"
+ (inplaceLibPath -/- "ghci-usage.txt" ) <~ return "driver"
+ (inplaceLibPath -/- "llvm-targets") <~ return "."
+ (inplaceLibPath -/- "platformConstants") <~ (buildRoot <&> (-/- generatedDir))
+ (inplaceLibPath -/- "settings") <~ return "."
+ (inplaceLibPath -/- "template-hsc.h") <~ return (pkgPath hsc2hs)
+ "//c/sm/Evac_thr.c" %> copyFile (pkgPath rts -/- "sm/Evac.c")
+ "//c/sm/Scav_thr.c" %> copyFile (pkgPath rts -/- "sm/Scav.c")
+ where
+ pattern <~ mdir = pattern %> \file -> do
+ dir <- mdir
+ copyFile (dir -/- takeFileName file) file
+
+generateRules :: Rules ()
+generateRules = do
+ priority 2.0 $ ("//" ++ generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH
+ priority 2.0 $ ("//" ++ generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH
+ priority 2.0 $ ("//" ++ generatedDir -/- "ghcversion.h") <~ generateGhcVersionH
+
+ ghcSplitPath %> \_ -> do
+ generate ghcSplitPath emptyTarget generateGhcSplit
+ makeExecutable ghcSplitPath
+
+ -- TODO: simplify, get rid of fake rts context
+ "//" ++ generatedDir ++ "//*" %> \file -> do
+ withTempDir $ \dir -> build $
+ target rtsContext DeriveConstants [] [file, dir]
+ where
+ file <~ gen = file %> \out -> generate out emptyTarget gen
+
+-- TODO: Use the Types, Luke! (drop partial function)
+-- We sometimes need to evaluate expressions that do not require knowing all
+-- information about the context. In this case, we don't want to know anything.
+emptyTarget :: Context
+emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
+ (error "Rules.Generate.emptyTarget: unknown package")
+
+-- Generators
+
+-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
+-- the resulting 'String' is a valid C preprocessor identifier.
+cppify :: String -> String
+cppify = replaceEq '-' '_' . replaceEq '.' '_'
+
+ghcSplitSource :: FilePath
+ghcSplitSource = "driver/split/ghc-split.pl"
+
+-- ref: rules/build-perl.mk
+-- | Generate the @ghc-split@ Perl script.
+generateGhcSplit :: Expr String
+generateGhcSplit = do
+ trackGenerateHs
+ targetPlatform <- getSetting TargetPlatform
+ ghcEnableTNC <- expr $ yesNo <$> ghcEnableTablesNextToCode
+ perlPath <- getBuilderPath Perl
+ contents <- expr $ readFileLines ghcSplitSource
+ return . unlines $
+ [ "#!" ++ perlPath
+ , "my $TARGETPLATFORM = " ++ show targetPlatform ++ ";"
+ -- I don't see where the ghc-split tool uses TNC, but
+ -- it's in the build-perl macro.
+ , "my $TABLES_NEXT_TO_CODE = " ++ show ghcEnableTNC ++ ";"
+ ] ++ contents
+
+-- | Generate @ghcplatform.h@ header.
+generateGhcPlatformH :: Expr String
+generateGhcPlatformH = do
+ trackGenerateHs
+ hostPlatform <- getSetting HostPlatform
+ hostArch <- getSetting HostArch
+ hostOs <- getSetting HostOs
+ hostVendor <- getSetting HostVendor
+ targetPlatform <- getSetting TargetPlatform
+ targetArch <- getSetting TargetArch
+ targetOs <- getSetting TargetOs
+ targetVendor <- getSetting TargetVendor
+ ghcUnreg <- expr $ flag GhcUnregisterised
+ return . unlines $
+ [ "#ifndef __GHCPLATFORM_H__"
+ , "#define __GHCPLATFORM_H__"
+ , ""
+ , "#define BuildPlatform_TYPE " ++ cppify hostPlatform
+ , "#define HostPlatform_TYPE " ++ cppify targetPlatform
+ , ""
+ , "#define " ++ cppify hostPlatform ++ "_BUILD 1"
+ , "#define " ++ cppify targetPlatform ++ "_HOST 1"
+ , ""
+ , "#define " ++ hostArch ++ "_BUILD_ARCH 1"
+ , "#define " ++ targetArch ++ "_HOST_ARCH 1"
+ , "#define BUILD_ARCH " ++ show hostArch
+ , "#define HOST_ARCH " ++ show targetArch
+ , ""
+ , "#define " ++ hostOs ++ "_BUILD_OS 1"
+ , "#define " ++ targetOs ++ "_HOST_OS 1"
+ , "#define BUILD_OS " ++ show hostOs
+ , "#define HOST_OS " ++ show targetOs
+ , ""
+ , "#define " ++ hostVendor ++ "_BUILD_VENDOR 1"
+ , "#define " ++ targetVendor ++ "_HOST_VENDOR 1"
+ , "#define BUILD_VENDOR " ++ show hostVendor
+ , "#define HOST_VENDOR " ++ show targetVendor
+ , ""
+ , "/* These TARGET macros are for backwards compatibility... DO NOT USE! */"
+ , "#define TargetPlatform_TYPE " ++ cppify targetPlatform
+ , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
+ , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
+ , "#define TARGET_ARCH " ++ show targetArch
+ , "#define " ++ targetOs ++ "_TARGET_OS 1"
+ , "#define TARGET_OS " ++ show targetOs
+ , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1" ]
+ ++
+ [ "#define UnregisterisedCompiler 1" | ghcUnreg ]
+ ++
+ [ "\n#endif /* __GHCPLATFORM_H__ */" ]
+
+-- | Generate @Config.hs@ files.
+generateConfigHs :: Expr String
+generateConfigHs = do
+ trackGenerateHs
+ cProjectName <- getSetting ProjectName
+ cProjectGitCommitId <- getSetting ProjectGitCommitId
+ cProjectVersion <- getSetting ProjectVersion
+ cProjectVersionInt <- getSetting ProjectVersionInt
+ cProjectPatchLevel <- getSetting ProjectPatchLevel
+ cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
+ cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
+ cBooterVersion <- getSetting GhcVersion
+ intLib <- getIntegerPackage
+ debugged <- ghcDebugged <$> expr flavour
+ let cIntegerLibraryType
+ | intLib == integerGmp = "IntegerGMP"
+ | intLib == integerSimple = "IntegerSimple"
+ | otherwise = error $ "Unknown integer library: " ++ pkgName intLib
+ cSupportsSplitObjs <- expr $ yesNo <$> supportsSplitObjects
+ cGhcWithInterpreter <- expr $ yesNo <$> ghcWithInterpreter
+ cGhcWithNativeCodeGen <- expr $ yesNo <$> ghcWithNativeCodeGen
+ cGhcWithSMP <- expr $ yesNo <$> ghcWithSMP
+ cGhcEnableTablesNextToCode <- expr $ yesNo <$> ghcEnableTablesNextToCode
+ cLeadingUnderscore <- expr $ yesNo <$> flag LeadingUnderscore
+ cGHC_UNLIT_PGM <- fmap takeFileName $ getBuilderPath Unlit
+ cLibFFI <- expr useLibFFIForAdjustors
+ rtsWays <- getRtsWays
+ cGhcRtsWithLibdw <- expr $ flag WithLibdw
+ let cGhcRTSWays = unwords $ map show rtsWays
+ return $ unlines
+ [ "{-# LANGUAGE CPP #-}"
+ , "module Config where"
+ , ""
+ , "import GhcPrelude"
+ , ""
+ , "#include \"ghc_boot_platform.h\""
+ , ""
+ , "data IntegerLibrary = IntegerGMP"
+ , " | IntegerSimple"
+ , " deriving Eq"
+ , ""
+ , "cBuildPlatformString :: String"
+ , "cBuildPlatformString = BuildPlatform_NAME"
+ , "cHostPlatformString :: String"
+ , "cHostPlatformString = HostPlatform_NAME"
+ , "cTargetPlatformString :: String"
+ , "cTargetPlatformString = TargetPlatform_NAME"
+ , ""
+ , "cProjectName :: String"
+ , "cProjectName = " ++ show cProjectName
+ , "cProjectGitCommitId :: String"
+ , "cProjectGitCommitId = " ++ show cProjectGitCommitId
+ , "cProjectVersion :: String"
+ , "cProjectVersion = " ++ show cProjectVersion
+ , "cProjectVersionInt :: String"
+ , "cProjectVersionInt = " ++ show cProjectVersionInt
+ , "cProjectPatchLevel :: String"
+ , "cProjectPatchLevel = " ++ show cProjectPatchLevel
+ , "cProjectPatchLevel1 :: String"
+ , "cProjectPatchLevel1 = " ++ show cProjectPatchLevel1
+ , "cProjectPatchLevel2 :: String"
+ , "cProjectPatchLevel2 = " ++ show cProjectPatchLevel2
+ , "cBooterVersion :: String"
+ , "cBooterVersion = " ++ show cBooterVersion
+ , "cStage :: String"
+ , "cStage = show (STAGE :: Int)"
+ , "cIntegerLibrary :: String"
+ , "cIntegerLibrary = " ++ show (pkgName intLib)
+ , "cIntegerLibraryType :: IntegerLibrary"
+ , "cIntegerLibraryType = " ++ cIntegerLibraryType
+ , "cSupportsSplitObjs :: String"
+ , "cSupportsSplitObjs = " ++ show cSupportsSplitObjs
+ , "cGhcWithInterpreter :: String"
+ , "cGhcWithInterpreter = " ++ show cGhcWithInterpreter
+ , "cGhcWithNativeCodeGen :: String"
+ , "cGhcWithNativeCodeGen = " ++ show cGhcWithNativeCodeGen
+ , "cGhcWithSMP :: String"
+ , "cGhcWithSMP = " ++ show cGhcWithSMP
+ , "cGhcRTSWays :: String"
+ , "cGhcRTSWays = " ++ show cGhcRTSWays
+ , "cGhcEnableTablesNextToCode :: String"
+ , "cGhcEnableTablesNextToCode = " ++ show cGhcEnableTablesNextToCode
+ , "cLeadingUnderscore :: String"
+ , "cLeadingUnderscore = " ++ show cLeadingUnderscore
+ , "cGHC_UNLIT_PGM :: String"
+ , "cGHC_UNLIT_PGM = " ++ show cGHC_UNLIT_PGM
+ , "cGHC_SPLIT_PGM :: String"
+ , "cGHC_SPLIT_PGM = " ++ show "ghc-split"
+ , "cLibFFI :: Bool"
+ , "cLibFFI = " ++ show cLibFFI
+ , "cGhcThreaded :: Bool"
+ , "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
+ , "cGhcDebugged :: Bool"
+ , "cGhcDebugged = " ++ show debugged
+ , "cGhcRtsWithLibdw :: Bool"
+ , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
+
+-- | Generate @ghcautoconf.h@ header.
+generateGhcAutoconfH :: Expr String
+generateGhcAutoconfH = do
+ trackGenerateHs
+ configHContents <- expr $ map undefinePackage <$> readFileLines configH
+ tablesNextToCode <- expr ghcEnableTablesNextToCode
+ ghcUnreg <- expr $ flag GhcUnregisterised
+ ccLlvmBackend <- getSetting CcLlvmBackend
+ ccClangBackend <- getSetting CcClangBackend
+ return . unlines $
+ [ "#ifndef __GHCAUTOCONF_H__"
+ , "#define __GHCAUTOCONF_H__" ]
+ ++ configHContents ++
+ [ "\n#define TABLES_NEXT_TO_CODE 1" | tablesNextToCode && not ghcUnreg ]
+ ++
+ [ "\n#define llvm_CC_FLAVOR 1" | ccLlvmBackend == "1" ]
+ ++
+ [ "\n#define clang_CC_FLAVOR 1" | ccClangBackend == "1" ]
+ ++
+ [ "#endif /* __GHCAUTOCONF_H__ */" ]
+ where
+ undefinePackage s
+ | "#define PACKAGE_" `isPrefixOf` s
+ = "/* #undef " ++ takeWhile (/=' ') (drop 8 s) ++ " */"
+ | otherwise = s
+
+-- | Generate @ghc_boot_platform.h@ headers.
+generateGhcBootPlatformH :: Expr String
+generateGhcBootPlatformH = do
+ trackGenerateHs
+ stage <- getStage
+ let chooseSetting x y = getSetting $ if stage == Stage0 then x else y
+ buildPlatform <- chooseSetting BuildPlatform HostPlatform
+ buildArch <- chooseSetting BuildArch HostArch
+ buildOs <- chooseSetting BuildOs HostOs
+ buildVendor <- chooseSetting BuildVendor HostVendor
+ hostPlatform <- chooseSetting HostPlatform TargetPlatform
+ hostArch <- chooseSetting HostArch TargetArch
+ hostOs <- chooseSetting HostOs TargetOs
+ hostVendor <- chooseSetting HostVendor TargetVendor
+ targetPlatform <- getSetting TargetPlatform
+ targetArch <- getSetting TargetArch
+ llvmTarget <- getSetting LlvmTarget
+ targetOs <- getSetting TargetOs
+ targetVendor <- getSetting TargetVendor
+ return $ unlines
+ [ "#ifndef __PLATFORM_H__"
+ , "#define __PLATFORM_H__"
+ , ""
+ , "#define BuildPlatform_NAME " ++ show buildPlatform
+ , "#define HostPlatform_NAME " ++ show hostPlatform
+ , "#define TargetPlatform_NAME " ++ show targetPlatform
+ , ""
+ , "#define " ++ cppify buildPlatform ++ "_BUILD 1"
+ , "#define " ++ cppify hostPlatform ++ "_HOST 1"
+ , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
+ , ""
+ , "#define " ++ buildArch ++ "_BUILD_ARCH 1"
+ , "#define " ++ hostArch ++ "_HOST_ARCH 1"
+ , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
+ , "#define BUILD_ARCH " ++ show buildArch
+ , "#define HOST_ARCH " ++ show hostArch
+ , "#define TARGET_ARCH " ++ show targetArch
+ , "#define LLVM_TARGET " ++ show llvmTarget
+ , ""
+ , "#define " ++ buildOs ++ "_BUILD_OS 1"
+ , "#define " ++ hostOs ++ "_HOST_OS 1"
+ , "#define " ++ targetOs ++ "_TARGET_OS 1"
+ , "#define BUILD_OS " ++ show buildOs
+ , "#define HOST_OS " ++ show hostOs
+ , "#define TARGET_OS " ++ show targetOs
+ , ""
+ , "#define " ++ buildVendor ++ "_BUILD_VENDOR 1"
+ , "#define " ++ hostVendor ++ "_HOST_VENDOR 1"
+ , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1"
+ , "#define BUILD_VENDOR " ++ show buildVendor
+ , "#define HOST_VENDOR " ++ show hostVendor
+ , "#define TARGET_VENDOR " ++ show targetVendor
+ , ""
+ , "#endif /* __PLATFORM_H__ */" ]
+
+-- | Generate @ghcversion.h@ header.
+generateGhcVersionH :: Expr String
+generateGhcVersionH = do
+ trackGenerateHs
+ version <- getSetting ProjectVersionInt
+ patchLevel1 <- getSetting ProjectPatchLevel1
+ patchLevel2 <- getSetting ProjectPatchLevel2
+ return . unlines $
+ [ "#ifndef __GHCVERSION_H__"
+ , "#define __GHCVERSION_H__"
+ , ""
+ , "#ifndef __GLASGOW_HASKELL__"
+ , "# define __GLASGOW_HASKELL__ " ++ version
+ , "#endif"
+ , ""]
+ ++
+ [ "#define __GLASGOW_HASKELL_PATCHLEVEL1__ " ++ patchLevel1 | patchLevel1 /= "" ]
+ ++
+ [ "#define __GLASGOW_HASKELL_PATCHLEVEL2__ " ++ patchLevel2 | patchLevel2 /= "" ]
+ ++
+ [ ""
+ , "#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\\"
+ , " ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \\"
+ , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
+ , " && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ || \\"
+ , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
+ , " && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \\"
+ , " && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )"
+ , ""
+ , "#endif /* __GHCVERSION_H__ */" ]
+
+-- | Generate @Version.hs@ files.
+generateVersionHs :: Expr String
+generateVersionHs = do
+ trackGenerateHs
+ projectVersion <- getSetting ProjectVersion
+ targetOs <- getSetting TargetOs
+ targetArch <- getSetting TargetArch
+ return $ unlines
+ [ "module Version where"
+ , "version, targetOS, targetARCH :: String"
+ , "version = " ++ show projectVersion
+ , "targetOS = " ++ show targetOs
+ , "targetARCH = " ++ show targetArch ]
diff --git a/hadrian/src/Rules/Gmp.hs b/hadrian/src/Rules/Gmp.hs
new file mode 100644
index 0000000000..46fad8a32c
--- /dev/null
+++ b/hadrian/src/Rules/Gmp.hs
@@ -0,0 +1,119 @@
+module Rules.Gmp (
+ gmpRules, gmpBuildPath, gmpObjectsDir, gmpLibraryH, gmpBuildInfoPath
+ ) where
+
+import Base
+import Context
+import GHC
+import Oracles.Setting
+import Target
+import Utilities
+
+gmpBase :: FilePath
+gmpBase = pkgPath integerGmp -/- "gmp"
+
+gmpLibraryInTreeH :: FilePath
+gmpLibraryInTreeH = "include/gmp.h"
+
+gmpLibrary :: FilePath
+gmpLibrary = ".libs/libgmp.a"
+
+-- | GMP is considered a Stage1 package. This determines GMP build directory.
+gmpContext :: Context
+gmpContext = vanillaContext Stage1 integerGmp
+
+-- | Build directory for in-tree GMP library.
+gmpBuildPath :: Action FilePath
+gmpBuildPath = buildRoot <&> (-/- stageString (stage gmpContext) -/- "gmp")
+
+-- | GMP library header, relative to 'gmpBuildPath'.
+gmpLibraryH :: FilePath
+gmpLibraryH = "include/ghc-gmp.h"
+
+-- | Directory for GMP library object files, relative to 'gmpBuildPath'.
+gmpObjectsDir :: FilePath
+gmpObjectsDir = "objs"
+
+-- | Path to the GMP library buildinfo file.
+gmpBuildInfoPath :: FilePath
+gmpBuildInfoPath = pkgPath integerGmp -/- "integer-gmp.buildinfo"
+
+configureEnvironment :: Action [CmdOption]
+configureEnvironment = sequence [ builderEnvironment "CC" $ Cc CompileC Stage1
+ , builderEnvironment "AR" (Ar Unpack Stage1)
+ , builderEnvironment "NM" Nm ]
+
+gmpRules :: Rules ()
+gmpRules = do
+ -- Copy appropriate GMP header and object files
+ "//" ++ gmpLibraryH %> \header -> do
+ windows <- windowsHost
+ configMk <- readFile' $ gmpBase -/- "config.mk"
+ if not windows && -- TODO: We don't use system GMP on Windows. Fix?
+ any (`isInfixOf` configMk) [ "HaveFrameworkGMP = YES", "HaveLibGmp = YES" ]
+ then do
+ putBuild "| GMP library/framework detected and will be used"
+ 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)
+
+ -- Build in-tree GMP library
+ "//" ++ gmpLibrary %> \lib -> do
+ gmpPath <- gmpBuildPath
+ build $ target gmpContext (Make gmpPath) [gmpPath -/- "Makefile"] [lib]
+ putSuccess "| Successfully built custom library 'gmp'"
+
+ -- In-tree GMP header is built by the gmpLibraryH rule
+ "//" ++ gmpLibraryInTreeH %> \_ -> do
+ gmpPath <- gmpBuildPath
+ need [gmpPath -/- gmpLibraryH]
+
+ -- This causes integerGmp package to be configured, hence creating the files
+ [gmpBase -/- "config.mk", gmpBuildInfoPath] &%> \_ -> do
+ dataFile <- pkgDataFile gmpContext
+ need [dataFile]
+
+ -- Run GMP's configure script
+ -- TODO: Get rid of hard-coded @gmp@.
+ "//gmp/Makefile" %> \mk -> do
+ env <- configureEnvironment
+ gmpPath <- gmpBuildPath
+ need [mk <.> "in"]
+ buildWithCmdOptions env $
+ target gmpContext (Configure gmpPath) [mk <.> "in"] [mk]
+
+ -- Extract in-tree GMP sources and apply patches
+ "//gmp/Makefile.in" %> \_ -> do
+ gmpPath <- gmpBuildPath
+ 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.
+ -- That's because the doc/ directory contents are under the GFDL,
+ -- which causes problems for Debian.
+ tarball <- unifyPath . fromSingleton "Exactly one GMP tarball is expected"
+ <$> getDirectoryFiles "" [gmpBase -/- "gmp-tarballs/gmp*.tar.bz2"]
+
+ withTempDir $ \dir -> do
+ let tmp = unifyPath dir
+ need [tarball]
+ build $ target gmpContext (Tar Extract) [tarball] [tmp]
+
+ let patch = gmpBase -/- "gmpsrc.patch"
+ patchName = takeFileName patch
+ copyFile patch $ tmp -/- patchName
+ applyPatch tmp patchName
+
+ let name = dropExtension . dropExtension $ takeFileName tarball
+ unpack = fromMaybe . error $ "gmpRules: expected suffix "
+ ++ "-nodoc (found: " ++ name ++ ")."
+ libName = unpack $ stripSuffix "-nodoc" name
+
+ moveDirectory (tmp -/- libName) gmpPath
diff --git a/hadrian/src/Rules/Install.hs b/hadrian/src/Rules/Install.hs
new file mode 100644
index 0000000000..bcdbf33e34
--- /dev/null
+++ b/hadrian/src/Rules/Install.hs
@@ -0,0 +1,336 @@
+module Rules.Install (installRules) where
+
+import Hadrian.Oracles.DirectoryContents
+import qualified System.Directory as IO
+
+import Base
+import Expression
+import Oracles.Setting
+import Rules
+import Rules.Generate
+import Rules.Libffi
+import Rules.Wrappers
+import Settings
+import Settings.Packages.Rts
+import Target
+import Utilities
+
+{- | Install the built binaries etc. to the @destDir ++ prefix@.
+
+The installation prefix is usually @/usr/local@ on a Unix system.
+The resulting tree structure is organized under @destDir ++ prefix@ as follows:
+
+* @bin@: executable wrapper scripts, installed by 'installBins', e.g. @ghc@.
+
+* @lib/ghc-<version>/bin@: executable binaries/scripts,
+ installed by 'installLibExecs' and 'installLibExecScripts'.
+
+* @lib/ghc-<version>/include@: headers etc., installed by 'installIncludes'.
+
+* @lib/ghc-<version>/<pkg-name>@: built packages, e.g. @base@, installed
+ by 'installPackages'.
+
+* @lib/ghc-<version>/settings@ etc.: other files in @lib@ directory,
+ installed by 'installCommonLibs'.
+
+XXX (izgzhen): Do we need @INSTALL_OPTS@ in the make scripts?
+-}
+installRules :: Rules ()
+installRules =
+ "install" ~> do
+ installIncludes
+ installPackageConf
+ installCommonLibs
+ installLibExecs
+ installLibExecScripts
+ installBins
+ installPackages
+ installDocs
+
+-- TODO: Get rid of hard-coded list.
+-- | Binaries to install.
+installBinPkgs :: [Package]
+installBinPkgs = [ghc, ghcPkg, ghcSplit, hp2ps, hpc, hsc2hs, runGhc, unlit]
+
+getLibExecDir :: Action FilePath
+getLibExecDir = (-/- "bin") <$> installGhcLibDir
+
+-- ref: ghc.mk
+-- | Install executable scripts to @prefix/lib/bin@.
+installLibExecScripts :: Action ()
+installLibExecScripts = do
+ libExecDir <- getLibExecDir
+ destDir <- getDestDir
+ installDirectory (destDir ++ libExecDir)
+ forM_ libExecScripts $ \script -> installScript script (destDir ++ libExecDir)
+ where
+ libExecScripts :: [FilePath]
+ libExecScripts = [ghcSplitPath]
+
+-- ref: ghc.mk
+-- | Install executable binaries to @prefix/lib/bin@.
+installLibExecs :: Action ()
+installLibExecs = do
+ libExecDir <- getLibExecDir
+ destDir <- getDestDir
+ installDirectory (destDir ++ libExecDir)
+ forM_ installBinPkgs $ \pkg ->
+ withInstallStage pkg $ \stage -> do
+ context <- programContext stage pkg
+ let bin = inplaceLibBinPath -/- programName context <.> exe
+ installProgram bin (destDir ++ libExecDir)
+ when (pkg == ghc) $
+ moveFile (destDir ++ libExecDir -/- programName context <.> exe)
+ (destDir ++ libExecDir -/- "ghc" <.> exe)
+
+-- ref: ghc.mk
+-- | Install executable wrapper scripts to @prefix/bin@.
+installBins :: Action ()
+installBins = do
+ binDir <- setting InstallBinDir
+ libDir <- installGhcLibDir
+ destDir <- getDestDir
+ installDirectory (destDir ++ binDir)
+ win <- windowsHost
+ when win $
+ copyDirectoryContents matchAll (destDir ++ libDir -/- "bin") (destDir ++ binDir)
+ unless win $ forM_ installBinPkgs $ \pkg ->
+ withInstallStage pkg $ \stage -> do
+ context <- programContext stage pkg
+ version <- setting ProjectVersion
+ -- Name of the binary file
+ let binName | pkg == ghc = "ghc-" ++ version <.> exe
+ | otherwise = programName context ++ "-" ++ version <.> exe
+ -- Name of the symbolic link
+ let symName | pkg == ghc = "ghc" <.> exe
+ | otherwise = programName context <.> exe
+ case lookup context installWrappers of
+ Nothing -> return ()
+ Just wrapper -> do
+ contents <- interpretInContext context $
+ wrapper (WrappedBinary (destDir ++ libDir) symName)
+ let wrapperPath = destDir ++ binDir -/- binName
+ writeFileChanged wrapperPath contents
+ makeExecutable wrapperPath
+ unlessM windowsHost $
+ linkSymbolic (destDir ++ binDir -/- binName)
+ (destDir ++ binDir -/- symName)
+
+-- | Perform an action depending on the install stage or do nothing if the
+-- package is not installed.
+withInstallStage :: Package -> (Stage -> Action ()) -> Action ()
+withInstallStage pkg m = do
+ maybeStage <- installStage pkg
+ case maybeStage of { Just stage -> m stage; Nothing -> return () }
+
+pkgConfInstallPath :: Action FilePath
+pkgConfInstallPath = buildPath (vanillaContext Stage0 rts) <&> (-/- "package.conf.install")
+
+-- ref: rules/manual-package-conf.mk
+-- TODO: Should we use a temporary file instead of pkgConfInstallPath?
+-- | Install @package.conf.install@ for each package. Note that it will be
+-- recreated each time.
+installPackageConf :: Action ()
+installPackageConf = do
+ let context = vanillaContext Stage0 rts
+ confPath <- pkgConfInstallPath
+ liftIO $ IO.createDirectoryIfMissing True (takeDirectory confPath)
+ build $ target context HsCpp [ pkgPath rts -/- "package.conf.in" ]
+ [ confPath <.> "raw" ]
+ Stdout content <- cmd "grep" [ "-v", "^#pragma GCC"
+ , confPath <.> "raw" ]
+ withTempFile $ \tmp -> do
+ liftIO $ writeFile tmp content
+ Stdout result <- cmd "sed" [ "-e", "s/\"\"//g", "-e", "s/:[ ]*,/: /g", tmp ]
+ liftIO $ writeFile confPath result
+
+-- ref: ghc.mk
+-- | Install packages to @prefix/lib@.
+installPackages :: Action ()
+installPackages = do
+ confPath <- pkgConfInstallPath
+ need [confPath]
+
+ ghcLibDir <- installGhcLibDir
+ binDir <- setting InstallBinDir
+ destDir <- getDestDir
+
+ -- Install package.conf
+ let installedPackageConf = destDir ++ ghcLibDir -/- "package.conf.d"
+ installDirectory (destDir ++ ghcLibDir)
+ removeDirectory installedPackageConf
+ installDirectory installedPackageConf
+
+ -- Install RTS
+ let rtsDir = destDir ++ ghcLibDir -/- "rts"
+ installDirectory rtsDir
+ ways <- interpretInContext (vanillaContext Stage1 rts) getRtsWays
+ rtsLibs <- mapM (pkgLibraryFile . Context Stage1 rts) ways
+ ffiLibs <- mapM rtsLibffiLibrary ways
+
+ -- TODO: Add dynamic libraries.
+ forM_ (rtsLibs ++ ffiLibs) $ \lib -> installData [lib] rtsDir
+
+ -- TODO: Remove this hack required for @ghc-cabal copy@.
+ -- See https://github.com/snowleopard/hadrian/issues/327.
+ ghcBootPlatformHeader <-
+ buildPath (vanillaContext Stage1 compiler) <&> (-/- "ghc_boot_platform.h")
+ copyFile ghcBootPlatformHeader (pkgPath compiler -/- "ghc_boot_platform.h")
+
+ installPackages <- filterM ((isJust <$>) . installStage)
+ (knownPackages \\ [rts, libffi])
+
+ installLibPkgs <- topsortPackages (filter isLibrary installPackages)
+
+ -- TODO: Figure out what is the root cause of the missing ghc-gmp.h error.
+ copyFile (pkgPath integerGmp -/- "gmp/ghc-gmp.h") (pkgPath integerGmp -/- "ghc-gmp.h")
+
+ forM_ installLibPkgs $ \pkg ->
+ case pkgCabalFile pkg of
+ Nothing -> error $ "Non-Haskell project in installLibPkgs" ++ show pkg
+ Just cabalFile -> withInstallStage pkg $ \stage -> do
+ let context = vanillaContext stage pkg
+ top <- topDirectory
+ installDistDir <- buildPath context
+ let absInstallDistDir = top -/- installDistDir
+
+ need =<< packageTargets True stage pkg
+ docDir <- installDocDir
+ ghclibDir <- installGhcLibDir
+
+ -- Copy over packages
+ strip <- stripCmdPath
+ ways <- interpretInContext context getLibraryWays
+ -- TODO: Remove hard-coded @ghc-cabal@ path.
+ let ghcCabalInplace = inplaceBinPath -/- "ghc-cabal" <.> exe
+ need [ghcCabalInplace]
+
+ pkgConf <- pkgConfFile context
+ need [cabalFile, pkgConf] -- TODO: Check if we need 'pkgConf'.
+
+ -- TODO: Drop redundant copies required by @ghc-cabal@.
+ -- See https://github.com/snowleopard/hadrian/issues/318.
+ quietly $ copyDirectoryContentsUntracked (Not excluded)
+ installDistDir (installDistDir -/- "build")
+
+ pref <- setting InstallPrefix
+ unit $ cmd ghcCabalInplace [ "copy"
+ , pkgPath pkg
+ , absInstallDistDir
+ , strip
+ , destDir
+ , pref
+ , ghclibDir
+ , docDir -/- "html/libraries"
+ , unwords (map show ways) ]
+
+ -- Register packages
+ let installedGhcPkgReal = destDir ++ binDir -/- "ghc-pkg" <.> exe
+ installedGhcReal = destDir ++ binDir -/- "ghc" <.> exe
+ -- TODO: Extend GhcPkg builder args to support --global-package-db
+ unit $ cmd installedGhcPkgReal [ "--force", "--global-package-db"
+ , installedPackageConf, "update"
+ , confPath ]
+
+ forM_ installLibPkgs $ \pkg ->
+ withInstallStage pkg $ \stage -> do
+ let context = vanillaContext stage pkg
+ top <- topDirectory
+ installDistDir <- (top -/-) <$> buildPath context
+ -- TODO: better reference to the built inplace binary path
+ let ghcCabalInplace = inplaceBinPath -/- "ghc-cabal"
+ pref <- setting InstallPrefix
+ docDir <- installDocDir
+ r <- relocatableBuild
+ unit $ cmd ghcCabalInplace
+ [ "register"
+ , pkgPath pkg
+ , installDistDir
+ , installedGhcReal
+ , installedGhcPkgReal
+ , destDir ++ ghcLibDir
+ , destDir
+ , destDir ++ pref
+ , destDir ++ ghcLibDir
+ , destDir ++ docDir -/- "html/libraries"
+ , if r then "YES" else "NO" ]
+
+ confs <- getDirectoryContents installedPackageConf
+ forM_ confs (\f -> createData $ installedPackageConf -/- f)
+ unit $ cmd installedGhcPkgReal [ "--force", "--global-package-db"
+ , installedPackageConf, "recache" ]
+ where
+ createData f = unit $ cmd "chmod" [ "644", f ]
+ excluded = Or [ Test "//haddock-prologue.txt"
+ , Test "//package-data.mk"
+ , Test "//setup-config"
+ , Test "//inplace-pkg-config"
+ , Test "//build" ]
+
+-- ref: ghc.mk
+-- | Install settings etc. files to @prefix/lib@.
+installCommonLibs :: Action ()
+installCommonLibs = do
+ ghcLibDir <- installGhcLibDir
+ destDir <- getDestDir
+ installLibsTo inplaceLibCopyTargets (destDir ++ ghcLibDir)
+
+-- ref: ghc.mk
+-- | Install library files to some path.
+installLibsTo :: [FilePath] -> FilePath -> Action ()
+installLibsTo libs dir = do
+ installDirectory dir
+ forM_ libs $ \lib -> case takeExtension lib of
+ ".a" -> do
+ let out = dir -/- takeFileName lib
+ installData [out] dir
+ runBuilder Ranlib [out] [out] [out]
+ _ -> installData [lib] dir
+
+-- ref: includes/ghc.mk
+-- | All header files are in includes/{one of these subdirectories}.
+includeHSubdirs :: [FilePath]
+includeHSubdirs = [".", "rts", "rts/prof", "rts/storage", "stg"]
+
+-- ref: includes/ghc.mk
+-- | Install header files to @prefix/lib/ghc-<version>/include@.
+installIncludes :: Action ()
+installIncludes = do
+ ghclibDir <- installGhcLibDir
+ destDir <- getDestDir
+ let ghcheaderDir = ghclibDir -/- "include"
+ installDirectory (destDir ++ ghcheaderDir)
+ forM_ includeHSubdirs $ \dir -> do
+ installDirectory (destDir ++ ghcheaderDir -/- dir)
+ headers <- getDirectoryFiles ("includes" -/- dir) ["*.h"]
+ installHeader (map (("includes" -/- dir) -/-) headers)
+ (destDir ++ ghcheaderDir -/- dir ++ "/")
+ root <- buildRoot
+ rtsPath <- rtsBuildPath
+ installHeader (fmap (root -/-) includesDependencies ++
+ [root -/- generatedDir -/- "DerivedConstants.h"] ++
+ fmap (rtsPath -/-) libffiDependencies)
+ (destDir ++ ghcheaderDir ++ "/")
+ where
+ installHeader = installData -- they share same arguments
+
+-- ref: ghc.mk
+-- | Install documentation to @prefix/share/doc/ghc-<version>@.
+installDocs :: Action ()
+installDocs = do
+ destDir <- getDestDir
+ docDir <- installDocDir
+ root <- buildRoot
+ installDirectory (destDir ++ docDir)
+
+ let usersGuide = root -/- "docs/pdfs/users_guide.pdf"
+ whenM (doesFileExist usersGuide) $
+ installData [usersGuide] (destDir ++ docDir)
+
+ let htmlDocDir = destDir ++ docDir -/- "html"
+ installDirectory htmlDocDir
+ installData ["docs/index.html"] htmlDocDir
+
+ forM_ ["Haddock", "libraries", "users_guide"] $ \dirname -> do
+ let dir = root -/- "docs/html" -/- dirname
+ whenM (doesDirectoryExist dir) $ copyDirectory dir htmlDocDir
diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs
new file mode 100644
index 0000000000..73f481d88a
--- /dev/null
+++ b/hadrian/src/Rules/Libffi.hs
@@ -0,0 +1,108 @@
+module Rules.Libffi (libffiRules, libffiBuildPath, libffiDependencies) where
+
+import Hadrian.Utilities
+
+import Settings.Builders.Common
+import Settings.Packages.Rts
+import Target
+import Utilities
+
+-- | Libffi is considered a Stage1 package. This determines its build directory.
+libffiContext :: Context
+libffiContext = vanillaContext Stage1 libffi
+
+-- | Build directory for in-tree Libffi library.
+libffiBuildPath :: Action FilePath
+libffiBuildPath = buildPath libffiContext
+
+libffiDependencies :: [FilePath]
+libffiDependencies = ["ffi.h", "ffitarget.h"]
+
+libffiLibrary :: FilePath
+libffiLibrary = "inst/lib/libffi.a"
+
+fixLibffiMakefile :: FilePath -> String -> String
+fixLibffiMakefile top =
+ replace "-MD" "-MMD"
+ . replace "@toolexeclibdir@" "$(libdir)"
+ . replace "@INSTALL@" ("$(subst ../install-sh," ++ top ++ "/install-sh,@INSTALL@)")
+
+-- TODO: remove code duplication (see Settings/Builders/GhcCabal.hs)
+-- TODO: check code duplication w.r.t. ConfCcArgs
+configureEnvironment :: Action [CmdOption]
+configureEnvironment = do
+ cFlags <- interpretInContext libffiContext $ mconcat
+ [ cArgs
+ , getStagedSettingList ConfCcArgs ]
+ ldFlags <- interpretInContext libffiContext ldArgs
+ sequence [ builderEnvironment "CC" $ Cc CompileC Stage1
+ , builderEnvironment "CXX" $ Cc CompileC Stage1
+ , builderEnvironment "LD" Ld
+ , builderEnvironment "AR" (Ar Unpack Stage1)
+ , builderEnvironment "NM" Nm
+ , builderEnvironment "RANLIB" Ranlib
+ , return . AddEnv "CFLAGS" $ unwords cFlags ++ " -w"
+ , return . AddEnv "LDFLAGS" $ unwords ldFlags ++ " -w" ]
+
+libffiRules :: Rules ()
+libffiRules = do
+ fmap ("//rts" -/-) libffiDependencies &%> \_ -> do
+ libffiPath <- libffiBuildPath
+ need [libffiPath -/- libffiLibrary]
+
+ "//" ++ libffiLibrary %> \_ -> do
+ useSystemFfi <- flag UseSystemFfi
+ rtsPath <- rtsBuildPath
+ if useSystemFfi
+ then do
+ ffiIncludeDir <- setting FfiIncludeDir
+ putBuild "| System supplied FFI library will be used"
+ forM_ ["ffi.h", "ffitarget.h"] $ \file ->
+ copyFile (ffiIncludeDir -/- file) (rtsPath -/- file)
+ putSuccess "| Successfully copied system FFI library header files"
+ else do
+ libffiPath <- libffiBuildPath
+ build $ target libffiContext (Make libffiPath) [] []
+
+ hs <- getDirectoryFiles "" [libffiPath -/- "inst/include/*"]
+ forM_ hs $ \header ->
+ copyFile header (rtsPath -/- takeFileName header)
+
+ ways <- interpretInContext libffiContext (getLibraryWays <> getRtsWays)
+ forM_ (nubOrd ways) $ \way -> do
+ rtsLib <- rtsLibffiLibrary way
+ copyFileUntracked (libffiPath -/- libffiLibrary) rtsLib
+
+ putSuccess "| Successfully built custom library 'libffi'"
+
+ "//libffi/Makefile.in" %> \mkIn -> do
+ libffiPath <- libffiBuildPath
+ removeDirectory libffiPath
+ tarball <- unifyPath . fromSingleton "Exactly one LibFFI tarball is expected"
+ <$> getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"]
+
+ need [tarball]
+ -- Go from 'libffi-3.99999+git20171002+77e130c.tar.gz' to 'libffi-3.99999'
+ let libname = takeWhile (/= '+') $ takeFileName tarball
+
+ root <- buildRoot
+ removeDirectory (root -/- libname)
+ -- TODO: Simplify.
+ actionFinally (do
+ build $ target libffiContext (Tar Extract) [tarball] [root]
+ moveDirectory (root -/- libname) libffiPath) $
+ removeFiles root [libname <//> "*"]
+
+ top <- topDirectory
+ fixFile mkIn (fixLibffiMakefile top)
+
+ -- TODO: Get rid of hard-coded @libffi@.
+ "//libffi/Makefile" %> \mk -> do
+ need [mk <.> "in"]
+ libffiPath <- libffiBuildPath
+ forM_ ["config.guess", "config.sub"] $ \file ->
+ copyFile file (libffiPath -/- file)
+
+ env <- configureEnvironment
+ buildWithCmdOptions env $
+ target libffiContext (Configure libffiPath) [mk <.> "in"] [mk]
diff --git a/hadrian/src/Rules/Library.hs b/hadrian/src/Rules/Library.hs
new file mode 100644
index 0000000000..e6e5b167ff
--- /dev/null
+++ b/hadrian/src/Rules/Library.hs
@@ -0,0 +1,103 @@
+module Rules.Library (
+ buildPackageLibrary, buildPackageGhciLibrary, buildDynamicLib
+ ) where
+
+import Hadrian.Haskell.Cabal
+import qualified System.Directory as IO
+
+import Base
+import Context
+import Expression hiding (way, package)
+import Flavour
+import Oracles.ModuleFiles
+import Oracles.PackageData
+import Oracles.Setting
+import Rules.Gmp
+import Settings
+import Target
+import Utilities
+
+libraryObjects :: Context -> Action [FilePath]
+libraryObjects context@Context{..} = do
+ hsObjs <- hsObjects context
+ noHsObjs <- nonHsObjects context
+
+ -- This will create split objects if required (we don't track them
+ -- explicitly as this would needlessly bloat the Shake database).
+ need $ noHsObjs ++ hsObjs
+
+ split <- interpretInContext context =<< splitObjects <$> flavour
+ let getSplitObjs = concatForM hsObjs $ \obj -> do
+ let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split"
+ contents <- liftIO $ IO.getDirectoryContents dir
+ return . map (dir -/-) $ filter (not . all (== '.')) contents
+
+ (noHsObjs ++) <$> if split then getSplitObjs else return hsObjs
+
+buildDynamicLib :: Context -> Rules ()
+buildDynamicLib context@Context{..} = do
+ let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package
+ -- OS X
+ libPrefix ++ "*.dylib" %> buildDynamicLibUnix
+ -- Linux
+ libPrefix ++ "*.so" %> buildDynamicLibUnix
+ -- TODO: Windows
+ where
+ buildDynamicLibUnix lib = do
+ deps <- contextDependencies context
+ need =<< mapM pkgLibraryFile deps
+ objs <- libraryObjects context
+ build $ target context (Ghc LinkHs stage) objs [lib]
+
+buildPackageLibrary :: Context -> Rules ()
+buildPackageLibrary context@Context {..} = do
+ let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package
+ libPrefix ++ "*" ++ (waySuffix way <.> "a") %%> \a -> do
+ objs <- libraryObjects context
+ asuf <- libsuf way
+ let isLib0 = ("//*-0" ++ asuf) ?== a
+ removeFile a
+ if isLib0 then build $ target context (Ar Pack stage) [] [a] -- TODO: Scan for dlls
+ else build $ target context (Ar Pack stage) objs [a]
+
+ synopsis <- traverse pkgSynopsis (pkgCabalFile package)
+ unless isLib0 . putSuccess $ renderLibrary
+ (quote (pkgName package) ++ " (" ++ show stage ++ ", way "
+ ++ show way ++ ").") a synopsis
+
+buildPackageGhciLibrary :: Context -> Rules ()
+buildPackageGhciLibrary context@Context {..} = priority 2 $ do
+ let libPrefix = "//" ++ contextDir context -/- "HS" ++ pkgName package
+ libPrefix ++ "*" ++ (waySuffix way <.> "o") %> \obj -> do
+ objs <- allObjects context
+ need objs
+ build $ target context Ld objs [obj]
+
+allObjects :: Context -> Action [FilePath]
+allObjects context = (++) <$> nonHsObjects context <*> hsObjects context
+
+nonHsObjects :: Context -> Action [FilePath]
+nonHsObjects context = do
+ path <- buildPath context
+ cObjs <- cObjects context
+ cmmSrcs <- pkgDataList (CmmSrcs path)
+ cmmObjs <- mapM (objectPath context) cmmSrcs
+ eObjs <- extraObjects context
+ return $ cObjs ++ cmmObjs ++ eObjs
+
+cObjects :: Context -> Action [FilePath]
+cObjects context = do
+ path <- buildPath context
+ srcs <- pkgDataList (CSrcs path)
+ objs <- mapM (objectPath context) srcs
+ return $ if way context == threaded
+ then objs
+ else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs
+
+extraObjects :: Context -> Action [FilePath]
+extraObjects context
+ | package context == integerGmp = do
+ gmpPath <- gmpBuildPath
+ need [gmpPath -/- gmpLibraryH]
+ map unifyPath <$> getDirectoryFiles "" [gmpPath -/- gmpObjectsDir -/- "*.o"]
+ | otherwise = return []
diff --git a/hadrian/src/Rules/PackageData.hs b/hadrian/src/Rules/PackageData.hs
new file mode 100644
index 0000000000..2442b03de3
--- /dev/null
+++ b/hadrian/src/Rules/PackageData.hs
@@ -0,0 +1,119 @@
+module Rules.PackageData (buildPackageData) where
+
+import Base
+import Context
+import Expression
+import Oracles.Setting
+import Rules.Generate
+import Settings.Packages.Rts
+import Target
+import Utilities
+
+-- | Build @package-data.mk@ by using ghc-cabal utility to process .cabal files.
+buildPackageData :: Context -> Rules ()
+buildPackageData context@Context {..} = do
+ let dir = "//" ++ contextDir context
+ cabalFile = unsafePkgCabalFile package -- TODO: improve
+ configure = pkgPath package -/- "configure"
+ -- TODO: Get rid of hardcoded file paths.
+ [dir -/- "package-data.mk", dir -/- "setup-config"] &%> \[mk, setupConfig] -> do
+ -- Make sure all generated dependencies are in place before proceeding.
+ orderOnly =<< interpretInContext context generatedDependencies
+
+ -- GhcCabal may run the configure script, so we depend on it.
+ whenM (doesFileExist $ configure <.> "ac") $ need [configure]
+
+ -- Before we configure a package its dependencies need to be registered.
+ need =<< mapM pkgConfFile =<< contextDependencies context
+
+ need [cabalFile]
+ build $ target context GhcCabal [cabalFile] [mk, setupConfig]
+ postProcessPackageData context mk
+
+ -- TODO: Get rid of hardcoded file paths.
+ dir -/- "inplace-pkg-config" %> \conf -> do
+ path <- buildPath context
+ dataFile <- pkgDataFile context
+ need [dataFile] -- ghc-cabal builds inplace package configuration file
+ if package == rts
+ then do
+ genPath <- buildRoot <&> (-/- generatedDir)
+ rtsPath <- rtsBuildPath
+ need [rtsConfIn]
+ build $ target context HsCpp [rtsConfIn] [conf]
+ fixFile conf $ unlines
+ . map
+ ( replace "\"\"" ""
+ . replace "rts/dist/build" rtsPath
+ . replace "includes/dist-derivedconstants/header" genPath )
+ . lines
+ else
+ fixFile conf $ unlines . map (replace (path </> "build") path) . lines
+
+ priority 2.0 $ when (nonCabalContext context) $ dir -/- "package-data.mk" %>
+ generatePackageData context
+
+generatePackageData :: Context -> FilePath -> Action ()
+generatePackageData context@Context {..} file = do
+ orderOnly =<< interpretInContext context generatedDependencies
+ asmSrcs <- packageAsmSources package
+ cSrcs <- packageCSources package
+ cmmSrcs <- packageCmmSources package
+ genPath <- buildRoot <&> (-/- generatedDir)
+ writeFileChanged file . unlines $
+ [ "S_SRCS = " ++ unwords asmSrcs ] ++
+ [ "C_SRCS = " ++ unwords cSrcs ] ++
+ [ "CMM_SRCS = " ++ unwords cmmSrcs ] ++
+ [ "DEP_EXTRA_LIBS = m" | package == hp2ps ] ++
+ [ "CC_OPTS = -I" ++ genPath | package `elem` [hp2ps, rts]] ++
+ [ "MODULES = Main" | package == ghcCabal ] ++
+ [ "HS_SRC_DIRS = ." | package == ghcCabal ]
+ putSuccess $ "| Successfully generated " ++ file
+
+packageCSources :: Package -> Action [FilePath]
+packageCSources pkg
+ | pkg /= rts = getDirectoryFiles (pkgPath pkg) ["*.c"]
+ | otherwise = do
+ windows <- windowsHost
+ rtsPath <- rtsBuildPath
+ sources <- fmap (map unifyPath) . getDirectoryFiles (pkgPath pkg) .
+ map (-/- "*.c") $ [ ".", "hooks", "sm", "eventlog", "linker" ] ++
+ [ if windows then "win32" else "posix" ]
+ return $ sources ++ [ rtsPath -/- "c/sm/Evac_thr.c" ]
+ ++ [ rtsPath -/- "c/sm/Scav_thr.c" ]
+
+packageAsmSources :: Package -> Action [FilePath]
+packageAsmSources pkg
+ | pkg /= rts = return []
+ | otherwise = do
+ buildAdjustor <- anyTargetArch ["i386", "powerpc", "powerpc64"]
+ buildStgCRunAsm <- anyTargetArch ["powerpc64le"]
+ return $ [ "AdjustorAsm.S" | buildAdjustor ]
+ ++ [ "StgCRunAsm.S" | buildStgCRunAsm ]
+
+packageCmmSources :: Package -> Action [FilePath]
+packageCmmSources pkg
+ | pkg /= rts = return []
+ | otherwise = do
+ rtsPath <- rtsBuildPath
+ sources <- getDirectoryFiles (pkgPath pkg) ["*.cmm"]
+ return $ sources ++ [ rtsPath -/- "cmm/AutoApply.cmm" ]
+
+-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
+-- 1) Drop lines containing '$'. For example, get rid of
+-- @libraries/Win32_dist-install_CMM_SRCS := $(addprefix cbits/,$(notdir ...@
+-- and replace it with a tracked call to getDirectoryFiles.
+-- 2) Drop path prefixes to individual settings.
+-- For example, @libraries/deepseq/dist-install_VERSION = 1.4.0.0@
+-- is replaced by @VERSION = 1.4.0.0@.
+-- Reason: Shake's built-in makefile parser doesn't recognise slashes
+-- TODO (izgzhen): should fix DEP_LIB_REL_DIRS_SEARCHPATH
+postProcessPackageData :: Context -> FilePath -> Action ()
+postProcessPackageData context@Context {..} file = do
+ top <- topDirectory
+ cmmSrcs <- getDirectoryFiles (pkgPath package) ["cbits/*.cmm"]
+ path <- buildPath context
+ let len = length (pkgPath package) + length (top -/- path) + 2
+ fixFile file $ unlines
+ . (++ ["CMM_SRCS = " ++ unwords (map unifyPath cmmSrcs) ])
+ . map (drop len) . filter ('$' `notElem`) . lines
diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs
new file mode 100644
index 0000000000..ba4dab0442
--- /dev/null
+++ b/hadrian/src/Rules/Program.hs
@@ -0,0 +1,116 @@
+module Rules.Program (buildProgram) where
+
+import Hadrian.Haskell.Cabal
+
+import Base
+import Context
+import Expression hiding (stage, way)
+import Oracles.ModuleFiles
+import Oracles.PackageData
+import Oracles.Setting
+import Rules.Wrappers
+import Settings
+import Settings.Packages.Rts
+import Target
+import Utilities
+
+-- | TODO: Drop code duplication
+buildProgram :: [(Resource, Int)] -> Package -> Rules ()
+buildProgram rs package = do
+ forM_ [Stage0 ..] $ \stage -> do
+ let context = vanillaContext stage package
+
+ -- Rules for programs built in 'buildRoot'
+ "//" ++ contextDir context -/- programName context <.> exe %> \bin ->
+ buildBinaryAndWrapper rs bin =<< programContext stage package
+
+ -- Rules for the GHC package, which is built 'inplace'
+ when (package == ghc) $ do
+ inplaceBinPath -/- programName context <.> exe %> \bin ->
+ buildBinaryAndWrapper rs bin =<< programContext stage package
+
+ inplaceLibBinPath -/- programName context <.> exe %> \bin ->
+ buildBinary rs bin =<< programContext stage package
+
+ inplaceLibBinPath -/- programName context <.> "bin" %> \bin ->
+ buildBinary rs bin =<< programContext stage package
+
+ -- Rules for other programs built in inplace directories
+ when (package /= ghc) $ do
+ let context0 = vanillaContext Stage0 package -- TODO: get rid of context0
+ inplaceBinPath -/- programName context0 <.> exe %> \bin -> do
+ stage <- installStage package -- TODO: get rid of fromJust
+ buildBinaryAndWrapper rs bin =<< programContext (fromJust stage) package
+
+ inplaceLibBinPath -/- programName context0 <.> exe %> \bin -> do
+ stage <- installStage package -- TODO: get rid of fromJust
+ context <- programContext (fromJust stage) package
+ if package /= iservBin then
+ -- We *normally* build only unwrapped binaries in inplace/lib/bin
+ buildBinary rs bin context
+ else
+ -- Build both binary and wrapper in inplace/lib/bin for iservBin
+ buildBinaryAndWrapperLib rs bin context
+
+ inplaceLibBinPath -/- programName context0 <.> "bin" %> \bin -> do
+ stage <- installStage package -- TODO: get rid of fromJust
+ buildBinary rs bin =<< programContext (fromJust stage) package
+
+buildBinaryAndWrapperLib :: [(Resource, Int)] -> FilePath -> Context -> Action ()
+buildBinaryAndWrapperLib rs bin context = do
+ windows <- windowsHost
+ if windows
+ then buildBinary rs bin context -- We don't build wrappers on Windows
+ else case lookup context inplaceWrappers of
+ Nothing -> buildBinary rs bin context -- No wrapper found
+ Just wrapper -> do
+ top <- topDirectory
+ let libdir = top -/- inplaceLibPath
+ let wrappedBin = inplaceLibBinPath -/- programName context <.> "bin"
+ need [wrappedBin]
+ buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName wrappedBin))
+
+buildBinaryAndWrapper :: [(Resource, Int)] -> FilePath -> Context -> Action ()
+buildBinaryAndWrapper rs bin context = do
+ windows <- windowsHost
+ if windows
+ then buildBinary rs bin context -- We don't build wrappers on Windows
+ else case lookup context inplaceWrappers of
+ Nothing -> buildBinary rs bin context -- No wrapper found
+ Just wrapper -> do
+ top <- topDirectory
+ let libPath = top -/- inplaceLibPath
+ wrappedBin = inplaceLibBinPath -/- takeFileName bin
+ need [wrappedBin]
+ buildWrapper context wrapper bin (WrappedBinary libPath (takeFileName bin))
+
+buildWrapper :: Context -> Wrapper -> FilePath -> WrappedBinary -> Action ()
+buildWrapper context@Context {..} wrapper wrapperPath wrapped = do
+ contents <- interpretInContext context $ wrapper wrapped
+ writeFileChanged wrapperPath contents
+ makeExecutable wrapperPath
+ putSuccess $ "| Successfully created wrapper for " ++
+ quote (pkgName package) ++ " (" ++ show stage ++ ")."
+
+-- TODO: Get rid of the Paths_hsc2hs.o hack.
+buildBinary :: [(Resource, Int)] -> FilePath -> Context -> Action ()
+buildBinary rs bin context@Context {..} = do
+ binDeps <- if stage == Stage0 && package == ghcCabal
+ then hsSources context
+ else do
+ needLibrary =<< contextDependencies context
+ when (stage > Stage0) $ do
+ ways <- interpretInContext context (getLibraryWays <> getRtsWays)
+ needLibrary [ rtsContext { way = w } | w <- ways ]
+ path <- buildPath context
+ cSrcs <- pkgDataList (CSrcs path)
+ cObjs <- mapM (objectPath context) cSrcs
+ hsObjs <- hsObjects context
+ return $ cObjs ++ hsObjs
+ ++ [ path -/- "Paths_hsc2hs.o" | package == hsc2hs ]
+ ++ [ path -/- "Paths_haddock.o" | package == haddock ]
+ need binDeps
+ buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin]
+ synopsis <- traverse pkgSynopsis (pkgCabalFile package)
+ putSuccess $ renderProgram
+ (quote (pkgName package) ++ " (" ++ show stage ++ ").") bin synopsis
diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
new file mode 100644
index 0000000000..7c0a3e00e8
--- /dev/null
+++ b/hadrian/src/Rules/Register.hs
@@ -0,0 +1,44 @@
+module Rules.Register (registerPackage) where
+
+import Base
+import Context
+import GHC
+import Target
+import Utilities
+
+-- TODO: Simplify.
+-- | Build rules for registering packages and initialising package databases
+-- by running the @ghc-pkg@ utility.
+registerPackage :: [(Resource, Int)] -> Context -> Rules ()
+registerPackage rs context@Context {..} = do
+ when (stage == Stage0) $ do
+ -- Packages @ghc-boot@ and @ghc-boot-th@ both match the @ghc-boot*@
+ -- pattern, therefore we need to use priorities to match the right rule.
+ -- TODO: Get rid of this hack.
+ "//" ++ stage0PackageDbDir -/- pkgName package ++ "*.conf" %%>
+ buildConf rs context
+
+ when (package == ghc) $ "//" ++ stage0PackageDbDir -/- packageDbStamp %>
+ buildStamp rs context
+
+ when (stage == Stage1) $ do
+ inplacePackageDbPath -/- pkgName package ++ "*.conf" %%>
+ buildConf rs context
+
+ when (package == ghc) $ inplacePackageDbPath -/- packageDbStamp %>
+ buildStamp rs context
+
+buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
+buildConf rs context@Context {..} conf = do
+ confIn <- pkgInplaceConfig context
+ need [confIn]
+ buildWithResources rs $ target context (GhcPkg Update stage) [confIn] [conf]
+
+buildStamp :: [(Resource, Int)] -> Context -> FilePath -> Action ()
+buildStamp rs Context {..} stamp = do
+ let path = takeDirectory stamp
+ removeDirectory path
+ buildWithResources rs $
+ target (vanillaContext stage ghc) (GhcPkg Init stage) [] [path]
+ writeFileLines stamp []
+ putSuccess $ "| Successfully initialised " ++ path
diff --git a/hadrian/src/Rules/Selftest.hs b/hadrian/src/Rules/Selftest.hs
new file mode 100644
index 0000000000..d1ffaac1c3
--- /dev/null
+++ b/hadrian/src/Rules/Selftest.hs
@@ -0,0 +1,92 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Rules.Selftest (selftestRules) where
+
+import Test.QuickCheck
+
+import Base
+import GHC
+import Oracles.ModuleFiles
+import Oracles.Setting
+import Settings
+import Target
+
+instance Arbitrary Way where
+ arbitrary = wayFromUnits <$> arbitrary
+
+instance Arbitrary WayUnit where
+ arbitrary = arbitraryBoundedEnum
+
+test :: Testable a => a -> Action ()
+test = liftIO . quickCheck
+
+selftestRules :: Rules ()
+selftestRules =
+ "selftest" ~> do
+ testBuilder
+ testChunksOfSize
+ testLookupAll
+ testModuleName
+ testPackages
+ testWay
+
+testBuilder :: Action ()
+testBuilder = do
+ putBuild "==== trackArgument"
+ let make = target undefined (Make undefined) undefined undefined
+ test $ forAll (elements ["-j", "MAKEFLAGS=-j", "THREADS="])
+ $ \prefix (NonNegative n) ->
+ not (trackArgument make prefix) &&
+ not (trackArgument make ("-j" ++ show (n :: Int)))
+
+testChunksOfSize :: Action ()
+testChunksOfSize = do
+ putBuild "==== chunksOfSize"
+ test $ chunksOfSize 3 [ "a", "b", "c" , "defg" , "hi" , "jk" ]
+ == [ ["a", "b", "c"], ["defg"], ["hi"], ["jk"] ]
+ test $ \n xs ->
+ let res = chunksOfSize n xs
+ in concat res == xs && all (\r -> length r == 1 || length (concat r) <= n) res
+
+testLookupAll :: Action ()
+testLookupAll = do
+ putBuild "==== lookupAll"
+ test $ lookupAll ["b" , "c" ] [("a", 1), ("c", 3), ("d", 4)]
+ == [Nothing, Just (3 :: Int)]
+ test $ forAll dicts $ \dict -> forAll extras $ \extra ->
+ let items = sort $ map fst dict ++ extra
+ in lookupAll items (sort dict) == map (`lookup` dict) items
+ where
+ dicts :: Gen [(Int, Int)]
+ dicts = nubBy (\x y -> fst x == fst y) <$> vector 20
+ extras :: Gen [Int]
+ extras = vector 20
+
+testModuleName :: Action ()
+testModuleName = do
+ putBuild "==== Encode/decode module name"
+ test $ encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
+ test $ encodeModule "" "Prelude" == "Prelude"
+
+ test $ decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
+ test $ decodeModule "Prelude" == ("", "Prelude")
+
+ test $ forAll names $ \n -> uncurry encodeModule (decodeModule n) == n
+ where
+ names = intercalate "." <$> listOf1 (listOf1 $ elements "abcABC123_'")
+
+testPackages :: Action ()
+testPackages = do
+ putBuild "==== Check system configuration"
+ win <- windowsHost -- This depends on the @boot@ and @configure@ scripts.
+ putBuild "==== Packages, interpretInContext, configuration flags"
+ forM_ [Stage0 ..] $ \stage -> do
+ pkgs <- stagePackages stage
+ when (win32 `elem` pkgs) . test $ win
+ when (unix `elem` pkgs) . test $ not win
+ test $ pkgs == nubOrd pkgs
+
+testWay :: Action ()
+testWay = do
+ putBuild "==== Read Way, Show Way"
+ test $ \(x :: Way) -> read (show x) == x
+
diff --git a/hadrian/src/Rules/SourceDist.hs b/hadrian/src/Rules/SourceDist.hs
new file mode 100644
index 0000000000..3143c4b153
--- /dev/null
+++ b/hadrian/src/Rules/SourceDist.hs
@@ -0,0 +1,113 @@
+module Rules.SourceDist (sourceDistRules) where
+
+import Hadrian.Oracles.DirectoryContents
+
+import Base
+import Builder
+import Oracles.Setting
+import Rules.Clean
+
+sourceDistRules :: Rules ()
+sourceDistRules = do
+ "sdist-ghc" ~> do
+ -- We clean the source tree first.
+ -- See https://github.com/snowleopard/hadrian/issues/384.
+ cleanSourceTree
+ version <- setting ProjectVersion
+ need ["sdistprep/ghc-" ++ version ++ "-src.tar.xz"]
+ putSuccess "| Done"
+ "sdistprep/ghc-*-src.tar.xz" %> \fname -> do
+ let tarName = takeFileName fname
+ dropTarXz = dropExtension . dropExtension
+ treePath = "sdistprep/ghc" -/- dropTarXz tarName
+ prepareTree treePath
+ runBuilderWithCmdOptions [Cwd "sdistprep/ghc"] (Tar Create)
+ ["cJf", ".." -/- tarName, dropTarXz tarName]
+ ["cJf", ".." -/- tarName] [dropTarXz tarName]
+ "GIT_COMMIT_ID" %> \fname ->
+ writeFileChanged fname =<< setting ProjectGitCommitId
+ "VERSION" %> \fname ->
+ writeFileChanged fname =<< setting ProjectVersion
+
+prepareTree :: FilePath -> Action ()
+prepareTree dest = do
+ mapM_ cpDir srcDirs
+ mapM_ cpFile srcFiles
+ where
+ cpFile a = copyFile a (dest -/- a)
+ cpDir a = copyDirectoryContents (Not excluded) a (dest -/- a)
+ excluded = Or
+ [ Test "//.*"
+ , Test "//#*"
+ , Test "//*-SAVE"
+ , Test "//*.orig"
+ , Test "//*.rej"
+ , Test "//*~"
+ , Test "//autom4te*"
+ , Test "//dist"
+ , Test "//dist-install"
+ , Test "//log"
+ , Test "//stage0"
+ , Test "//stage1"
+ , Test "//stage2"
+ , Test "//stage3"
+ , Test "hadrian/.cabal-sandbox"
+ , Test "hadrian/.stack-work"
+ , Test "hadrian/UserSettings.hs"
+ , Test "hadrian/cabal.sandbox.config"
+ , Test "hadrian/cfg/system.config"
+ , Test "hadrian/bin"
+ , Test "hadrian/dist"
+ , Test "hadrian/dist-newstyle"
+ , Test "libraries//*.buildinfo"
+ , Test "libraries//GNUmakefile"
+ , Test "libraries//config.log"
+ , Test "libraries//config.status"
+ , Test "libraries//configure"
+ , Test "libraries//ghc.mk"
+ , Test "libraries//include/Hs*Config.h"
+ , Test "libraries/dph"
+ , Test "libraries/parallel"
+ , Test "libraries/primitive"
+ , Test "libraries/random"
+ , Test "libraries/stm"
+ , Test "libraries/vector"
+ , Test "mk/build.mk" ]
+ srcDirs =
+ [ "bindisttest"
+ , "compiler"
+ , "distrib"
+ , "docs"
+ , "docs"
+ , "driver"
+ , "ghc"
+ , "hadrian"
+ , "includes"
+ , "iserv"
+ , "libffi"
+ , "libffi-tarballs"
+ , "libraries"
+ , "mk"
+ , "rts"
+ , "rules"
+ , "utils" ]
+ srcFiles =
+ [ "ANNOUNCE"
+ , "GIT_COMMIT_ID"
+ , "HACKING.md"
+ , "INSTALL.md"
+ , "LICENSE"
+ , "MAKEHELP.md"
+ , "Makefile"
+ , "README.md"
+ , "VERSION"
+ , "aclocal.m4"
+ , "boot"
+ , "config.guess"
+ , "config.sub"
+ , "configure"
+ , "configure.ac"
+ , "ghc.mk"
+ , "install-sh"
+ , "packages"
+ , "settings.in" ]
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
new file mode 100644
index 0000000000..ae37343432
--- /dev/null
+++ b/hadrian/src/Rules/Test.hs
@@ -0,0 +1,72 @@
+module Rules.Test (testRules) where
+
+import Base
+import Expression
+import Flavour
+import Oracles.Flag
+import Oracles.Setting
+import Settings
+import Target
+import Utilities
+
+-- TODO: clean up after testing
+testRules :: Rules ()
+testRules = do
+ "validate" ~> do
+ need inplaceLibCopyTargets
+ needBuilder $ Ghc CompileHs Stage2
+ needBuilder $ GhcPkg Update Stage1
+ needBuilder Hpc
+ -- TODO: Figure out why @needBuilder Hsc2Hs@ doesn't work.
+ -- TODO: Eliminate explicit filepaths.
+ -- See https://github.com/snowleopard/hadrian/issues/376.
+ need ["inplace/bin/hp2ps", "inplace/bin/hsc2hs"]
+ build $ target (vanillaContext Stage2 compiler) (Make "testsuite/tests") [] []
+
+ "test" ~> do
+ pkgs <- stagePackages Stage1
+ tests <- filterM doesDirectoryExist $ concat
+ [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
+ | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
+ windows <- windowsHost
+ top <- topDirectory
+ compiler <- builderPath $ Ghc CompileHs Stage2
+ ghcPkg <- builderPath $ GhcPkg Update Stage1
+ haddock <- builderPath (Haddock BuildPackage)
+ threads <- shakeThreads <$> getShakeOptions
+ debugged <- ghcDebugged <$> flavour
+ ghcWithNativeCodeGenInt <- fromEnum <$> ghcWithNativeCodeGen
+ ghcWithInterpreterInt <- fromEnum <$> ghcWithInterpreter
+ ghcUnregisterisedInt <- fromEnum <$> flag GhcUnregisterised
+ quietly . cmd "python2" $
+ [ "testsuite/driver/runtests.py" ]
+ ++ map ("--rootdir="++) tests ++
+ [ "-e", "windows=" ++ show windows
+ , "-e", "config.speed=2"
+ , "-e", "ghc_compiler_always_flags=" ++ show "-fforce-recomp -dcore-lint -dcmm-lint -dno-debug-output -no-user-package-db -rtsopts"
+ , "-e", "ghc_with_native_codegen=" ++ show ghcWithNativeCodeGenInt
+ , "-e", "ghc_debugged=" ++ show (yesNo debugged)
+ , "-e", "ghc_with_vanilla=1" -- TODO: do we always build vanilla?
+ , "-e", "ghc_with_dynamic=0" -- TODO: support dynamic
+ , "-e", "ghc_with_profiling=0" -- TODO: support profiling
+ , "-e", "ghc_with_interpreter=" ++ show ghcWithInterpreterInt
+ , "-e", "ghc_unregisterised=" ++ show ghcUnregisterisedInt
+ , "-e", "ghc_with_threaded_rts=0" -- TODO: support threaded
+ , "-e", "ghc_with_dynamic_rts=0" -- TODO: support dynamic
+ , "-e", "ghc_dynamic_by_default=False" -- TODO: support dynamic
+ , "-e", "ghc_dynamic=0" -- TODO: support dynamic
+ , "-e", "ghc_with_llvm=0" -- TODO: support LLVM
+ , "-e", "in_tree_compiler=True" -- TODO: when is it equal to False?
+ , "-e", "clean_only=False" -- TODO: do we need to support True?
+ , "--configfile=testsuite/config/ghc"
+ , "--config", "compiler=" ++ show (top -/- compiler)
+ , "--config", "ghc_pkg=" ++ show (top -/- ghcPkg)
+ , "--config", "haddock=" ++ show (top -/- haddock)
+ , "--summary-file", "testsuite_summary.txt"
+ , "--threads=" ++ show threads
+ ]
+
+ -- , "--config", "hp2ps=" ++ quote ("hp2ps")
+ -- , "--config", "hpc=" ++ quote ("hpc")
+ -- , "--config", "gs=$(call quote_path,$(GS))"
+ -- , "--config", "timeout_prog=$(call quote_path,$(TIMEOUT_PROGRAM))"
diff --git a/hadrian/src/Rules/Wrappers.hs b/hadrian/src/Rules/Wrappers.hs
new file mode 100644
index 0000000000..20763a778e
--- /dev/null
+++ b/hadrian/src/Rules/Wrappers.hs
@@ -0,0 +1,162 @@
+module Rules.Wrappers (
+ WrappedBinary(..), Wrapper, inplaceWrappers, installWrappers
+ ) where
+
+import Hadrian.Oracles.Path
+
+import Base
+import Expression
+import Oracles.Setting
+import Settings
+
+-- | Wrapper is an expression depending on (i) the 'FilePath' to the library and
+-- (ii) the name of the wrapped binary.
+data WrappedBinary = WrappedBinary
+ { binaryLibPath :: FilePath
+ , binaryName :: String }
+
+type Wrapper = WrappedBinary -> Expr String
+
+ghcWrapper :: WrappedBinary -> Expr String
+ghcWrapper WrappedBinary{..} = do
+ expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+ bash <- expr bashPath
+ return $ unlines
+ [ "#!"++bash
+ , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+ ++ " -B" ++ binaryLibPath ++ " ${1+\"$@\"}" ]
+
+inplaceRunGhcWrapper :: WrappedBinary -> Expr String
+inplaceRunGhcWrapper WrappedBinary{..} = do
+ expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+ bash <- expr bashPath
+ return $ unlines
+ [ "#!"++bash
+ , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+ ++ " -f" ++ (binaryLibPath -/- "bin/ghc-stage2") -- TODO: use ProgramName
+ ++ " -B" ++ binaryLibPath ++ " ${1+\"$@\"}" ]
+
+installRunGhcWrapper :: WrappedBinary -> Expr String
+installRunGhcWrapper WrappedBinary{..} = do
+ expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+ bash <- expr bashPath
+ return $ unlines
+ [ "#!"++bash
+ , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+ ++ " -f" ++ (binaryLibPath -/- "bin/ghc") -- TODO: use ProgramName
+ ++ " -B" ++ binaryLibPath ++ " ${1+\"$@\"}" ]
+
+inplaceGhcPkgWrapper :: WrappedBinary -> Expr String
+inplaceGhcPkgWrapper WrappedBinary{..} = do
+ expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+ top <- expr topDirectory
+ -- The wrapper is generated in StageN, but used in StageN+1. Therefore, we
+ -- always use the inplace package database, located at 'inplacePackageDbPath',
+ -- which is used in Stage1 and later.
+ bash <- expr bashPath
+ return $ unlines
+ [ "#!" ++ bash
+ , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++
+ " --global-package-db " ++ top -/- inplacePackageDbPath ++ " ${1+\"$@\"}" ]
+
+installGhcPkgWrapper :: WrappedBinary -> Expr String
+installGhcPkgWrapper WrappedBinary{..} = do
+ expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+ stage <- getStage
+ top <- expr topDirectory
+ -- Use the package configuration for the next stage in the wrapper.
+ -- The wrapper is generated in StageN, but used in StageN+1.
+ packageDb <- expr $ installPackageDbPath binaryLibPath top (succ stage)
+ bash <- expr bashPath
+ return $ unlines
+ [ "#!"++bash
+ , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+ ++ " --global-package-db " ++ packageDb ++ " ${1+\"$@\"}" ]
+
+hp2psWrapper :: WrappedBinary -> Expr String
+hp2psWrapper WrappedBinary{..} = do
+ expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+ bash <- expr bashPath
+ return $ unlines
+ [ "#!"++bash
+ , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ]
+
+hpcWrapper :: WrappedBinary -> Expr String
+hpcWrapper WrappedBinary{..} = do
+ expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+ bash <- expr bashPath
+ return $ unlines
+ [ "#!"++bash
+ , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ]
+
+hsc2hsWrapper :: WrappedBinary -> Expr String
+hsc2hsWrapper WrappedBinary{..} = do
+ top <- expr topDirectory
+ expr $ need [ sourcePath -/- "Rules/Wrappers.hs" ]
+ contents <- expr $ readFile' $ top -/- "utils/hsc2hs/hsc2hs.wrapper"
+ let executableName = binaryLibPath -/- "bin" -/- binaryName
+ confCcArgs <- expr $ settingList (ConfCcArgs Stage1)
+ confGccLinkerArgs <- expr $ settingList (ConfGccLinkerArgs Stage1)
+ let hsc2hsExtra = unwords (map ("-cflags=" ++) confCcArgs) ++ " " ++
+ unwords (map ("-lflags=" ++) confGccLinkerArgs)
+ bash <- expr bashPath
+ return $ unlines
+ [ "#!"++bash
+ , "executablename=\"" ++ executableName ++ "\""
+ , "HSC2HS_EXTRA=\"" ++ hsc2hsExtra ++ "\""
+ , contents ]
+
+haddockWrapper :: WrappedBinary -> Expr String
+haddockWrapper WrappedBinary{..} = do
+ expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+ return $ unlines
+ [ "#!/bin/bash"
+ , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+ ++ " -B" ++ binaryLibPath ++ " -l" ++ binaryLibPath ++ " ${1+\"$@\"}" ]
+
+iservBinWrapper :: WrappedBinary -> Expr String
+iservBinWrapper WrappedBinary{..} = do
+ expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+ stage <- getStage
+ stageLibraries <- expr $ filter isLibrary <$> stagePackages stage
+ -- TODO: Figure our the reason of this hardcoded exclusion
+ let pkgs = stageLibraries \\ [ cabal, process, haskeline
+ , terminfo, ghcCompact, hpc, compiler ]
+ contexts <- expr $ concatForM pkgs $ \p -> do
+ maybeStage <- installStage p
+ return [ vanillaContext s p | s <- maybeToList maybeStage ]
+ buildPaths <- expr $ mapM buildPath contexts
+ return $ unlines
+ [ "#!/bin/bash"
+ , "export DYLD_LIBRARY_PATH=\"" ++ intercalate ":" buildPaths ++
+ "${DYLD_LIBRARY_PATH:+:$DYLD_LIBRARY_PATH}\""
+ , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ]
+
+wrappersCommon :: [(Context, Wrapper)]
+wrappersCommon = [ (vanillaContext Stage0 ghc , ghcWrapper)
+ , (vanillaContext Stage1 ghc , ghcWrapper)
+ , (vanillaContext Stage1 hp2ps , hp2psWrapper)
+ , (vanillaContext Stage1 hpc , hpcWrapper)
+ , (vanillaContext Stage1 hsc2hs, hsc2hsWrapper)
+ , (vanillaContext Stage2 haddock, haddockWrapper)
+ , (vanillaContext Stage1 iservBin, iservBinWrapper) ]
+
+-- | List of wrappers for inplace artefacts
+inplaceWrappers :: [(Context, Wrapper)]
+inplaceWrappers = wrappersCommon ++
+ [ (vanillaContext Stage0 ghcPkg, inplaceGhcPkgWrapper)
+ , (vanillaContext Stage1 runGhc, inplaceRunGhcWrapper) ]
+
+-- | List of wrappers for installation
+installWrappers :: [(Context, Wrapper)]
+installWrappers = wrappersCommon ++
+ [ (vanillaContext Stage0 ghcPkg, installGhcPkgWrapper)
+ , (vanillaContext Stage1 runGhc, installRunGhcWrapper) ]
+
+-- | In the final installation path specified by @DEST@, there is another
+-- @package.conf.d@ different from 'inplacePackageDbPath' defined in "Base".
+installPackageDbPath :: FilePath -> FilePath -> Stage -> Action FilePath
+installPackageDbPath _ top Stage0 = do
+ path <- buildRoot
+ return $ top -/- path -/- "stage0/bootstrapping.conf"
+installPackageDbPath libdir _ _ = return $ libdir -/- "package.conf.d"
diff --git a/hadrian/src/Settings.hs b/hadrian/src/Settings.hs
new file mode 100644
index 0000000000..091efc10ca
--- /dev/null
+++ b/hadrian/src/Settings.hs
@@ -0,0 +1,68 @@
+module Settings (
+ getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
+ findPackageByName, getPkgData, getPkgDataList, isLibrary, stagePackages,
+ programContext, getIntegerPackage, getDestDir
+ ) where
+
+import CommandLine
+import Expression
+import Flavour
+import {-# SOURCE #-} Settings.Default
+import Settings.Flavours.Development
+import Settings.Flavours.Performance
+import Settings.Flavours.Profiled
+import Settings.Flavours.Quick
+import Settings.Flavours.Quickest
+import Settings.Flavours.QuickCross
+import UserSettings
+
+getArgs :: Args
+getArgs = expr flavour >>= args
+
+getLibraryWays :: Ways
+getLibraryWays = expr flavour >>= libraryWays
+
+getRtsWays :: Ways
+getRtsWays = expr flavour >>= rtsWays
+
+stagePackages :: Stage -> Action [Package]
+stagePackages stage = do
+ f <- flavour
+ packages f stage
+
+hadrianFlavours :: [Flavour]
+hadrianFlavours =
+ [ defaultFlavour, developmentFlavour Stage1, developmentFlavour Stage2
+ , performanceFlavour, profiledFlavour, quickFlavour, quickestFlavour
+ , quickCrossFlavour ]
+
+flavour :: Action Flavour
+flavour = do
+ flavourName <- fromMaybe "default" <$> cmdFlavour
+ let unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
+ flavours = hadrianFlavours ++ userFlavours
+ return $ fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
+
+getIntegerPackage :: Expr Package
+getIntegerPackage = expr (integerLibrary =<< flavour)
+
+programContext :: Stage -> Package -> Action Context
+programContext stage pkg = do
+ profiled <- ghcProfiled <$> flavour
+ return $ if pkg == ghc && profiled && stage > Stage0
+ then Context stage pkg profiling
+ else vanillaContext stage pkg
+
+-- 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 $ ghcPackages ++ userPackages
+
+-- TODO: Speed up? Switch to Set?
+-- 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
+
+-- | Install's DESTDIR setting.
+getDestDir :: Action FilePath
+getDestDir = fromMaybe "" <$> cmdInstallDestDir
diff --git a/hadrian/src/Settings/Builders/Alex.hs b/hadrian/src/Settings/Builders/Alex.hs
new file mode 100644
index 0000000000..e0ef1367f7
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Alex.hs
@@ -0,0 +1,8 @@
+module Settings.Builders.Alex (alexBuilderArgs) where
+
+import Settings.Builders.Common
+
+alexBuilderArgs :: Args
+alexBuilderArgs = builder Alex ? mconcat [ arg "-g"
+ , arg =<< getInput
+ , arg "-o", arg =<< getOutput ]
diff --git a/hadrian/src/Settings/Builders/Cc.hs b/hadrian/src/Settings/Builders/Cc.hs
new file mode 100644
index 0000000000..70d043f76d
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Cc.hs
@@ -0,0 +1,26 @@
+module Settings.Builders.Cc (ccBuilderArgs) where
+
+import Settings.Builders.Common
+
+ccBuilderArgs :: Args
+ccBuilderArgs = do
+ way <- getWay
+ builder Cc ? mconcat
+ [ getPkgDataList CcArgs
+ , getStagedSettingList ConfCcArgs
+ , cIncludeArgs
+
+ , builder (Cc CompileC) ? mconcat
+ [ pure ["-Wall", "-Werror"]
+ , Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ]
+ , arg "-c", arg =<< getInput
+ , arg "-o", arg =<< getOutput ]
+
+ , builder (Cc FindCDependencies) ? do
+ output <- getOutput
+ mconcat [ arg "-E"
+ , arg "-MM", arg "-MG"
+ , arg "-MF", arg output
+ , arg "-MT", arg $ dropExtension output -<.> "o"
+ , arg "-x", arg "c"
+ , arg =<< getInput ] ]
diff --git a/hadrian/src/Settings/Builders/Common.hs b/hadrian/src/Settings/Builders/Common.hs
new file mode 100644
index 0000000000..5ca594e645
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Common.hs
@@ -0,0 +1,59 @@
+module Settings.Builders.Common (
+ module Base,
+ module Expression,
+ module Oracles.Flag,
+ module Oracles.PackageData,
+ module Oracles.Setting,
+ module Settings,
+ module UserSettings,
+ cIncludeArgs, ldArgs, cArgs, cWarnings, bootPackageDatabaseArgs
+ ) where
+
+import Base
+import Expression
+import Oracles.Flag
+import Oracles.PackageData
+import Oracles.Setting
+import Settings
+import UserSettings
+
+cIncludeArgs :: Args
+cIncludeArgs = do
+ pkg <- getPackage
+ root <- getBuildRoot
+ path <- getBuildPath
+ incDirs <- getPkgDataList IncludeDirs
+ depDirs <- getPkgDataList DepIncludeDirs
+ cross <- expr crossCompiling
+ compilerOrGhc <- package compiler ||^ package ghc
+ mconcat [ not (cross && compilerOrGhc) ? arg "-Iincludes"
+ , arg $ "-I" ++ root -/- generatedDir
+ , arg $ "-I" ++ path
+ , pure [ "-I" ++ pkgPath pkg -/- dir | dir <- incDirs ]
+ , pure [ "-I" ++ unifyPath dir | dir <- depDirs ] ]
+
+ldArgs :: Args
+ldArgs = mempty
+
+cArgs :: Args
+cArgs = mempty
+
+-- TODO: should be in a different file
+cWarnings :: Args
+cWarnings = do
+ let gccGe46 = notM (flag GccIsClang ||^ flag GccLt46)
+ mconcat [ arg "-Wall"
+ , flag GccIsClang ? arg "-Wno-unknown-pragmas"
+ , gccGe46 ? notM windowsHost ? arg "-Werror=unused-but-set-variable"
+ , gccGe46 ? arg "-Wno-error=inline" ]
+
+bootPackageDatabaseArgs :: Args
+bootPackageDatabaseArgs = do
+ stage <- getStage
+ dbPath <- expr $ packageDbPath stage
+ expr $ need [dbPath -/- packageDbStamp]
+ stage0 ? do
+ top <- expr topDirectory
+ root <- getBuildRoot
+ prefix <- ifM (builder Ghc) (return "-package-db ") (return "--package-db=")
+ arg $ prefix ++ top -/- root -/- stage0PackageDbDir
diff --git a/hadrian/src/Settings/Builders/Configure.hs b/hadrian/src/Settings/Builders/Configure.hs
new file mode 100644
index 0000000000..93225b5405
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Configure.hs
@@ -0,0 +1,25 @@
+module Settings.Builders.Configure (configureBuilderArgs) where
+
+import Rules.Gmp
+import Rules.Libffi
+import Settings.Builders.Common
+
+configureBuilderArgs :: Args
+configureBuilderArgs = do
+ gmpPath <- expr gmpBuildPath
+ libffiPath <- expr libffiBuildPath
+ mconcat [ builder (Configure gmpPath) ? do
+ hostPlatform <- getSetting HostPlatform
+ buildPlatform <- getSetting BuildPlatform
+ pure [ "--enable-shared=no"
+ , "--host=" ++ hostPlatform
+ , "--build=" ++ buildPlatform ]
+
+ , builder (Configure libffiPath) ? do
+ top <- expr topDirectory
+ targetPlatform <- getSetting TargetPlatform
+ pure [ "--prefix=" ++ top -/- libffiPath -/- "inst"
+ , "--libdir=" ++ top -/- libffiPath -/- "inst/lib"
+ , "--enable-static=yes"
+ , "--enable-shared=no" -- TODO: add support for yes
+ , "--host=" ++ targetPlatform ] ]
diff --git a/hadrian/src/Settings/Builders/DeriveConstants.hs b/hadrian/src/Settings/Builders/DeriveConstants.hs
new file mode 100644
index 0000000000..7a6e863e9c
--- /dev/null
+++ b/hadrian/src/Settings/Builders/DeriveConstants.hs
@@ -0,0 +1,39 @@
+module Settings.Builders.DeriveConstants (deriveConstantsBuilderArgs) where
+
+import Settings.Builders.Common
+
+-- TODO: do we need to support `includes_CC_OPTS += -DDYNAMIC_BY_DEFAULT`?
+deriveConstantsBuilderArgs :: Args
+deriveConstantsBuilderArgs = builder DeriveConstants ? do
+ cFlags <- includeCcArgs
+ outs <- getOutputs
+ let (outputFile, tempDir) = case outs of
+ [a, b] -> (a, b)
+ _ -> error $ "DeriveConstants: expected two outputs, got " ++ show outs
+ mconcat
+ [ output "//DerivedConstants.h" ? arg "--gen-header"
+ , output "//GHCConstantsHaskellType.hs" ? arg "--gen-haskell-type"
+ , output "//platformConstants" ? arg "--gen-haskell-value"
+ , output "//GHCConstantsHaskellWrappers.hs" ? arg "--gen-haskell-wrappers"
+ , output "//GHCConstantsHaskellExports.hs" ? arg "--gen-haskell-exports"
+ , arg "-o", arg outputFile
+ , arg "--tmpdir", arg tempDir
+ , arg "--gcc-program", arg =<< getBuilderPath (Cc CompileC Stage1)
+ , pure $ concatMap (\a -> ["--gcc-flag", a]) cFlags
+ , arg "--nm-program", arg =<< getBuilderPath Nm
+ , isSpecified Objdump ? mconcat [ arg "--objdump-program"
+ , arg =<< getBuilderPath Objdump ]
+ , arg "--target-os", arg =<< getSetting TargetOs ]
+
+includeCcArgs :: Args
+includeCcArgs = do
+ root <- getBuildRoot
+ mconcat [ cArgs
+ , cWarnings
+ , getSettingList $ ConfCcArgs Stage1
+ , flag GhcUnregisterised ? arg "-DUSE_MINIINTERPRETER"
+ , arg "-Irts"
+ , arg "-Iincludes"
+ , arg $ "-I" ++ root -/- generatedDir
+ , notM ghcWithSMP ? arg "-DNOSMP"
+ , arg "-fcommon" ]
diff --git a/hadrian/src/Settings/Builders/GenPrimopCode.hs b/hadrian/src/Settings/Builders/GenPrimopCode.hs
new file mode 100644
index 0000000000..e616ed3b43
--- /dev/null
+++ b/hadrian/src/Settings/Builders/GenPrimopCode.hs
@@ -0,0 +1,24 @@
+module Settings.Builders.GenPrimopCode (genPrimopCodeBuilderArgs) where
+
+import Settings.Builders.Common
+
+genPrimopCodeBuilderArgs :: Args
+genPrimopCodeBuilderArgs = builder GenPrimopCode ? mconcat
+ [ output "//PrimopWrappers.hs" ? arg "--make-haskell-wrappers"
+ , output "//Prim.hs" ? arg "--make-haskell-source"
+ , output "//primop-data-decl.hs-incl" ? arg "--data-decl"
+ , output "//primop-tag.hs-incl" ? arg "--primop-tag"
+ , output "//primop-list.hs-incl" ? arg "--primop-list"
+ , output "//primop-has-side-effects.hs-incl" ? arg "--has-side-effects"
+ , output "//primop-out-of-line.hs-incl" ? arg "--out-of-line"
+ , output "//primop-commutable.hs-incl" ? arg "--commutable"
+ , output "//primop-code-size.hs-incl" ? arg "--code-size"
+ , output "//primop-can-fail.hs-incl" ? arg "--can-fail"
+ , output "//primop-strictness.hs-incl" ? arg "--strictness"
+ , output "//primop-fixity.hs-incl" ? arg "--fixity"
+ , output "//primop-primop-info.hs-incl" ? arg "--primop-primop-info"
+ , output "//primop-vector-uniques.hs-incl" ? arg "--primop-vector-uniques"
+ , output "//primop-vector-tys.hs-incl" ? arg "--primop-vector-tys"
+ , output "//primop-vector-tys-exports.hs-incl" ? arg "--primop-vector-tys-exports"
+ , output "//primop-vector-tycons.hs-incl" ? arg "--primop-vector-tycons"
+ , output "//primop-usage.hs-incl" ? arg "--usage" ]
diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs
new file mode 100644
index 0000000000..a975e7e799
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Ghc.hs
@@ -0,0 +1,149 @@
+module Settings.Builders.Ghc (ghcBuilderArgs, haddockGhcArgs) where
+
+import Hadrian.Haskell.Cabal
+
+import Flavour
+import Rules.Gmp
+import Settings.Builders.Common
+import Settings.Warnings
+
+ghcBuilderArgs :: Args
+ghcBuilderArgs = mconcat [compileAndLinkHs, compileC, findHsDependencies]
+
+compileAndLinkHs :: Args
+compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
+ needTouchy
+ mconcat [ arg "-Wall"
+ , commonGhcArgs
+ , splitObjectsArgs
+ , ghcLinkArgs
+ , defaultGhcWarningsArgs
+ , builder (Ghc CompileHs) ? arg "-c"
+ , getInputs
+ , arg "-o", arg =<< getOutput ]
+
+needTouchy :: Expr ()
+needTouchy = notStage0 ? windowsHost ? do
+ touchyPath <- expr $ programPath (vanillaContext Stage0 touchy)
+ expr $ need [touchyPath]
+
+compileC :: Args
+compileC = builder (Ghc CompileCWithGhc) ? do
+ way <- getWay
+ let ccArgs = [ getPkgDataList CcArgs
+ , getStagedSettingList ConfCcArgs
+ , cIncludeArgs
+ , Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ] ]
+ mconcat [ arg "-Wall"
+ , ghcLinkArgs
+ , commonGhcArgs
+ , mconcat (map (map ("-optc" ++) <$>) ccArgs)
+ , defaultGhcWarningsArgs
+ , arg "-c"
+ , getInputs
+ , arg "-o"
+ , arg =<< getOutput ]
+
+ghcLinkArgs :: Args
+ghcLinkArgs = builder (Ghc LinkHs) ? do
+ stage <- getStage
+ way <- getWay
+ pkg <- getPackage
+ libs <- getPkgDataList DepExtraLibs
+ libDirs <- getPkgDataList DepLibDirs
+ intLib <- getIntegerPackage
+ gmpLibs <- if stage > Stage0 && intLib == integerGmp
+ then do -- TODO: get this data more gracefully
+ let strip = fromMaybe "" . stripPrefix "extra-libraries: "
+ buildInfo <- expr $ readFileLines gmpBuildInfoPath
+ return $ concatMap (words . strip) buildInfo
+ else return []
+ mconcat [ (Dynamic `wayUnit` way) ?
+ pure [ "-shared", "-dynamic", "-dynload", "deploy" ]
+ , arg "-no-auto-link-packages"
+ , nonHsMainPackage pkg ? arg "-no-hs-main"
+ , not (nonHsMainPackage pkg) ? arg "-rtsopts"
+ , pure [ "-optl-l" ++ lib | lib <- libs ++ gmpLibs ]
+ , pure [ "-optl-L" ++ unifyPath dir | dir <- libDirs ] ]
+
+splitObjectsArgs :: Args
+splitObjectsArgs = splitObjects <$> flavour ? do
+ expr $ need [ghcSplitPath]
+ arg "-split-objs"
+
+findHsDependencies :: Args
+findHsDependencies = builder (Ghc FindHsDependencies) ? do
+ ways <- getLibraryWays
+ mconcat [ arg "-M"
+ , commonGhcArgs
+ , arg "-include-pkg-deps"
+ , arg "-dep-makefile", arg =<< getOutput
+ , pure $ concat [ ["-dep-suffix", wayPrefix w] | w <- ways ]
+ , getInputs ]
+
+haddockGhcArgs :: Args
+haddockGhcArgs = mconcat [ commonGhcArgs, getPkgDataList HsArgs ]
+
+-- Used in ghcBuilderArgs, ghcCBuilderArgs, ghcMBuilderArgs and haddockGhcArgs.
+commonGhcArgs :: Args
+commonGhcArgs = do
+ way <- getWay
+ path <- getBuildPath
+ pkg <- getPackage
+ when (isLibrary pkg) $ do
+ context <- getContext
+ conf <- expr $ pkgConfFile context
+ expr $ need [conf]
+ mconcat [ arg "-hisuf", arg $ hisuf way
+ , arg "-osuf" , arg $ osuf way
+ , arg "-hcsuf", arg $ hcsuf way
+ , wayGhcArgs
+ , packageGhcArgs
+ , includeGhcArgs
+ , map ("-optc" ++) <$> getStagedSettingList ConfCcArgs
+ , map ("-optP" ++) <$> getStagedSettingList ConfCppArgs
+ , map ("-optP" ++) <$> getPkgDataList CppArgs
+ , arg "-odir" , arg path
+ , arg "-hidir" , arg path
+ , arg "-stubdir" , arg path ]
+
+-- TODO: Do '-ticky' in all debug ways?
+wayGhcArgs :: Args
+wayGhcArgs = do
+ way <- getWay
+ mconcat [ if (Dynamic `wayUnit` way)
+ then pure ["-fPIC", "-dynamic"]
+ else arg "-static"
+ , (Threaded `wayUnit` way) ? arg "-optc-DTHREADED_RTS"
+ , (Debug `wayUnit` way) ? arg "-optc-DDEBUG"
+ , (Profiling `wayUnit` way) ? arg "-prof"
+ , (Logging `wayUnit` way) ? arg "-eventlog"
+ , (way == debug || way == debugDynamic) ?
+ pure ["-ticky", "-DTICKY_TICKY"] ]
+
+packageGhcArgs :: Args
+packageGhcArgs = withHsPackage $ \cabalFile -> do
+ pkgId <- expr $ pkgIdentifier cabalFile
+ mconcat [ arg "-hide-all-packages"
+ , arg "-no-user-package-db"
+ , bootPackageDatabaseArgs
+ , libraryPackage ? arg ("-this-unit-id " ++ pkgId)
+ , map ("-package-id " ++) <$> getPkgDataList DepIds ]
+
+includeGhcArgs :: Args
+includeGhcArgs = do
+ pkg <- getPackage
+ path <- getBuildPath
+ root <- getBuildRoot
+ context <- getContext
+ srcDirs <- getPkgDataList SrcDirs
+ autogen <- expr $ autogenPath context
+ mconcat [ arg "-i"
+ , arg $ "-i" ++ path
+ , arg $ "-i" ++ autogen
+ , pure [ "-i" ++ pkgPath pkg -/- dir | dir <- srcDirs ]
+ , cIncludeArgs
+ , arg $ "-I" ++ root -/- generatedDir
+ , arg $ "-optc-I" ++ root -/- generatedDir
+ , (not $ nonCabalContext context) ?
+ pure [ "-optP-include", "-optP" ++ autogen -/- "cabal_macros.h" ] ]
diff --git a/hadrian/src/Settings/Builders/GhcCabal.hs b/hadrian/src/Settings/Builders/GhcCabal.hs
new file mode 100644
index 0000000000..bfb84a76ec
--- /dev/null
+++ b/hadrian/src/Settings/Builders/GhcCabal.hs
@@ -0,0 +1,118 @@
+module Settings.Builders.GhcCabal (
+ ghcCabalBuilderArgs
+ ) where
+
+import Hadrian.Haskell.Cabal
+
+import Context
+import Flavour
+import Settings.Builders.Common
+
+ghcCabalBuilderArgs :: Args
+ghcCabalBuilderArgs = builder GhcCabal ? do
+ verbosity <- expr getVerbosity
+ top <- expr topDirectory
+ path <- getBuildPath
+ notStage0 ? expr (need inplaceLibCopyTargets)
+ mconcat [ arg "configure"
+ , arg =<< pkgPath <$> getPackage
+ , arg $ top -/- path
+ , withStaged $ Ghc CompileHs
+ , withStaged (GhcPkg Update)
+ , bootPackageDatabaseArgs
+ , libraryArgs
+ , configureArgs
+ , bootPackageConstraints
+ , withStaged $ Cc CompileC
+ , notStage0 ? with Ld
+ , withStaged (Ar Pack)
+ , with Alex
+ , with Happy
+ , verbosity < Chatty ? pure [ "-v0", "--configure-option=--quiet"
+ , "--configure-option=--disable-option-checking" ] ]
+
+-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
+-- TODO: Need compiler_stage1_CONFIGURE_OPTS += --disable-library-for-ghci?
+libraryArgs :: Args
+libraryArgs = do
+ ways <- getLibraryWays
+ withGhci <- expr ghcWithInterpreter
+ dynPrograms <- dynamicGhcPrograms <$> expr flavour
+ pure [ if vanilla `elem` ways
+ then "--enable-library-vanilla"
+ else "--disable-library-vanilla"
+ , if vanilla `elem` ways && withGhci && not dynPrograms
+ then "--enable-library-for-ghci"
+ else "--disable-library-for-ghci"
+ , if profiling `elem` ways
+ then "--enable-library-profiling"
+ else "--disable-library-profiling"
+ , if dynamic `elem` ways
+ then "--enable-shared"
+ else "--disable-shared" ]
+
+-- TODO: LD_OPTS?
+configureArgs :: Args
+configureArgs = do
+ top <- expr topDirectory
+ root <- getBuildRoot
+ let conf key expr = do
+ values <- unwords <$> expr
+ not (null values) ?
+ arg ("--configure-option=" ++ key ++ "=" ++ values)
+ cFlags = mconcat [ remove ["-Werror"] cArgs
+ , getStagedSettingList ConfCcArgs
+ , arg $ "-I" ++ top -/- root -/- generatedDir ]
+ ldFlags = ldArgs <> (getStagedSettingList ConfGccLinkerArgs)
+ cppFlags = cppArgs <> (getStagedSettingList ConfCppArgs)
+ cldFlags <- unwords <$> (cFlags <> ldFlags)
+ mconcat
+ [ conf "CFLAGS" cFlags
+ , conf "LDFLAGS" ldFlags
+ , conf "CPPFLAGS" cppFlags
+ , not (null cldFlags) ? arg ("--gcc-options=" ++ cldFlags)
+ , conf "--with-iconv-includes" $ arg =<< getSetting IconvIncludeDir
+ , conf "--with-iconv-libraries" $ arg =<< getSetting IconvLibDir
+ , conf "--with-gmp-includes" $ arg =<< getSetting GmpIncludeDir
+ , conf "--with-gmp-libraries" $ arg =<< getSetting GmpLibDir
+ , conf "--with-curses-libraries" $ arg =<< getSetting CursesLibDir
+ , crossCompiling ? (conf "--host" $ arg =<< getSetting TargetPlatformFull)
+ , conf "--with-cc" $ arg =<< getBuilderPath . (Cc CompileC) =<< getStage ]
+
+bootPackageConstraints :: Args
+bootPackageConstraints = stage0 ? do
+ bootPkgs <- expr $ stagePackages Stage0
+ let pkgs = filter (\p -> p /= compiler && isLibrary p) bootPkgs
+ constraints <- expr $ fmap catMaybes $ forM (sort pkgs) $ \pkg -> do
+ version <- traverse pkgVersion (pkgCabalFile pkg)
+ return $ fmap ((pkgName pkg ++ " == ") ++) version
+ pure $ concat [ ["--constraint", c] | c <- constraints ]
+
+cppArgs :: Args
+cppArgs = do
+ root <- getBuildRoot
+ arg $ "-I" ++ root -/- generatedDir
+
+withBuilderKey :: Builder -> String
+withBuilderKey b = case b of
+ Ar _ _ -> "--with-ar="
+ Ld -> "--with-ld="
+ Cc _ _ -> "--with-gcc="
+ Ghc _ _ -> "--with-ghc="
+ Alex -> "--with-alex="
+ Happy -> "--with-happy="
+ GhcPkg _ _ -> "--with-ghc-pkg="
+ _ -> error $ "withBuilderKey: not supported builder " ++ show b
+
+-- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
+with :: Builder -> Args
+with b = do
+ path <- getBuilderPath b
+ 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
+
diff --git a/hadrian/src/Settings/Builders/GhcPkg.hs b/hadrian/src/Settings/Builders/GhcPkg.hs
new file mode 100644
index 0000000000..ba705c6892
--- /dev/null
+++ b/hadrian/src/Settings/Builders/GhcPkg.hs
@@ -0,0 +1,17 @@
+module Settings.Builders.GhcPkg (ghcPkgBuilderArgs) where
+
+import Settings.Builders.Common
+
+ghcPkgBuilderArgs :: Args
+ghcPkgBuilderArgs = mconcat
+ [ builder (GhcPkg Init) ? mconcat [ arg "init", arg =<< getOutput ]
+
+ , builder (GhcPkg Update) ? do
+ verbosity <- expr getVerbosity
+ context <- getContext
+ config <- expr $ pkgInplaceConfig context
+ mconcat [ arg "update"
+ , arg "--force"
+ , verbosity < Chatty ? arg "-v0"
+ , bootPackageDatabaseArgs
+ , arg config ] ]
diff --git a/hadrian/src/Settings/Builders/Haddock.hs b/hadrian/src/Settings/Builders/Haddock.hs
new file mode 100644
index 0000000000..b3810476ad
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Haddock.hs
@@ -0,0 +1,63 @@
+module Settings.Builders.Haddock (haddockBuilderArgs) where
+
+import Hadrian.Utilities
+import Hadrian.Haskell.Cabal
+
+import Rules.Documentation
+import Settings.Builders.Common
+import Settings.Builders.Ghc
+
+-- | Given a version string such as "2.16.2" produce an integer equivalent.
+versionToInt :: String -> Int
+versionToInt s = case map read . words $ replaceEq '.' ' ' s of
+ [major, minor, patch] -> major * 1000 + minor * 10 + patch
+ _ -> error "versionToInt: cannot parse version."
+
+haddockBuilderArgs :: Args
+haddockBuilderArgs = withHsPackage $ \cabalFile -> mconcat
+ [ builder (Haddock BuildIndex) ? do
+ output <- getOutput
+ inputs <- getInputs
+ mconcat
+ [ arg "--gen-index"
+ , arg "--gen-contents"
+ , arg "-o", arg $ takeDirectory output
+ , arg "-t", arg "Haskell Hierarchical Libraries"
+ , arg "-p", arg "libraries/prologue.txt"
+ , pure [ "--read-interface="
+ ++ (takeFileName . takeDirectory) haddock
+ ++ "," ++ haddock | haddock <- inputs ] ]
+
+ , builder (Haddock BuildPackage) ? do
+ output <- getOutput
+ pkg <- getPackage
+ path <- getBuildPath
+ version <- expr $ pkgVersion cabalFile
+ synopsis <- expr $ pkgSynopsis cabalFile
+ deps <- getPkgDataList DepNames
+ haddocks <- expr . haddockDependencies =<< getContext
+ hVersion <- expr $ pkgVersion (unsafePkgCabalFile haddock) -- TODO: improve
+ ghcOpts <- haddockGhcArgs
+ mconcat
+ [ arg $ "--odir=" ++ takeDirectory output
+ , arg "--verbosity=0"
+ , arg "--no-tmp-comp-dir"
+ , arg $ "--dump-interface=" ++ output
+ , arg "--html"
+ , arg "--hyperlinked-source"
+ , arg "--hoogle"
+ , arg $ "--title=" ++ pkgName pkg ++ "-" ++ version
+ ++ ": " ++ synopsis
+ , arg $ "--prologue=" ++ path -/- "haddock-prologue.txt"
+ , arg $ "--optghc=-D__HADDOCK_VERSION__="
+ ++ show (versionToInt hVersion)
+ , map ("--hide=" ++) <$> getPkgDataList HiddenModules
+ , pure [ "--read-interface=../" ++ dep
+ ++ ",../" ++ dep ++ "/src/%{MODULE}.html#%{NAME},"
+ ++ haddock | (dep, haddock) <- zip deps haddocks ]
+ , pure [ "--optghc=" ++ opt | opt <- ghcOpts ]
+ , getInputs
+ , arg "+RTS"
+ , arg $ "-t" ++ path -/- "haddock.t"
+ , arg "--machine-readable"
+ , arg "-RTS" ] ]
diff --git a/hadrian/src/Settings/Builders/Happy.hs b/hadrian/src/Settings/Builders/Happy.hs
new file mode 100644
index 0000000000..5ffb2614cc
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Happy.hs
@@ -0,0 +1,9 @@
+module Settings.Builders.Happy (happyBuilderArgs) where
+
+import Settings.Builders.Common
+
+happyBuilderArgs :: Args
+happyBuilderArgs = builder Happy ? mconcat [ arg "-agc"
+ , arg "--strict"
+ , arg =<< getInput
+ , arg "-o", arg =<< getOutput ]
diff --git a/hadrian/src/Settings/Builders/HsCpp.hs b/hadrian/src/Settings/Builders/HsCpp.hs
new file mode 100644
index 0000000000..aeb5255990
--- /dev/null
+++ b/hadrian/src/Settings/Builders/HsCpp.hs
@@ -0,0 +1,16 @@
+module Settings.Builders.HsCpp (hsCppBuilderArgs) where
+
+import Settings.Builders.Common
+
+hsCppBuilderArgs :: Args
+hsCppBuilderArgs = builder HsCpp ? do
+ stage <- getStage
+ root <- getBuildRoot
+ ghcPath <- expr $ buildPath (vanillaContext stage compiler)
+ mconcat [ getSettingList HsCppArgs
+ , arg "-P"
+ , arg "-Iincludes"
+ , arg $ "-I" ++ root -/- generatedDir
+ , arg $ "-I" ++ ghcPath
+ , arg "-x", arg "c"
+ , arg =<< getInput ]
diff --git a/hadrian/src/Settings/Builders/Hsc2Hs.hs b/hadrian/src/Settings/Builders/Hsc2Hs.hs
new file mode 100644
index 0000000000..6185f6bec3
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Hsc2Hs.hs
@@ -0,0 +1,56 @@
+module Settings.Builders.Hsc2Hs (hsc2hsBuilderArgs) where
+
+import Settings.Builders.Common
+
+hsc2hsBuilderArgs :: Args
+hsc2hsBuilderArgs = builder Hsc2Hs ? do
+ stage <- getStage
+ ccPath <- getBuilderPath $ Cc CompileC stage
+ gmpDir <- getSetting GmpIncludeDir
+ top <- expr topDirectory
+ hArch <- getSetting HostArch
+ hOs <- getSetting HostOs
+ tArch <- getSetting TargetArch
+ tOs <- getSetting TargetOs
+ version <- if stage == Stage0
+ then expr ghcCanonVersion
+ else getSetting ProjectVersionInt
+ mconcat [ arg $ "--cc=" ++ ccPath
+ , arg $ "--ld=" ++ ccPath
+ , notM windowsHost ? arg "--cross-safe"
+ , pure $ map ("-I" ++) (words gmpDir)
+ , map ("--cflag=" ++) <$> getCFlags
+ , map ("--lflag=" ++) <$> getLFlags
+ , notStage0 ? crossCompiling ? arg "--cross-compile"
+ , stage0 ? arg ("--cflag=-D" ++ hArch ++ "_HOST_ARCH=1")
+ , stage0 ? arg ("--cflag=-D" ++ hOs ++ "_HOST_OS=1" )
+ , notStage0 ? arg ("--cflag=-D" ++ tArch ++ "_HOST_ARCH=1")
+ , notStage0 ? arg ("--cflag=-D" ++ tOs ++ "_HOST_OS=1" )
+ , arg $ "--cflag=-D__GLASGOW_HASKELL__=" ++ version
+ , arg $ "--template=" ++ top -/- templateHscPath
+ , arg $ "-I" ++ top -/- "inplace/lib/include/"
+ , arg =<< getInput
+ , arg "-o", arg =<< getOutput ]
+
+getCFlags :: Expr [String]
+getCFlags = do
+ context <- getContext
+ autogen <- expr $ autogenPath context
+ mconcat [ remove ["-O"] (cArgs <> getStagedSettingList ConfCcArgs)
+ , getStagedSettingList ConfCppArgs
+ , cIncludeArgs
+ , getPkgDataList CppArgs
+ , getPkgDataList DepCcArgs
+ , cWarnings
+ , arg "-include", arg $ autogen -/- "cabal_macros.h" ]
+
+getLFlags :: Expr [String]
+getLFlags = do
+ libDirs <- getPkgDataList DepLibDirs
+ extraLibs <- getPkgDataList DepExtraLibs
+ mconcat [ getStagedSettingList ConfGccLinkerArgs
+ , ldArgs
+ , getPkgDataList LdArgs
+ , pure [ "-L" ++ unifyPath dir | dir <- libDirs ]
+ , pure [ "-l" ++ unifyPath dir | dir <- extraLibs ]
+ , getPkgDataList DepLdArgs ]
diff --git a/hadrian/src/Settings/Builders/Ld.hs b/hadrian/src/Settings/Builders/Ld.hs
new file mode 100644
index 0000000000..2715bbb20c
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Ld.hs
@@ -0,0 +1,9 @@
+module Settings.Builders.Ld (ldBuilderArgs) where
+
+import Settings.Builders.Common
+
+ldBuilderArgs :: Args
+ldBuilderArgs = builder Ld ? mconcat [ getStagedSettingList ConfLdLinkerArgs
+ , arg "-r"
+ , arg "-o", arg =<< getOutput
+ , getInputs ]
diff --git a/hadrian/src/Settings/Builders/Make.hs b/hadrian/src/Settings/Builders/Make.hs
new file mode 100644
index 0000000000..cc350df508
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Make.hs
@@ -0,0 +1,16 @@
+module Settings.Builders.Make (makeBuilderArgs) where
+
+import Rules.Gmp
+import Rules.Libffi
+import Settings.Builders.Common
+
+makeBuilderArgs :: Args
+makeBuilderArgs = do
+ threads <- shakeThreads <$> expr getShakeOptions
+ gmpPath <- expr gmpBuildPath
+ libffiPath <- expr libffiBuildPath
+ let t = show $ max 4 (threads - 2) -- Don't use all Shake's threads
+ mconcat
+ [ builder (Make gmpPath ) ? pure ["MAKEFLAGS=-j" ++ t]
+ , builder (Make libffiPath ) ? pure ["MAKEFLAGS=-j" ++ t, "install"]
+ , builder (Make "testsuite/tests") ? pure ["THREADS=" ++ t, "fast"] ]
diff --git a/hadrian/src/Settings/Builders/Xelatex.hs b/hadrian/src/Settings/Builders/Xelatex.hs
new file mode 100644
index 0000000000..5623284ed5
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Xelatex.hs
@@ -0,0 +1,7 @@
+module Settings.Builders.Xelatex (xelatexBuilderArgs) where
+
+import Settings.Builders.Common
+
+xelatexBuilderArgs :: Args
+xelatexBuilderArgs = builder Xelatex ? mconcat [ arg "-halt-on-error"
+ , arg =<< getInput ]
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
new file mode 100644
index 0000000000..dc58f22160
--- /dev/null
+++ b/hadrian/src/Settings/Default.hs
@@ -0,0 +1,173 @@
+module Settings.Default (
+ SourceArgs (..), sourceArgs, defaultBuilderArgs, defaultPackageArgs,
+ defaultArgs, defaultLibraryWays, defaultRtsWays,
+ defaultFlavour, defaultSplitObjects
+ ) where
+
+import qualified Hadrian.Builder.Ar
+import qualified Hadrian.Builder.Sphinx
+import qualified Hadrian.Builder.Tar
+
+import CommandLine
+import Expression
+import Flavour
+import Oracles.Flag
+import Oracles.PackageData
+import Settings
+import Settings.Builders.Alex
+import Settings.Builders.DeriveConstants
+import Settings.Builders.Cc
+import Settings.Builders.Configure
+import Settings.Builders.GenPrimopCode
+import Settings.Builders.Ghc
+import Settings.Builders.GhcCabal
+import Settings.Builders.GhcPkg
+import Settings.Builders.Haddock
+import Settings.Builders.Happy
+import Settings.Builders.Hsc2Hs
+import Settings.Builders.HsCpp
+import Settings.Builders.Ld
+import Settings.Builders.Make
+import Settings.Builders.Xelatex
+import Settings.Packages.Base
+import Settings.Packages.Cabal
+import Settings.Packages.Compiler
+import Settings.Packages.Ghc
+import Settings.Packages.GhcCabal
+import Settings.Packages.Ghci
+import Settings.Packages.GhcPkg
+import Settings.Packages.GhcPrim
+import Settings.Packages.Haddock
+import Settings.Packages.Haskeline
+import Settings.Packages.IntegerGmp
+import Settings.Packages.Rts
+import Settings.Packages.RunGhc
+import Settings.Warnings
+
+-- TODO: Move C source arguments here
+-- | Default and package-specific source arguments.
+data SourceArgs = SourceArgs
+ { hsDefault :: Args
+ , hsLibrary :: Args
+ , hsCompiler :: Args
+ , hsGhc :: Args }
+
+-- | Concatenate source arguments in appropriate order.
+sourceArgs :: SourceArgs -> Args
+sourceArgs SourceArgs {..} = builder Ghc ? mconcat
+ [ hsDefault
+ , getPkgDataList HsArgs
+ , libraryPackage ? hsLibrary
+ , package compiler ? hsCompiler
+ , package ghc ? hsGhc ]
+
+-- | All default command line arguments.
+defaultArgs :: Args
+defaultArgs = mconcat
+ [ defaultBuilderArgs
+ , sourceArgs defaultSourceArgs
+ , defaultPackageArgs ]
+
+-- | Default source arguments, e.g. optimisation settings.
+defaultSourceArgs :: SourceArgs
+defaultSourceArgs = SourceArgs
+ { hsDefault = mconcat [ stage0 ? arg "-O"
+ , notStage0 ? arg "-O2"
+ , arg "-H32m" ]
+ , hsLibrary = mempty
+ , hsCompiler = mempty
+ , hsGhc = mempty }
+
+-- | Default build ways for library packages:
+-- * We always build 'vanilla' way.
+-- * We build 'profiling' way when stage > Stage0.
+-- * We build 'dynamic' way when stage > Stage0 and the platform supports it.
+defaultLibraryWays :: Ways
+defaultLibraryWays = mconcat
+ [ pure [vanilla]
+ , notStage0 ? pure [profiling]
+ , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ]
+
+-- | Default build ways for the RTS.
+defaultRtsWays :: Ways
+defaultRtsWays = do
+ ways <- getLibraryWays
+ mconcat
+ [ pure [ logging, debug, threaded, threadedDebug, threadedLogging ]
+ , (profiling `elem` ways) ? pure [threadedProfiling]
+ , (dynamic `elem` ways) ?
+ pure [ dynamic, debugDynamic, threadedDynamic, threadedDebugDynamic
+ , loggingDynamic, threadedLoggingDynamic ] ]
+
+-- Please update doc/flavours.md when changing the default build flavour.
+-- | Default build flavour. Other build flavours are defined in modules
+-- @Settings.Flavours.*@. Users can add new build flavours in "UserSettings".
+defaultFlavour :: Flavour
+defaultFlavour = Flavour
+ { name = "default"
+ , args = defaultArgs
+ , packages = defaultPackages
+ , integerLibrary = (\x -> if x then integerSimple else integerGmp) <$> cmdIntegerSimple
+ , libraryWays = defaultLibraryWays
+ , rtsWays = defaultRtsWays
+ , splitObjects = defaultSplitObjects
+ , dynamicGhcPrograms = False
+ , ghciWithDebugger = False
+ , ghcProfiled = False
+ , ghcDebugged = False }
+
+-- | Default condition for building split objects.
+defaultSplitObjects :: Predicate
+defaultSplitObjects = do
+ goodStage <- notStage0 -- We don't split bootstrap (stage 0) packages
+ pkg <- getPackage
+ supported <- expr supportsSplitObjects
+ split <- expr cmdSplitObjects
+ let goodPackage = isLibrary pkg && pkg /= compiler && pkg /= rts
+ return $ split && goodStage && goodPackage && supported
+
+-- | All 'Builder'-dependent command line arguments.
+defaultBuilderArgs :: Args
+defaultBuilderArgs = mconcat
+ -- GHC-specific builders:
+ [ alexBuilderArgs
+ , ccBuilderArgs
+ , configureBuilderArgs
+ , deriveConstantsBuilderArgs
+ , genPrimopCodeBuilderArgs
+ , ghcBuilderArgs
+ , ghcCabalBuilderArgs
+ , ghcPkgBuilderArgs
+ , haddockBuilderArgs
+ , happyBuilderArgs
+ , hsc2hsBuilderArgs
+ , hsCppBuilderArgs
+ , ldBuilderArgs
+ , makeBuilderArgs
+ , xelatexBuilderArgs
+ -- Generic builders from the Hadrian library:
+ , builder (Ar Pack ) ? Hadrian.Builder.Ar.args Pack
+ , builder (Ar Unpack ) ? Hadrian.Builder.Ar.args Unpack
+ , builder (Sphinx Html ) ? Hadrian.Builder.Sphinx.args Html
+ , builder (Sphinx Latex) ? Hadrian.Builder.Sphinx.args Latex
+ , builder (Sphinx Man ) ? Hadrian.Builder.Sphinx.args Man
+ , builder (Tar Create ) ? Hadrian.Builder.Tar.args Create
+ , builder (Tar Extract ) ? Hadrian.Builder.Tar.args Extract ]
+
+-- | All 'Package'-dependent command line arguments.
+defaultPackageArgs :: Args
+defaultPackageArgs = mconcat
+ [ basePackageArgs
+ , cabalPackageArgs
+ , compilerPackageArgs
+ , ghcCabalPackageArgs
+ , ghciPackageArgs
+ , ghcPackageArgs
+ , ghcPkgPackageArgs
+ , ghcPrimPackageArgs
+ , haddockPackageArgs
+ , haskelinePackageArgs
+ , integerGmpPackageArgs
+ , rtsPackageArgs
+ , runGhcPackageArgs
+ , warningArgs ]
diff --git a/hadrian/src/Settings/Default.hs-boot b/hadrian/src/Settings/Default.hs-boot
new file mode 100644
index 0000000000..468c5cae3e
--- /dev/null
+++ b/hadrian/src/Settings/Default.hs-boot
@@ -0,0 +1,20 @@
+module Settings.Default (
+ SourceArgs (..), sourceArgs, defaultBuilderArgs, defaultPackageArgs,
+ defaultArgs, defaultLibraryWays, defaultRtsWays, defaultFlavour, defaultSplitObjects
+ ) where
+
+import Flavour
+import Expression
+
+data SourceArgs = SourceArgs
+ { hsDefault :: Args
+ , hsLibrary :: Args
+ , hsCompiler :: Args
+ , hsGhc :: Args }
+
+sourceArgs :: SourceArgs -> Args
+
+defaultBuilderArgs, defaultPackageArgs, defaultArgs :: Args
+defaultLibraryWays, defaultRtsWays :: Ways
+defaultFlavour :: Flavour
+defaultSplitObjects :: Predicate
diff --git a/hadrian/src/Settings/Flavours/Development.hs b/hadrian/src/Settings/Flavours/Development.hs
new file mode 100644
index 0000000000..5919026cb0
--- /dev/null
+++ b/hadrian/src/Settings/Flavours/Development.hs
@@ -0,0 +1,20 @@
+module Settings.Flavours.Development (developmentFlavour) where
+
+import Expression
+import Flavour
+import {-# SOURCE #-} Settings.Default
+
+-- Please update doc/flavours.md when changing this file.
+developmentFlavour :: Stage -> Flavour
+developmentFlavour ghcStage = defaultFlavour
+ { name = "devel" ++ show (fromEnum ghcStage)
+ , args = defaultBuilderArgs <> developmentArgs ghcStage <> defaultPackageArgs }
+
+developmentArgs :: Stage -> Args
+developmentArgs ghcStage = do
+ stage <- getStage
+ sourceArgs SourceArgs
+ { hsDefault = pure ["-O", "-H64m"]
+ , hsLibrary = notStage0 ? arg "-dcore-lint"
+ , hsCompiler = succ stage == ghcStage ? pure ["-O0", "-DDEBUG"]
+ , hsGhc = succ stage == ghcStage ? pure ["-O0", "-DDEBUG"] }
diff --git a/hadrian/src/Settings/Flavours/Performance.hs b/hadrian/src/Settings/Flavours/Performance.hs
new file mode 100644
index 0000000000..64ab4bce9d
--- /dev/null
+++ b/hadrian/src/Settings/Flavours/Performance.hs
@@ -0,0 +1,18 @@
+module Settings.Flavours.Performance (performanceFlavour) where
+
+import Expression
+import Flavour
+import {-# SOURCE #-} Settings.Default
+
+-- Please update doc/flavours.md when changing this file.
+performanceFlavour :: Flavour
+performanceFlavour = defaultFlavour
+ { name = "perf"
+ , args = defaultBuilderArgs <> performanceArgs <> defaultPackageArgs }
+
+performanceArgs :: Args
+performanceArgs = sourceArgs SourceArgs
+ { hsDefault = pure ["-O", "-H64m"]
+ , hsLibrary = notStage0 ? arg "-O2"
+ , hsCompiler = mconcat [stage0 ? arg "-O", notStage0 ? arg "-O2"]
+ , hsGhc = mconcat [stage0 ? arg "-O", notStage0 ? arg "-O2"] }
diff --git a/hadrian/src/Settings/Flavours/Profiled.hs b/hadrian/src/Settings/Flavours/Profiled.hs
new file mode 100644
index 0000000000..d56cc10055
--- /dev/null
+++ b/hadrian/src/Settings/Flavours/Profiled.hs
@@ -0,0 +1,19 @@
+module Settings.Flavours.Profiled (profiledFlavour) where
+
+import Expression
+import Flavour
+import {-# SOURCE #-} Settings.Default
+
+-- Please update doc/flavours.md when changing this file.
+profiledFlavour :: Flavour
+profiledFlavour = defaultFlavour
+ { name = "prof"
+ , args = defaultBuilderArgs <> profiledArgs <> defaultPackageArgs
+ , ghcProfiled = True }
+
+profiledArgs :: Args
+profiledArgs = sourceArgs SourceArgs
+ { hsDefault = pure ["-O0", "-H64m"]
+ , hsLibrary = notStage0 ? arg "-O"
+ , hsCompiler = arg "-O"
+ , hsGhc = arg "-O" }
diff --git a/hadrian/src/Settings/Flavours/Quick.hs b/hadrian/src/Settings/Flavours/Quick.hs
new file mode 100644
index 0000000000..99dade9bf1
--- /dev/null
+++ b/hadrian/src/Settings/Flavours/Quick.hs
@@ -0,0 +1,22 @@
+module Settings.Flavours.Quick (quickFlavour) where
+
+import Expression
+import Flavour
+import Oracles.Flag
+import {-# SOURCE #-} Settings.Default
+
+-- Please update doc/flavours.md when changing this file.
+quickFlavour :: Flavour
+quickFlavour = defaultFlavour
+ { name = "quick"
+ , args = defaultBuilderArgs <> quickArgs <> defaultPackageArgs
+ , libraryWays = mconcat
+ [ pure [vanilla]
+ , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ] }
+
+quickArgs :: Args
+quickArgs = sourceArgs SourceArgs
+ { hsDefault = pure ["-O0", "-H64m"]
+ , hsLibrary = notStage0 ? arg "-O"
+ , hsCompiler = stage0 ? arg "-O"
+ , hsGhc = stage0 ? arg "-O" }
diff --git a/hadrian/src/Settings/Flavours/QuickCross.hs b/hadrian/src/Settings/Flavours/QuickCross.hs
new file mode 100644
index 0000000000..3d0c410bea
--- /dev/null
+++ b/hadrian/src/Settings/Flavours/QuickCross.hs
@@ -0,0 +1,24 @@
+module Settings.Flavours.QuickCross (quickCrossFlavour) where
+
+import Expression
+import Flavour
+import Oracles.Flag
+import {-# SOURCE #-} Settings.Default
+
+-- Please update doc/flavours.md when changing this file.
+quickCrossFlavour :: Flavour
+quickCrossFlavour = defaultFlavour
+ { name = "quick-cross"
+ , args = defaultBuilderArgs <> quickCrossArgs <> defaultPackageArgs
+ , libraryWays = mconcat
+ [ pure [vanilla]
+ , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ] }
+
+quickCrossArgs :: Args
+quickCrossArgs = sourceArgs SourceArgs
+ { hsDefault = pure ["-O0", "-H64m"]
+ , hsLibrary = notStage0 ? mconcat [ arg "-O", arg "-fllvm" ]
+ , hsCompiler = stage0 ? arg "-O"
+ , hsGhc = mconcat
+ [ stage0 ? arg "-O"
+ , stage1 ? mconcat [ arg "-O0", arg "-fllvm" ] ] }
diff --git a/hadrian/src/Settings/Flavours/Quickest.hs b/hadrian/src/Settings/Flavours/Quickest.hs
new file mode 100644
index 0000000000..a9dfb7087f
--- /dev/null
+++ b/hadrian/src/Settings/Flavours/Quickest.hs
@@ -0,0 +1,23 @@
+module Settings.Flavours.Quickest (quickestFlavour) where
+
+import Expression
+import Flavour
+import {-# SOURCE #-} Settings.Default
+
+-- Please update doc/flavours.md when changing this file.
+quickestFlavour :: Flavour
+quickestFlavour = defaultFlavour
+ { name = "quickest"
+ , args = defaultBuilderArgs <> quickestArgs <> defaultPackageArgs
+ , libraryWays = pure [vanilla]
+ , rtsWays = quickestRtsWays }
+
+quickestArgs :: Args
+quickestArgs = sourceArgs SourceArgs
+ { hsDefault = pure ["-O0", "-H64m"]
+ , hsLibrary = mempty
+ , hsCompiler = stage0 ? arg "-O"
+ , hsGhc = stage0 ? arg "-O" }
+
+quickestRtsWays :: Ways
+quickestRtsWays = pure [vanilla, threaded]
diff --git a/hadrian/src/Settings/Packages/Base.hs b/hadrian/src/Settings/Packages/Base.hs
new file mode 100644
index 0000000000..2e0ced4c26
--- /dev/null
+++ b/hadrian/src/Settings/Packages/Base.hs
@@ -0,0 +1,12 @@
+module Settings.Packages.Base (basePackageArgs) where
+
+import Expression
+import Settings
+
+basePackageArgs :: Args
+basePackageArgs = package base ? do
+ integerLibraryName <- pkgName <$> getIntegerPackage
+ mconcat [ builder GhcCabal ? arg ("--flags=" ++ integerLibraryName)
+ -- This fixes the 'unknown symbol stat' issue.
+ -- See: https://github.com/snowleopard/hadrian/issues/259.
+ , builder (Ghc CompileCWithGhc) ? arg "-optc-O2" ]
diff --git a/hadrian/src/Settings/Packages/Cabal.hs b/hadrian/src/Settings/Packages/Cabal.hs
new file mode 100644
index 0000000000..c01be4b3ed
--- /dev/null
+++ b/hadrian/src/Settings/Packages/Cabal.hs
@@ -0,0 +1,10 @@
+module Settings.Packages.Cabal where
+
+import Expression
+
+cabalPackageArgs :: Args
+cabalPackageArgs = package cabal ?
+ -- Cabal is a rather large library and quite slow to compile. Moreover, we
+ -- build it for stage0 only so we can link ghc-pkg against it, so there is
+ -- little reason to spend the effort to optimize it.
+ stage0 ? builder Ghc ? arg "-O0"
diff --git a/hadrian/src/Settings/Packages/Compiler.hs b/hadrian/src/Settings/Packages/Compiler.hs
new file mode 100644
index 0000000000..6b329d7b4f
--- /dev/null
+++ b/hadrian/src/Settings/Packages/Compiler.hs
@@ -0,0 +1,45 @@
+module Settings.Packages.Compiler (compilerPackageArgs) where
+
+import Base
+import Expression
+import Flavour
+import Oracles.Flag
+import Oracles.Setting
+import Settings
+
+compilerPackageArgs :: Args
+compilerPackageArgs = package compiler ? do
+ stage <- getStage
+ rtsWays <- getRtsWays
+ path <- getBuildPath
+ mconcat [ builder Alex ? arg "--latin1"
+
+ , builder (Ghc CompileHs) ? mconcat
+ [ inputs ["//GHC.hs", "//GhcMake.hs"] ? arg "-fprof-auto"
+ , input "//Parser.hs" ?
+ pure ["-O0", "-fno-ignore-interface-pragmas", "-fcmm-sink" ] ]
+
+ , builder GhcCabal ? mconcat
+ [ arg $ "--ghc-option=-DSTAGE=" ++ show (fromEnum stage + 1)
+ , arg "--disable-library-for-ghci"
+ , anyTargetOs ["openbsd"] ? arg "--ld-options=-E"
+ , flag GhcUnregisterised ? arg "--ghc-option=-DNO_REGS"
+ , notM ghcWithSMP ? arg "--ghc-option=-DNOSMP"
+ , notM ghcWithSMP ? arg "--ghc-option=-optc-DNOSMP"
+ , (threaded `elem` rtsWays) ?
+ notStage0 ? arg "--ghc-option=-optc-DTHREADED_RTS"
+ , ghcWithNativeCodeGen ? arg "--flags=ncg"
+ , ghcWithInterpreter ?
+ notStage0 ? arg "--flags=ghci"
+ , crossCompiling ? arg "-f-terminfo"
+ , ghcWithInterpreter ?
+ ghcEnableTablesNextToCode ?
+ notM (flag GhcUnregisterised) ?
+ notStage0 ? arg "--ghc-option=-DGHCI_TABLES_NEXT_TO_CODE"
+ , ghcWithInterpreter ?
+ ghciWithDebugger <$> flavour ?
+ notStage0 ? arg "--ghc-option=-DDEBUGGER"
+ , ghcProfiled <$> flavour ?
+ notStage0 ? arg "--ghc-pkg-option=--force" ]
+
+ , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ]
diff --git a/hadrian/src/Settings/Packages/Ghc.hs b/hadrian/src/Settings/Packages/Ghc.hs
new file mode 100644
index 0000000000..d7b1d78ddd
--- /dev/null
+++ b/hadrian/src/Settings/Packages/Ghc.hs
@@ -0,0 +1,13 @@
+module Settings.Packages.Ghc (ghcPackageArgs) where
+
+import Expression
+import Oracles.Setting
+import Oracles.Flag (crossCompiling)
+
+ghcPackageArgs :: Args
+ghcPackageArgs = package ghc ? do
+ stage <- getStage
+ path <- expr $ buildPath (vanillaContext stage compiler)
+ mconcat [ builder Ghc ? arg ("-I" ++ path)
+ , builder GhcCabal ? ghcWithInterpreter ? notStage0 ? arg "--flags=ghci"
+ , builder GhcCabal ? crossCompiling ? arg "-f-terminfo" ]
diff --git a/hadrian/src/Settings/Packages/GhcCabal.hs b/hadrian/src/Settings/Packages/GhcCabal.hs
new file mode 100644
index 0000000000..7d2e99e536
--- /dev/null
+++ b/hadrian/src/Settings/Packages/GhcCabal.hs
@@ -0,0 +1,24 @@
+module Settings.Packages.GhcCabal (ghcCabalPackageArgs) where
+
+import Hadrian.Haskell.Cabal
+
+import Base
+import Expression
+import Utilities
+
+ghcCabalPackageArgs :: Args
+ghcCabalPackageArgs = stage0 ? package ghcCabal ? builder Ghc ? do
+ cabalDeps <- expr $ stage1Dependencies cabal
+ cabalVersion <- expr $ pkgVersion (unsafePkgCabalFile cabal) -- TODO: improve
+ mconcat
+ [ pure [ "-package " ++ pkgName pkg | pkg <- cabalDeps, pkg /= parsec ]
+ , arg "--make"
+ , arg "-j"
+ , pure ["-Wall", "-fno-warn-unused-imports", "-fno-warn-warnings-deprecations"]
+ , arg ("-DCABAL_VERSION=" ++ replace "." "," cabalVersion)
+ , arg "-DBOOTSTRAPPING"
+ , arg "-DMIN_VERSION_binary_0_8_0"
+ , arg "-ilibraries/Cabal/Cabal"
+ , arg "-ilibraries/binary/src"
+ , arg "-ilibraries/filepath"
+ , arg "-ilibraries/hpc" ]
diff --git a/hadrian/src/Settings/Packages/GhcPkg.hs b/hadrian/src/Settings/Packages/GhcPkg.hs
new file mode 100644
index 0000000000..a13a9dab7e
--- /dev/null
+++ b/hadrian/src/Settings/Packages/GhcPkg.hs
@@ -0,0 +1,7 @@
+module Settings.Packages.GhcPkg (ghcPkgPackageArgs) where
+
+import Expression
+import Oracles.Flag (crossCompiling)
+
+ghcPkgPackageArgs :: Args
+ghcPkgPackageArgs = package ghcPkg ? builder GhcCabal ? crossCompiling ? arg "-f-terminfo"
diff --git a/hadrian/src/Settings/Packages/GhcPrim.hs b/hadrian/src/Settings/Packages/GhcPrim.hs
new file mode 100644
index 0000000000..df1c553d25
--- /dev/null
+++ b/hadrian/src/Settings/Packages/GhcPrim.hs
@@ -0,0 +1,13 @@
+module Settings.Packages.GhcPrim (ghcPrimPackageArgs) where
+
+import Oracles.Flag
+import Expression
+
+ghcPrimPackageArgs :: Args
+ghcPrimPackageArgs = package ghcPrim ? mconcat
+ [ builder GhcCabal ? arg "--flag=include-ghc-prim"
+
+ , builder (Cc CompileC) ?
+ (not <$> flag GccLt44) ?
+ (not <$> flag GccIsClang) ?
+ input "//cbits/atomic.c" ? arg "-Wno-sync-nand" ]
diff --git a/hadrian/src/Settings/Packages/Ghci.hs b/hadrian/src/Settings/Packages/Ghci.hs
new file mode 100644
index 0000000000..47e7d38deb
--- /dev/null
+++ b/hadrian/src/Settings/Packages/Ghci.hs
@@ -0,0 +1,6 @@
+module Settings.Packages.Ghci (ghciPackageArgs) where
+
+import Expression
+
+ghciPackageArgs :: Args
+ghciPackageArgs = package ghci ? notStage0 ? builder GhcCabal ? arg "--flags=ghci"
diff --git a/hadrian/src/Settings/Packages/Haddock.hs b/hadrian/src/Settings/Packages/Haddock.hs
new file mode 100644
index 0000000000..c8d667ecb4
--- /dev/null
+++ b/hadrian/src/Settings/Packages/Haddock.hs
@@ -0,0 +1,7 @@
+module Settings.Packages.Haddock (haddockPackageArgs) where
+
+import Expression
+
+haddockPackageArgs :: Args
+haddockPackageArgs = package haddock ?
+ builder GhcCabal ? pure ["--flag", "in-ghc-tree"]
diff --git a/hadrian/src/Settings/Packages/Haskeline.hs b/hadrian/src/Settings/Packages/Haskeline.hs
new file mode 100644
index 0000000000..254c6b704c
--- /dev/null
+++ b/hadrian/src/Settings/Packages/Haskeline.hs
@@ -0,0 +1,8 @@
+module Settings.Packages.Haskeline (haskelinePackageArgs) where
+
+import Expression
+import Oracles.Flag (crossCompiling)
+
+haskelinePackageArgs :: Args
+haskelinePackageArgs =
+ package haskeline ? builder GhcCabal ? crossCompiling ? arg "-f-terminfo"
diff --git a/hadrian/src/Settings/Packages/IntegerGmp.hs b/hadrian/src/Settings/Packages/IntegerGmp.hs
new file mode 100644
index 0000000000..7c2b5f635b
--- /dev/null
+++ b/hadrian/src/Settings/Packages/IntegerGmp.hs
@@ -0,0 +1,24 @@
+module Settings.Packages.IntegerGmp (integerGmpPackageArgs) where
+
+import Base
+import Expression
+import Oracles.Setting
+import Rules.Gmp
+
+-- TODO: Is this needed?
+-- ifeq "$(GMP_PREFER_FRAMEWORK)" "YES"
+-- libraries/integer-gmp_CONFIGURE_OPTS += --with-gmp-framework-preferred
+-- endif
+integerGmpPackageArgs :: Args
+integerGmpPackageArgs = package integerGmp ? do
+ path <- expr gmpBuildPath
+ let includeGmp = "-I" ++ path -/- "include"
+ gmpIncludeDir <- getSetting GmpIncludeDir
+ gmpLibDir <- getSetting GmpLibDir
+ mconcat [ builder Cc ? arg includeGmp
+
+ , builder GhcCabal ? mconcat
+ [ (null gmpIncludeDir && null gmpLibDir) ?
+ arg "--configure-option=--with-intree-gmp"
+ , arg ("--configure-option=CFLAGS=" ++ includeGmp)
+ , arg ("--gcc-options=" ++ includeGmp) ] ]
diff --git a/hadrian/src/Settings/Packages/Rts.hs b/hadrian/src/Settings/Packages/Rts.hs
new file mode 100644
index 0000000000..33169fe78b
--- /dev/null
+++ b/hadrian/src/Settings/Packages/Rts.hs
@@ -0,0 +1,218 @@
+module Settings.Packages.Rts (
+ rtsContext, rtsBuildPath, rtsConfIn, rtsPackageArgs, rtsLibffiLibrary
+ ) where
+
+import Base
+import Expression
+import Oracles.Flag
+import Oracles.Setting
+import Settings
+
+-- | RTS is considered a Stage1 package. This determines RTS build directory.
+rtsContext :: Context
+rtsContext = vanillaContext Stage1 rts
+
+-- | Path to the RTS build directory.
+rtsBuildPath :: Action FilePath
+rtsBuildPath = buildPath rtsContext
+
+-- | Path to RTS package configuration file, to be processed by HsCpp.
+rtsConfIn :: FilePath
+rtsConfIn = pkgPath rts -/- "package.conf.in"
+
+-- These numbers can be found at:
+-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx
+-- If we're compiling on windows, enforce that we only support Vista SP1+
+-- Adding this here means it doesn't have to be done in individual .c files
+-- and also centralizes the versioning.
+-- | Minimum supported Windows version.
+windowsVersion :: String
+windowsVersion = "0x06000100"
+
+libffiLibraryName :: Action FilePath
+libffiLibraryName = do
+ useSystemFfi <- flag UseSystemFfi
+ windows <- windowsHost
+ return $ case (useSystemFfi, windows) of
+ (True , False) -> "ffi"
+ (False, False) -> "Cffi"
+ (_ , True ) -> "Cffi-6"
+
+rtsLibffiLibrary :: Way -> Action FilePath
+rtsLibffiLibrary way = do
+ name <- libffiLibraryName
+ suf <- libsuf way
+ rtsPath <- rtsBuildPath
+ return $ rtsPath -/- "lib" ++ name ++ suf
+
+-- Compile various performance-critical pieces *without* -fPIC -dynamic
+-- even when building a shared library. If we don't do this, then the
+-- GC runs about 50% slower on x86 due to the overheads of PIC. The
+-- cost of doing this is a little runtime linking and less sharing, but
+-- not much.
+--
+-- On x86_64 this doesn't work, because all objects in a shared library
+-- must be compiled with -fPIC (since the 32-bit relocations generated
+-- by the default small memory can't be resolved at runtime). So we
+-- only do this on i386.
+--
+-- This apparently doesn't work on OS X (Darwin) nor on Solaris.
+-- On Darwin we get errors of the form
+--
+-- ld: absolute addressing (perhaps -mdynamic-no-pic) used in _stg_ap_0_fast from rts/dist/build/Apply.dyn_o not allowed in slidable image
+--
+-- and lots of these warnings:
+--
+-- ld: warning codegen in _stg_ap_pppv_fast (offset 0x0000005E) prevents image from loading in dyld shared cache
+--
+-- On Solaris we get errors like:
+--
+-- Text relocation remains referenced
+-- against symbol offset in file
+-- .rodata (section) 0x11 rts/dist/build/Apply.dyn_o
+-- ...
+-- ld: fatal: relocations remain against allocatable but non-writable sections
+-- collect2: ld returned 1 exit status
+speedHack :: Action Bool
+speedHack = do
+ i386 <- anyTargetArch ["i386"]
+ goodOS <- not <$> anyTargetOs ["darwin", "solaris2"]
+ return $ i386 && goodOS
+
+rtsPackageArgs :: Args
+rtsPackageArgs = package rts ? do
+ projectVersion <- getSetting ProjectVersion
+ hostPlatform <- getSetting HostPlatform
+ hostArch <- getSetting HostArch
+ hostOs <- getSetting HostOs
+ hostVendor <- getSetting HostVendor
+ buildPlatform <- getSetting BuildPlatform
+ buildArch <- getSetting BuildArch
+ buildOs <- getSetting BuildOs
+ buildVendor <- getSetting BuildVendor
+ targetPlatform <- getSetting TargetPlatform
+ targetArch <- getSetting TargetArch
+ targetOs <- getSetting TargetOs
+ targetVendor <- getSetting TargetVendor
+ ghcUnreg <- expr $ yesNo <$> flag GhcUnregisterised
+ ghcEnableTNC <- expr $ yesNo <$> ghcEnableTablesNextToCode
+ way <- getWay
+ path <- getBuildPath
+ top <- expr topDirectory
+ libffiName <- expr libffiLibraryName
+ ffiIncludeDir <- getSetting FfiIncludeDir
+ ffiLibraryDir <- getSetting FfiLibDir
+ ghclibDir <- expr installGhcLibDir
+ destDir <- expr getDestDir
+ let cArgs = mconcat
+ [ arg "-Irts"
+ , rtsWarnings
+ , arg $ "-I" ++ path
+ , flag UseSystemFfi ? arg ("-I" ++ ffiIncludeDir)
+ , arg $ "-DRtsWay=\"rts_" ++ show way ++ "\""
+ -- RTS *must* be compiled with optimisations. The INLINE_HEADER macro
+ -- requires that functions are inlined to work as expected. Inlining
+ -- only happens for optimised builds. Otherwise we can assume that
+ -- there is a non-inlined variant to use instead. But RTS does not
+ -- provide non-inlined alternatives and hence needs the function to
+ -- be inlined. See https://github.com/snowleopard/hadrian/issues/90.
+ , arg "-O2"
+
+ , Debug `wayUnit` way ? arg "-DDEBUG"
+ , way `elem` [debug, debugDynamic] ? arg "-DTICKY_TICKY"
+ , Profiling `wayUnit` way ? arg "-DPROFILING"
+ , Threaded `wayUnit` way ? arg "-DTHREADED_RTS"
+
+ , inputs ["//RtsMessages.c", "//Trace.c"] ?
+ arg ("-DProjectVersion=" ++ show projectVersion)
+
+ , input "//RtsUtils.c" ? pure
+ [ "-DProjectVersion=" ++ show projectVersion
+ , "-DHostPlatform=" ++ show hostPlatform
+ , "-DHostArch=" ++ show hostArch
+ , "-DHostOS=" ++ show hostOs
+ , "-DHostVendor=" ++ show hostVendor
+ , "-DBuildPlatform=" ++ show buildPlatform
+ , "-DBuildArch=" ++ show buildArch
+ , "-DBuildOS=" ++ show buildOs
+ , "-DBuildVendor=" ++ show buildVendor
+ , "-DTargetPlatform=" ++ show targetPlatform
+ , "-DTargetArch=" ++ show targetArch
+ , "-DTargetOS=" ++ show targetOs
+ , "-DTargetVendor=" ++ show targetVendor
+ , "-DGhcUnregisterised=" ++ show ghcUnreg
+ , "-DGhcEnableTablesNextToCode=" ++ show ghcEnableTNC ]
+
+ , inputs ["//Evac.c", "//Evac_thr.c"] ? arg "-funroll-loops"
+
+ , speedHack ?
+ inputs [ "//Evac.c", "//Evac_thr.c"
+ , "//Scav.c", "//Scav_thr.c"
+ , "//Compact.c", "//GC.c" ] ? arg "-fno-PIC"
+ -- -static is also necessary for these bits, otherwise the NCG
+ -- generates dynamic references:
+ , speedHack ?
+ inputs [ "//Updates.c", "//StgMiscClosures.c"
+ , "//PrimOps.c", "//Apply.c"
+ , "//AutoApply.c" ] ? pure ["-fno-PIC", "-static"]
+
+ -- inlining warnings happen in Compact
+ , inputs ["//Compact.c"] ? arg "-Wno-inline"
+
+ -- emits warnings about call-clobbered registers on x86_64
+ , inputs [ "//RetainerProfile.c", "//StgCRun.c"
+ , "//win32/ConsoleHandler.c", "//win32/ThrIOManager.c"] ? arg "-w"
+ , inputs ["//RetainerSet.c"] ? arg "-Wno-format"
+ -- The above warning suppression flags are a temporary kludge.
+ -- While working on this module you are encouraged to remove it and fix
+ -- any warnings in the module. See:
+ -- http://ghc.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+
+ , (not <$> flag GccIsClang) ?
+ inputs ["//Compact.c"] ? arg "-finline-limit=2500"
+
+ , inputs ["//Evac_thr.c", "//Scav_thr.c"] ?
+ pure ["-DPARALLEL_GC", "-Irts/sm"]
+
+ , input "//StgCRun.c" ? windowsHost ? arg "-Wno-return-local-addr"
+ , input "//RetainerProfile.c" ? flag GccIsClang ?
+ arg "-Wno-incompatible-pointer-types"
+ , inputs [ "//Interpreter.c", "//Storage.c", "//Adjustor.c" ] ?
+ arg "-Wno-strict-prototypes"
+ , windowsHost ? arg ("-DWINVER=" ++ windowsVersion) ]
+ mconcat
+ [ builder (Cc FindCDependencies) ? cArgs
+ , builder (Ghc CompileCWithGhc) ? map ("-optc" ++) <$> cArgs
+ , builder Ghc ? arg "-Irts"
+
+ , builder HsCpp ? pure
+ [ "-DTOP=" ++ show top
+ , "-DFFI_INCLUDE_DIR=" ++ show ffiIncludeDir
+ , "-DFFI_LIB_DIR=" ++ show ffiLibraryDir
+ , "-DFFI_LIB=" ++ show libffiName ]
+
+ , builder HsCpp ?
+ input "//package.conf.in" ?
+ output "//package.conf.install.raw" ?
+ pure [ "-DINSTALLING"
+ , "-DLIB_DIR=\"" ++ destDir ++ ghclibDir ++ "\""
+ , "-DINCLUDE_DIR=\"" ++ destDir ++ ghclibDir -/- "include\"" ]
+
+ , builder HsCpp ? flag HaveLibMingwEx ? arg "-DHAVE_LIBMINGWEX" ]
+
+-- See @rts/ghc.mk@.
+rtsWarnings :: Args
+rtsWarnings = mconcat
+ [ pure ["-Wall", "-Werror"]
+ , flag GccLt34 ? arg "-W", not <$> flag GccLt34 ? arg "-Wextra"
+ , arg "-Wstrict-prototypes"
+ , arg "-Wmissing-prototypes"
+ , arg "-Wmissing-declarations"
+ , arg "-Winline"
+ , arg "-Waggregate-return"
+ , arg "-Wpointer-arith"
+ , arg "-Wmissing-noreturn"
+ , arg "-Wnested-externs"
+ , arg "-Wredundant-decls"
+ , not <$> flag GccLt46 ? arg "-Wundef"
+ , arg "-fno-strict-aliasing" ]
diff --git a/hadrian/src/Settings/Packages/RunGhc.hs b/hadrian/src/Settings/Packages/RunGhc.hs
new file mode 100644
index 0000000000..03a19c8373
--- /dev/null
+++ b/hadrian/src/Settings/Packages/RunGhc.hs
@@ -0,0 +1,9 @@
+module Settings.Packages.RunGhc (runGhcPackageArgs) where
+
+import Oracles.Setting
+import Expression
+
+runGhcPackageArgs :: Args
+runGhcPackageArgs = package runGhc ? builder Ghc ? input "//Main.hs" ? do
+ version <- getSetting ProjectVersion
+ pure ["-cpp", "-DVERSION=" ++ show version]
diff --git a/hadrian/src/Settings/Warnings.hs b/hadrian/src/Settings/Warnings.hs
new file mode 100644
index 0000000000..f8eb4a5da0
--- /dev/null
+++ b/hadrian/src/Settings/Warnings.hs
@@ -0,0 +1,57 @@
+module Settings.Warnings (defaultGhcWarningsArgs, warningArgs) where
+
+import Expression
+import Oracles.Flag
+import Oracles.Setting
+import Settings
+
+-- See @mk/warnings.mk@ for warning-related arguments in the Make build system.
+
+-- | Default Haskell warning-related arguments.
+defaultGhcWarningsArgs :: Args
+defaultGhcWarningsArgs = mconcat
+ [ notStage0 ? pure [ "-Werror", "-Wnoncanonical-monad-instances" ]
+ , (not <$> flag GccIsClang) ? mconcat
+ [ (not <$> flag GccLt46) ?
+ (not <$> windowsHost ) ? arg "-optc-Werror=unused-but-set-variable"
+ , (not <$> flag GccLt44) ? arg "-optc-Wno-error=inline" ]
+ , flag GccIsClang ? arg "-optc-Wno-unknown-pragmas" ]
+
+-- | Package-specific warnings-related arguments, mostly suppressing various warnings.
+warningArgs :: Args
+warningArgs = builder Ghc ? do
+ isIntegerSimple <- (== integerSimple) <$> getIntegerPackage
+ mconcat
+ [ stage0 ? mconcat
+ [ libraryPackage ? pure [ "-fno-warn-deprecated-flags" ]
+ , package terminfo ? pure [ "-fno-warn-unused-imports" ]
+ , package transformers ? pure [ "-fno-warn-unused-matches"
+ , "-fno-warn-unused-imports" ] ]
+ , notStage0 ? mconcat
+ [ libraryPackage ? pure [ "-Wno-deprecated-flags" ]
+ , package base ? pure [ "-Wno-trustworthy-safe" ]
+ , package binary ? pure [ "-Wno-deprecations" ]
+ , package bytestring ? pure [ "-Wno-inline-rule-shadowing" ]
+ , package compiler ? pure [ "-Wcpp-undef" ]
+ , package directory ? pure [ "-Wno-unused-imports" ]
+ , package ghc ? pure [ "-Wcpp-undef" ]
+ , package ghcPrim ? pure [ "-Wno-trustworthy-safe" ]
+ , package haddock ? pure [ "-Wno-unused-imports"
+ , "-Wno-deprecations" ]
+ , package haskeline ? pure [ "-Wno-deprecations"
+ , "-Wno-unused-imports"
+ , "-Wno-redundant-constraints"
+ , "-Wno-simplifiable-class-constraints" ]
+ , package pretty ? pure [ "-Wno-unused-imports" ]
+ , package primitive ? pure [ "-Wno-unused-imports"
+ , "-Wno-deprecations" ]
+ , package rts ? pure [ "-Wcpp-undef" ]
+ , package terminfo ? pure [ "-Wno-unused-imports" ]
+ , isIntegerSimple ?
+ package text ? pure [ "-Wno-unused-imports" ]
+ , package transformers ? pure [ "-Wno-unused-matches"
+ , "-Wno-unused-imports"
+ , "-Wno-redundant-constraints"
+ , "-Wno-orphans" ]
+ , package win32 ? pure [ "-Wno-trustworthy-safe" ]
+ , package xhtml ? pure [ "-Wno-unused-imports" ] ] ]
diff --git a/hadrian/src/Stage.hs b/hadrian/src/Stage.hs
new file mode 100644
index 0000000000..7c9405c2b8
--- /dev/null
+++ b/hadrian/src/Stage.hs
@@ -0,0 +1,31 @@
+module Stage (Stage (..), stageString) where
+
+import Development.Shake.Classes
+import GHC.Generics
+
+-- | A stage refers to a certain compiler in GHC's build process.
+--
+-- * Stage 0 is built with the bootstrapping compiler, i.e. the one already
+-- installed on the user's system. The compiler that is produced during
+-- stage 0 is called /stage 1 compiler/.
+--
+-- * Stage 1 is built using the stage 1 compiler and all GHC sources. The result
+-- is called /stage 2 compiler/ and it has all features of the new GHC.
+--
+-- * Stage 2 is built using the stage 2 compiler. The result is a compiler
+-- fully "built by itself", commonly referred to as /bootstrapping/.
+--
+-- * Stage 3 is built as a self test. The resulting compiler should have
+-- the same object code as the one built in stage 2, which is a good test
+-- for the compiler. Since it serves no other purpose than that, the stage 3
+-- build is usually omitted in the build process.
+data Stage = Stage0 | Stage1 | Stage2 | Stage3
+ deriving (Show, Eq, Ord, Enum, Generic, Bounded)
+
+instance Binary Stage
+instance Hashable Stage
+instance NFData Stage
+
+-- | Prettyprint a 'Stage'.
+stageString :: Stage -> String
+stageString stage = "stage" ++ show (fromEnum stage)
diff --git a/hadrian/src/Target.hs b/hadrian/src/Target.hs
new file mode 100644
index 0000000000..30c8d98d14
--- /dev/null
+++ b/hadrian/src/Target.hs
@@ -0,0 +1,26 @@
+module Target (
+ Target, target, context, builder, inputs, outputs, trackArgument,
+ module Builder
+ ) where
+
+import Data.Char
+import Data.List.Extra
+
+import qualified Hadrian.Target as H
+import Hadrian.Target hiding (Target)
+
+import Builder
+import Context
+
+type Target = H.Target Context Builder
+
+-- | Some arguments do not affect build results and therefore do not need to be
+-- tracked by the build system. A notable example is "-jN" that controls Make's
+-- parallelism. Given a 'Target' and an argument, this function should return
+-- 'True' only if the argument needs to be tracked.
+trackArgument :: Target -> String -> Bool
+trackArgument target arg = case builder target of
+ (Make _) -> not $ threadArg arg
+ _ -> True
+ where
+ threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="]
diff --git a/hadrian/src/UserSettings.hs b/hadrian/src/UserSettings.hs
new file mode 100644
index 0000000000..1b7c3f8bdd
--- /dev/null
+++ b/hadrian/src/UserSettings.hs
@@ -0,0 +1,64 @@
+-- If you want to customise your build you should copy this file from
+-- hadrian/src/UserSettings.hs to hadrian/UserSettings.hs and edit your copy.
+-- If you don't copy the file your changes will be tracked by git and you can
+-- accidentally commit them.
+module UserSettings (
+ userBuildRoot, userFlavours, userPackages, verboseCommand,
+ buildProgressColour, successColour, stage1Only
+ ) where
+
+import Hadrian.Utilities
+import System.Console.ANSI
+
+import Flavour
+import Expression
+import {-# SOURCE #-} Settings.Default
+
+-- See doc/user-settings.md for instructions.
+-- Please update doc/user-settings.md when committing changes to this file.
+
+-- | All build results are put into the 'buildRoot' directory.
+userBuildRoot :: BuildRoot
+userBuildRoot = BuildRoot "_build"
+
+-- | User-defined build flavours. See 'userFlavour' as an example.
+userFlavours :: [Flavour]
+userFlavours = [userFlavour] -- Add more build flavours if need be.
+
+-- | This is an example user-defined build flavour. Feel free to modify it and
+-- use by passing @--flavour=user@ from the command line.
+userFlavour :: Flavour
+userFlavour = defaultFlavour { name = "user" } -- Modify other settings here.
+
+-- | 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.
+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
+-- targets, e.g.: @verboseCommand = package ghcPrim@.
+verboseCommand :: Predicate
+verboseCommand = do
+ verbosity <- expr getVerbosity
+ return $ verbosity >= Loud
+
+-- | Set colour for build progress messages (e.g. executing a build command).
+buildProgressColour :: BuildProgressColour
+buildProgressColour = BuildProgressColour (Dull, Magenta)
+
+-- | Set colour for success messages (e.g. a package is built successfully).
+successColour :: SuccessColour
+successColour = SuccessColour (Dull, Green)
+
+-- TODO: Set this flag from the command line.
+-- | Set this flag to 'True' to disable building Stage2 GHC (i.e. the @ghc-stage2@
+-- executable) and Stage2 utilities (such as @haddock@). Note that all Stage0
+-- and Stage1 libraries (including 'compiler') will still be built. Enabling
+-- this flag during installation leads to installing @ghc-stage1@ instead of
+-- @ghc-stage2@, and @ghc-pkg@ that was build with the Stage0 compiler.
+-- Also see Note [No stage2 packages when CrossCompiling or Stage1Only] in the
+-- top-level @ghc.mk@.
+stage1Only :: Bool
+stage1Only = False
diff --git a/hadrian/src/Utilities.hs b/hadrian/src/Utilities.hs
new file mode 100644
index 0000000000..3c61daecfd
--- /dev/null
+++ b/hadrian/src/Utilities.hs
@@ -0,0 +1,80 @@
+module Utilities (
+ build, buildWithResources, buildWithCmdOptions, runBuilder, runBuilderWith,
+ needLibrary, contextDependencies, stage1Dependencies, libraryTargets,
+ topsortPackages
+ ) where
+
+import qualified Hadrian.Builder as H
+import Hadrian.Haskell.Cabal
+import Hadrian.Utilities
+
+import Context
+import Expression hiding (stage)
+import Oracles.PackageData
+import Settings
+import Target
+import UserSettings
+
+build :: Target -> Action ()
+build target = H.build target getArgs
+
+buildWithResources :: [(Resource, Int)] -> Target -> Action ()
+buildWithResources rs target = H.buildWithResources rs target getArgs
+
+buildWithCmdOptions :: [CmdOption] -> Target -> Action ()
+buildWithCmdOptions opts target = H.buildWithCmdOptions opts target getArgs
+
+-- | Given a 'Context' this 'Action' look up the package dependencies and wrap
+-- the results in appropriate contexts. The only subtlety here is that we never
+-- depend on packages built in 'Stage2' or later, therefore the stage of the
+-- resulting dependencies is bounded from above at 'Stage1'. To compute package
+-- dependencies we scan package @.cabal@ files, see 'pkgDependencies' defined
+-- in "Hadrian.Haskell.Cabal".
+contextDependencies :: Context -> Action [Context]
+contextDependencies Context {..} = case pkgCabalFile package of
+ Nothing -> return [] -- Non-Cabal packages have no dependencies.
+ Just cabalFile -> do
+ let depStage = min stage Stage1
+ depContext = \pkg -> Context depStage pkg way
+ deps <- pkgDependencies cabalFile
+ pkgs <- sort <$> stagePackages depStage
+ return . map depContext $ intersectOrd (compare . pkgName) pkgs deps
+
+-- | Lookup dependencies of a 'Package' in the vanilla Stage1 context.
+stage1Dependencies :: Package -> Action [Package]
+stage1Dependencies =
+ fmap (map Context.package) . contextDependencies . vanillaContext Stage1
+
+-- | Given a library 'Package' this action computes all of its targets. See
+-- 'packageTargets' for the explanation of the @includeGhciLib@ parameter.
+libraryTargets :: Bool -> Context -> Action [FilePath]
+libraryTargets includeGhciLib context = do
+ confFile <- pkgConfFile context
+ libFile <- pkgLibraryFile context
+ lib0File <- pkgLibraryFile0 context
+ lib0 <- buildDll0 context
+ ghciLib <- pkgGhciLibraryFile context
+ ghciFlag <- if includeGhciLib
+ then interpretInContext context $ getPkgData BuildGhciLib
+ else return "NO"
+ let ghci = ghciFlag == "YES" && (stage context == Stage1 || stage1Only)
+ return $ [ confFile, libFile ] ++ [ lib0File | lib0 ] ++ [ ghciLib | ghci ]
+
+-- | Coarse-grain 'need': make sure all given libraries are fully built.
+needLibrary :: [Context] -> Action ()
+needLibrary cs = need =<< concatMapM (libraryTargets True) cs
+
+-- HACK (izgzhen), see https://github.com/snowleopard/hadrian/issues/344.
+-- | Topological sort of packages according to their dependencies.
+topsortPackages :: [Package] -> Action [Package]
+topsortPackages pkgs = do
+ elems <- mapM (\p -> (p,) <$> stage1Dependencies p) pkgs
+ return $ map fst $ topSort elems
+ where
+ annotateInDeg es e =
+ (foldr (\e' s -> if fst e' `elem` snd e then s + 1 else s) (0 :: Int) es, e)
+ topSort [] = []
+ topSort es =
+ let annotated = map (annotateInDeg es) es
+ inDegZero = map snd $ filter ((== 0). fst) annotated
+ in inDegZero ++ topSort (es \\ inDegZero)
diff --git a/hadrian/src/Way.hs b/hadrian/src/Way.hs
new file mode 100644
index 0000000000..e904d93cbc
--- /dev/null
+++ b/hadrian/src/Way.hs
@@ -0,0 +1,162 @@
+module Way (
+ WayUnit (..), Way, wayUnit, removeWayUnit, wayFromUnits, allWays,
+
+ vanilla, profiling, dynamic, profilingDynamic, threaded, debug, logging,
+ threadedDebug, threadedProfiling, threadedLogging, threadedDynamic,
+ threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic,
+ threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic,
+
+ wayPrefix, waySuffix, hisuf, osuf, hcsuf, obootsuf, hibootsuf, ssuf
+ ) where
+
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as Set
+import Data.List
+import Data.Maybe
+import Development.Shake.Classes
+import Hadrian.Utilities
+
+-- Note: order of constructors is important for compatibility with the old build
+-- system, e.g. we want "thr_p", not "p_thr" (see instance Show Way).
+-- | A 'WayUnit' is a single way of building source code, for example with
+-- profiling enabled, or dynamically linked.
+data WayUnit = Threaded
+ | Debug
+ | Profiling
+ | Logging
+ | Dynamic
+ deriving (Bounded, Enum, Eq, Ord)
+
+-- TODO: get rid of non-derived Show instances
+instance Show WayUnit where
+ show unit = case unit of
+ Threaded -> "thr"
+ Debug -> "debug"
+ Profiling -> "p"
+ Logging -> "l"
+ Dynamic -> "dyn"
+
+instance Read WayUnit where
+ readsPrec _ s = [(unit, "") | unit <- [minBound ..], show unit == s]
+
+-- | Collection of 'WayUnit's that stands for the different ways source code
+-- is to be built.
+newtype Way = Way IntSet
+
+instance Binary Way where
+ put = put . show
+ get = fmap read get
+
+instance Hashable Way where
+ hashWithSalt salt = hashWithSalt salt . show
+
+instance NFData Way where
+ rnf (Way s) = s `seq` ()
+
+-- | Construct a 'Way' from multiple 'WayUnit's. Inverse of 'wayToUnits'.
+wayFromUnits :: [WayUnit] -> Way
+wayFromUnits = Way . Set.fromList . map fromEnum
+
+-- | Split a 'Way' into its 'WayUnit' building blocks.
+-- Inverse of 'wayFromUnits'.
+wayToUnits :: Way -> [WayUnit]
+wayToUnits (Way set) = map toEnum . Set.elems $ set
+
+-- | Check whether a 'Way' contains a certain 'WayUnit'.
+wayUnit :: WayUnit -> Way -> Bool
+wayUnit unit (Way set) = fromEnum unit `Set.member` set
+
+-- | Remove a 'WayUnit' from 'Way'.
+removeWayUnit :: WayUnit -> Way -> Way
+removeWayUnit unit (Way set) = Way . Set.delete (fromEnum unit) $ set
+
+instance Show Way where
+ show way = if null tag then "v" else tag
+ where
+ tag = intercalate "_" . map show . wayToUnits $ way
+
+instance Read Way where
+ readsPrec _ s = if s == "v" then [(vanilla, "")] else result
+ where
+ uniqueReads token = case reads token of
+ [(unit, "")] -> Just unit
+ _ -> Nothing
+ units = map uniqueReads . words . replaceEq '_' ' ' $ s
+ result = if Nothing `elem` units
+ then []
+ else [(wayFromUnits . map fromJust $ units, "")]
+
+instance Eq Way where
+ Way a == Way b = a == b
+
+instance Ord Way where
+ compare (Way a) (Way b) = compare a b
+
+-- | Build default _vanilla_ way.
+vanilla :: Way
+vanilla = wayFromUnits []
+
+-- | Build with profiling.
+profiling :: Way
+profiling = wayFromUnits [Profiling]
+
+-- | Build with dynamic linking.
+dynamic :: Way
+dynamic = wayFromUnits [Dynamic]
+
+-- | Build with profiling and dynamic linking.
+profilingDynamic :: Way
+profilingDynamic = wayFromUnits [Profiling, Dynamic]
+
+-- RTS only ways below. See compiler/main/DynFlags.hs.
+-- | Build RTS with event logging.
+logging :: Way
+logging = wayFromUnits [Logging]
+
+-- | Build multithreaded RTS.
+threaded :: Way
+threaded = wayFromUnits [Threaded]
+
+-- | Build RTS with debug information.
+debug :: Way
+debug = wayFromUnits [Debug]
+
+-- | Various combinations of RTS only ways.
+threadedDebug, threadedProfiling, threadedLogging, threadedDynamic,
+ threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic,
+ threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic :: Way
+threadedDebug = wayFromUnits [Threaded, Debug]
+threadedProfiling = wayFromUnits [Threaded, Profiling]
+threadedLogging = wayFromUnits [Threaded, Logging]
+threadedDynamic = wayFromUnits [Threaded, Dynamic]
+threadedDebugProfiling = wayFromUnits [Threaded, Debug, Profiling]
+threadedDebugDynamic = wayFromUnits [Threaded, Debug, Dynamic]
+threadedProfilingDynamic = wayFromUnits [Threaded, Profiling, Dynamic]
+threadedLoggingDynamic = wayFromUnits [Threaded, Logging, Dynamic]
+debugProfiling = wayFromUnits [Debug, Profiling]
+debugDynamic = wayFromUnits [Debug, Dynamic]
+loggingDynamic = wayFromUnits [Logging, Dynamic]
+
+-- | All ways supported by the build system.
+allWays :: [Way]
+allWays =
+ [ vanilla, profiling, dynamic, profilingDynamic, threaded, debug, logging
+ , threadedDebug, threadedProfiling, threadedLogging, threadedDynamic
+ , threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic
+ , threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic ]
+
+wayPrefix :: Way -> String
+wayPrefix way | way == vanilla = ""
+ | otherwise = show way ++ "_"
+
+waySuffix :: Way -> String
+waySuffix way | way == vanilla = ""
+ | otherwise = "_" ++ show way
+
+osuf, ssuf, hisuf, hcsuf, obootsuf, hibootsuf :: Way -> String
+osuf = (++ "o" ) . wayPrefix
+ssuf = (++ "s" ) . wayPrefix
+hisuf = (++ "hi" ) . wayPrefix
+hcsuf = (++ "hc" ) . wayPrefix
+obootsuf = (++ "o-boot" ) . wayPrefix
+hibootsuf = (++ "hi-boot") . wayPrefix