diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2017-12-08 12:42:35 -0500 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-12-08 13:22:41 -0500 |
| commit | 7733e44dd4ba7e7a0a9f3456e6ddc32decbcf5a3 (patch) | |
| tree | 79c5e7151d760e6c7617d8450fb9ec2a10560989 /hadrian/src | |
| parent | 5695f462f604fc63cbb45a7f3073bc114f9b475f (diff) | |
| download | haskell-7733e44dd4ba7e7a0a9f3456e6ddc32decbcf5a3.tar.gz | |
Rip out hadrian subtree
Sadly subtrees haven't worked quite as well as we would have liked for
developers. See Hadrian #440.
Diffstat (limited to 'hadrian/src')
89 files changed, 0 insertions, 7382 deletions
diff --git a/hadrian/src/Base.hs b/hadrian/src/Base.hs deleted file mode 100644 index 38c879234a..0000000000 --- a/hadrian/src/Base.hs +++ /dev/null @@ -1,121 +0,0 @@ -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 deleted file mode 100644 index 2b99c03992..0000000000 --- a/hadrian/src/Builder.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# 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 deleted file mode 100644 index 2344dcc99c..0000000000 --- a/hadrian/src/CommandLine.hs +++ /dev/null @@ -1,137 +0,0 @@ -module CommandLine ( - optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple, - cmdProgressColour, cmdProgressInfo, cmdConfigure, 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 - { configure :: Bool - , flavour :: Maybe String - , freeze1 :: Bool - , installDestDir :: Maybe String - , integerSimple :: Bool - , progressColour :: UseColour - , progressInfo :: ProgressInfo - , splitObjects :: Bool } - deriving (Eq, Show) - --- | Default values for 'CommandLineArgs'. -defaultCommandLineArgs :: CommandLineArgs -defaultCommandLineArgs = CommandLineArgs - { configure = False - , flavour = Nothing - , freeze1 = False - , installDestDir = Nothing - , integerSimple = False - , progressColour = Auto - , progressInfo = Brief - , splitObjects = False } - -readConfigure :: Either String (CommandLineArgs -> CommandLineArgs) -readConfigure = Right $ \flags -> flags { configure = True } - -readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) -readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms } - -readFreeze1 :: Either String (CommandLineArgs -> CommandLineArgs) -readFreeze1 = Right $ \flags -> flags { freeze1 = True } - -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 } - -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 ['c'] ["configure"] (NoArg readConfigure) - "Run the boot and configure scripts (if you do not want to run them manually)." - , 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 [] ["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 - -cmdConfigure :: Action Bool -cmdConfigure = configure <$> cmdLineArgs - -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 - -cmdSplitObjects :: Action Bool -cmdSplitObjects = splitObjects <$> cmdLineArgs diff --git a/hadrian/src/Context.hs b/hadrian/src/Context.hs deleted file mode 100644 index ad1a2d7295..0000000000 --- a/hadrian/src/Context.hs +++ /dev/null @@ -1,158 +0,0 @@ -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 deleted file mode 100644 index de43efa924..0000000000 --- a/hadrian/src/Environment.hs +++ /dev/null @@ -1,16 +0,0 @@ -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 deleted file mode 100644 index 7e8220e675..0000000000 --- a/hadrian/src/Expression.hs +++ /dev/null @@ -1,123 +0,0 @@ -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 deleted file mode 100644 index fcbbb70d45..0000000000 --- a/hadrian/src/Flavour.hs +++ /dev/null @@ -1,34 +0,0 @@ -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 deleted file mode 100644 index baae940959..0000000000 --- a/hadrian/src/GHC.hs +++ /dev/null @@ -1,289 +0,0 @@ -{-# 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 deleted file mode 100644 index 4de658edc3..0000000000 --- a/hadrian/src/Hadrian/Builder.hs +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index ad74653db0..0000000000 --- a/hadrian/src/Hadrian/Builder/Ar.hs +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index 44b522c4d3..0000000000 --- a/hadrian/src/Hadrian/Builder/Sphinx.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index d51e3c7bee..0000000000 --- a/hadrian/src/Hadrian/Builder/Tar.hs +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index e5c01f8935..0000000000 --- a/hadrian/src/Hadrian/Expression.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# 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 deleted file mode 100644 index ab5f334f9b..0000000000 --- a/hadrian/src/Hadrian/Haskell/Cabal.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index 578eeacc52..0000000000 --- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index bae2fdbd80..0000000000 --- a/hadrian/src/Hadrian/Oracles/ArgsHash.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# 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 deleted file mode 100644 index f302af9da0..0000000000 --- a/hadrian/src/Hadrian/Oracles/DirectoryContents.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# 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 deleted file mode 100644 index ceccc23db2..0000000000 --- a/hadrian/src/Hadrian/Oracles/Path.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# 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 deleted file mode 100644 index 6d4f048c7d..0000000000 --- a/hadrian/src/Hadrian/Oracles/TextFile.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# 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 deleted file mode 100644 index 11a6998f65..0000000000 --- a/hadrian/src/Hadrian/Package.hs +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index 88489776c0..0000000000 --- a/hadrian/src/Hadrian/Target.hs +++ /dev/null @@ -1,29 +0,0 @@ -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 deleted file mode 100644 index 1cd22b1179..0000000000 --- a/hadrian/src/Hadrian/Utilities.hs +++ /dev/null @@ -1,406 +0,0 @@ -{-# 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 deleted file mode 100644 index 52af0adf7c..0000000000 --- a/hadrian/src/Main.hs +++ /dev/null @@ -1,59 +0,0 @@ -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 deleted file mode 100644 index 1bd4dfeefd..0000000000 --- a/hadrian/src/Oracles/Flag.hs +++ /dev/null @@ -1,74 +0,0 @@ -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 - | 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" - 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 deleted file mode 100644 index c7175dbc1c..0000000000 --- a/hadrian/src/Oracles/ModuleFiles.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# 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 deleted file mode 100644 index cdfe9bfb48..0000000000 --- a/hadrian/src/Oracles/PackageData.hs +++ /dev/null @@ -1,66 +0,0 @@ -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 deleted file mode 100644 index aa49011e1e..0000000000 --- a/hadrian/src/Oracles/Setting.hs +++ /dev/null @@ -1,236 +0,0 @@ -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 deleted file mode 100644 index d5c26e8e94..0000000000 --- a/hadrian/src/Rules.hs +++ /dev/null @@ -1,123 +0,0 @@ -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 deleted file mode 100644 index d11cbf5e53..0000000000 --- a/hadrian/src/Rules/Clean.hs +++ /dev/null @@ -1,23 +0,0 @@ -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 deleted file mode 100644 index b7f3bc8447..0000000000 --- a/hadrian/src/Rules/Compile.hs +++ /dev/null @@ -1,81 +0,0 @@ -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 - 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 deleted file mode 100644 index 9de31e2bbc..0000000000 --- a/hadrian/src/Rules/Configure.hs +++ /dev/null @@ -1,43 +0,0 @@ -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 <- not <$> cmdConfigure - if skip - then unlessM (doesFileExist configFile) $ - error $ "Configuration file " ++ configFile ++ " is missing.\n" - ++ "Run the configure script manually or let Hadrian run it " - ++ "automatically by passing the flag --configure." - 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 <- not <$> cmdConfigure - if skip - then unlessM (doesFileExist "configure") $ - error $ "The configure script is missing.\nRun the boot script " - ++ "manually let Hadrian run it automatically by passing the " - ++ "flag --configure." - 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 deleted file mode 100644 index f9d17e93d8..0000000000 --- a/hadrian/src/Rules/Dependencies.hs +++ /dev/null @@ -1,33 +0,0 @@ -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 writeFile' mk "" - else buildWithResources rs $ - target context (Ghc FindHsDependencies stage) srcs [mk] - removeFile $ mk <.> "bak" - mkDeps <- liftIO $ 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 deleted file mode 100644 index 5a5698c995..0000000000 --- a/hadrian/src/Rules/Documentation.hs +++ /dev/null @@ -1,197 +0,0 @@ -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 deleted file mode 100644 index 8e2b65d183..0000000000 --- a/hadrian/src/Rules/Generate.hs +++ /dev/null @@ -1,482 +0,0 @@ -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 deleted file mode 100644 index 46fad8a32c..0000000000 --- a/hadrian/src/Rules/Gmp.hs +++ /dev/null @@ -1,119 +0,0 @@ -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 deleted file mode 100644 index bcdbf33e34..0000000000 --- a/hadrian/src/Rules/Install.hs +++ /dev/null @@ -1,336 +0,0 @@ -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 deleted file mode 100644 index 73f481d88a..0000000000 --- a/hadrian/src/Rules/Libffi.hs +++ /dev/null @@ -1,108 +0,0 @@ -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 deleted file mode 100644 index e6e5b167ff..0000000000 --- a/hadrian/src/Rules/Library.hs +++ /dev/null @@ -1,103 +0,0 @@ -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 deleted file mode 100644 index 2442b03de3..0000000000 --- a/hadrian/src/Rules/PackageData.hs +++ /dev/null @@ -1,119 +0,0 @@ -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 deleted file mode 100644 index dca177f879..0000000000 --- a/hadrian/src/Rules/Program.hs +++ /dev/null @@ -1,113 +0,0 @@ -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 ++ ")." - -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 - 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 deleted file mode 100644 index 7c0a3e00e8..0000000000 --- a/hadrian/src/Rules/Register.hs +++ /dev/null @@ -1,44 +0,0 @@ -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 deleted file mode 100644 index d1ffaac1c3..0000000000 --- a/hadrian/src/Rules/Selftest.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# 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 deleted file mode 100644 index 3143c4b153..0000000000 --- a/hadrian/src/Rules/SourceDist.hs +++ /dev/null @@ -1,113 +0,0 @@ -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 deleted file mode 100644 index ae37343432..0000000000 --- a/hadrian/src/Rules/Test.hs +++ /dev/null @@ -1,72 +0,0 @@ -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 deleted file mode 100644 index 20763a778e..0000000000 --- a/hadrian/src/Rules/Wrappers.hs +++ /dev/null @@ -1,162 +0,0 @@ -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 deleted file mode 100644 index 091efc10ca..0000000000 --- a/hadrian/src/Settings.hs +++ /dev/null @@ -1,68 +0,0 @@ -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 deleted file mode 100644 index e0ef1367f7..0000000000 --- a/hadrian/src/Settings/Builders/Alex.hs +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 index 70d043f76d..0000000000 --- a/hadrian/src/Settings/Builders/Cc.hs +++ /dev/null @@ -1,26 +0,0 @@ -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 deleted file mode 100644 index 340239acd6..0000000000 --- a/hadrian/src/Settings/Builders/Common.hs +++ /dev/null @@ -1,58 +0,0 @@ -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 = - mconcat [ arg "-Wall" - , flag GccIsClang ? arg "-Wno-unknown-pragmas" - , notM (flag GccIsClang) ? notM windowsHost ? arg "-Werror=unused-but-set-variable" - , notM (flag GccIsClang) ? 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 deleted file mode 100644 index 93225b5405..0000000000 --- a/hadrian/src/Settings/Builders/Configure.hs +++ /dev/null @@ -1,25 +0,0 @@ -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 deleted file mode 100644 index 7a6e863e9c..0000000000 --- a/hadrian/src/Settings/Builders/DeriveConstants.hs +++ /dev/null @@ -1,39 +0,0 @@ -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 deleted file mode 100644 index e616ed3b43..0000000000 --- a/hadrian/src/Settings/Builders/GenPrimopCode.hs +++ /dev/null @@ -1,24 +0,0 @@ -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 deleted file mode 100644 index af78b74637..0000000000 --- a/hadrian/src/Settings/Builders/Ghc.hs +++ /dev/null @@ -1,149 +0,0 @@ -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 (pkg == rts) $ 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 deleted file mode 100644 index bfb84a76ec..0000000000 --- a/hadrian/src/Settings/Builders/GhcCabal.hs +++ /dev/null @@ -1,118 +0,0 @@ -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 deleted file mode 100644 index ba705c6892..0000000000 --- a/hadrian/src/Settings/Builders/GhcPkg.hs +++ /dev/null @@ -1,17 +0,0 @@ -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 deleted file mode 100644 index b3810476ad..0000000000 --- a/hadrian/src/Settings/Builders/Haddock.hs +++ /dev/null @@ -1,63 +0,0 @@ -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 deleted file mode 100644 index 5ffb2614cc..0000000000 --- a/hadrian/src/Settings/Builders/Happy.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 index aeb5255990..0000000000 --- a/hadrian/src/Settings/Builders/HsCpp.hs +++ /dev/null @@ -1,16 +0,0 @@ -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 deleted file mode 100644 index 6185f6bec3..0000000000 --- a/hadrian/src/Settings/Builders/Hsc2Hs.hs +++ /dev/null @@ -1,56 +0,0 @@ -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 deleted file mode 100644 index 2715bbb20c..0000000000 --- a/hadrian/src/Settings/Builders/Ld.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 index cc350df508..0000000000 --- a/hadrian/src/Settings/Builders/Make.hs +++ /dev/null @@ -1,16 +0,0 @@ -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 deleted file mode 100644 index 5623284ed5..0000000000 --- a/hadrian/src/Settings/Builders/Xelatex.hs +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 index dc58f22160..0000000000 --- a/hadrian/src/Settings/Default.hs +++ /dev/null @@ -1,173 +0,0 @@ -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 deleted file mode 100644 index 468c5cae3e..0000000000 --- a/hadrian/src/Settings/Default.hs-boot +++ /dev/null @@ -1,20 +0,0 @@ -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 deleted file mode 100644 index 5919026cb0..0000000000 --- a/hadrian/src/Settings/Flavours/Development.hs +++ /dev/null @@ -1,20 +0,0 @@ -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 deleted file mode 100644 index 64ab4bce9d..0000000000 --- a/hadrian/src/Settings/Flavours/Performance.hs +++ /dev/null @@ -1,18 +0,0 @@ -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 deleted file mode 100644 index d56cc10055..0000000000 --- a/hadrian/src/Settings/Flavours/Profiled.hs +++ /dev/null @@ -1,19 +0,0 @@ -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 deleted file mode 100644 index 99dade9bf1..0000000000 --- a/hadrian/src/Settings/Flavours/Quick.hs +++ /dev/null @@ -1,22 +0,0 @@ -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 deleted file mode 100644 index 3d0c410bea..0000000000 --- a/hadrian/src/Settings/Flavours/QuickCross.hs +++ /dev/null @@ -1,24 +0,0 @@ -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 deleted file mode 100644 index a9dfb7087f..0000000000 --- a/hadrian/src/Settings/Flavours/Quickest.hs +++ /dev/null @@ -1,23 +0,0 @@ -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 deleted file mode 100644 index 2e0ced4c26..0000000000 --- a/hadrian/src/Settings/Packages/Base.hs +++ /dev/null @@ -1,12 +0,0 @@ -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 deleted file mode 100644 index c01be4b3ed..0000000000 --- a/hadrian/src/Settings/Packages/Cabal.hs +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 index 6b329d7b4f..0000000000 --- a/hadrian/src/Settings/Packages/Compiler.hs +++ /dev/null @@ -1,45 +0,0 @@ -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 deleted file mode 100644 index d7b1d78ddd..0000000000 --- a/hadrian/src/Settings/Packages/Ghc.hs +++ /dev/null @@ -1,13 +0,0 @@ -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 deleted file mode 100644 index c88617b97f..0000000000 --- a/hadrian/src/Settings/Packages/GhcCabal.hs +++ /dev/null @@ -1,32 +0,0 @@ -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 - let bootDeps = cabalDeps \\ [integerGmp, integerSimple, mtl, parsec, text] - cabalVersion <- expr $ pkgVersion (unsafePkgCabalFile cabal) -- TODO: improve - mconcat - [ pure [ "-package " ++ pkgName pkg | pkg <- bootDeps ] - , arg "--make" - , arg "-j" - , pure ["-Wall", "-fno-warn-unused-imports", "-fno-warn-warnings-deprecations"] - , arg ("-DCABAL_VERSION=" ++ replace "." "," cabalVersion) - , arg "-DCABAL_PARSEC" - , arg "-DBOOTSTRAPPING" - , arg "-DMIN_VERSION_binary_0_8_0" - , arg "libraries/text/cbits/cbits.c" - , arg "-ilibraries/Cabal/Cabal" - , arg "-ilibraries/binary/src" - , arg "-ilibraries/filepath" - , arg "-ilibraries/hpc" - , arg "-ilibraries/mtl" - , arg "-ilibraries/text" - , arg "-Ilibraries/text/include" - , arg "-ilibraries/parsec" ] - diff --git a/hadrian/src/Settings/Packages/GhcPkg.hs b/hadrian/src/Settings/Packages/GhcPkg.hs deleted file mode 100644 index a13a9dab7e..0000000000 --- a/hadrian/src/Settings/Packages/GhcPkg.hs +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 index aed8f2ff73..0000000000 --- a/hadrian/src/Settings/Packages/GhcPrim.hs +++ /dev/null @@ -1,12 +0,0 @@ -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 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 deleted file mode 100644 index 47e7d38deb..0000000000 --- a/hadrian/src/Settings/Packages/Ghci.hs +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index c8d667ecb4..0000000000 --- a/hadrian/src/Settings/Packages/Haddock.hs +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 index 254c6b704c..0000000000 --- a/hadrian/src/Settings/Packages/Haskeline.hs +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 index 7c2b5f635b..0000000000 --- a/hadrian/src/Settings/Packages/IntegerGmp.hs +++ /dev/null @@ -1,24 +0,0 @@ -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 deleted file mode 100644 index cdc89dae56..0000000000 --- a/hadrian/src/Settings/Packages/Rts.hs +++ /dev/null @@ -1,224 +0,0 @@ -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" - , windowsHost ? arg ("-DWINVER=" ++ windowsVersion) - - -- libffi's ffi.h triggers various warnings - , inputs [ "//Interpreter.c", "//Storage.c", "//Adjustor.c" ] ? - arg "-Wno-strict-prototypes" - , inputs ["//Interpreter.c", "//Adjustor.c", "//sm/Storage.c"] ? - anyTargetArch ["powerpc"] ? arg "-Wno-undef" - ] - - 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"] - , 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" - , arg "-Wundef" - , arg "-fno-strict-aliasing" ] diff --git a/hadrian/src/Settings/Packages/RunGhc.hs b/hadrian/src/Settings/Packages/RunGhc.hs deleted file mode 100644 index 03a19c8373..0000000000 --- a/hadrian/src/Settings/Packages/RunGhc.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 index abbc814291..0000000000 --- a/hadrian/src/Settings/Warnings.hs +++ /dev/null @@ -1,56 +0,0 @@ -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 <$> windowsHost ) ? arg "-optc-Werror=unused-but-set-variable" - , 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 deleted file mode 100644 index 7c9405c2b8..0000000000 --- a/hadrian/src/Stage.hs +++ /dev/null @@ -1,31 +0,0 @@ -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 deleted file mode 100644 index 30c8d98d14..0000000000 --- a/hadrian/src/Target.hs +++ /dev/null @@ -1,26 +0,0 @@ -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 deleted file mode 100644 index 1b7c3f8bdd..0000000000 --- a/hadrian/src/UserSettings.hs +++ /dev/null @@ -1,64 +0,0 @@ --- 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 deleted file mode 100644 index fc898c35b9..0000000000 --- a/hadrian/src/Utilities.hs +++ /dev/null @@ -1,88 +0,0 @@ -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 - --- TODO: Cache the computation. --- | Given a 'Context' this 'Action' looks up the package dependencies and wraps --- 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 transitively scan @.cabal@ files using 'pkgDependencies' --- defined in "Hadrian.Haskell.Cabal". -contextDependencies :: Context -> Action [Context] -contextDependencies Context {..} = do - depPkgs <- go [package] - return [ Context depStage pkg way | pkg <- depPkgs, pkg /= package ] - where - depStage = min stage Stage1 - go pkgs = do - deps <- concatMapM step pkgs - let newPkgs = nubOrd $ sort (deps ++ pkgs) - if pkgs == newPkgs then return pkgs else go newPkgs - step pkg = case pkgCabalFile pkg of - Nothing -> return [] -- Non-Cabal packages have no dependencies. - Just cabalFile -> do - deps <- pkgDependencies cabalFile - active <- sort <$> stagePackages depStage - return $ intersectOrd (compare . pkgName) active 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 deleted file mode 100644 index e904d93cbc..0000000000 --- a/hadrian/src/Way.hs +++ /dev/null @@ -1,162 +0,0 @@ -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 |