Commit 8ee46b1a authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Refactor builder path manipulation

parent c93cf69f
......@@ -35,7 +35,7 @@ executable hadrian
, Oracles.LookupInPath
, Oracles.ModuleFiles
, Oracles.PackageData
, Oracles.WindowsPath
, Oracles.Path
, Package
, Predicate
, Rules
......
{-# LANGUAGE DeriveGeneric, LambdaCase #-}
module Builder (
CcMode (..), GhcMode (..), Builder (..), builderPath, getBuilderPath,
builderEnvironment, specified, trackedArgument, needBuilder
CcMode (..), GhcMode (..), Builder (..), trackedArgument, isOptional
) where
import Control.Monad.Trans.Reader
import Data.Char
import GHC.Generics
import Base
import Context
import GHC
import Oracles.Config
import Oracles.LookupInPath
import Oracles.WindowsPath
import Stage
-- | A compiler can typically be used in different modes:
......@@ -58,30 +51,6 @@ data Builder = Alex
| Unlit
deriving (Eq, Generic, Show)
-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
-- 'Stage' and GHC 'Package').
builderProvenance :: Builder -> Maybe Context
builderProvenance = \case
DeriveConstants -> context Stage0 deriveConstants
GenApply -> context Stage0 genapply
GenPrimopCode -> context Stage0 genprimopcode
Ghc _ Stage0 -> Nothing
Ghc _ stage -> context (pred stage) ghc
GhcCabal -> context Stage0 ghcCabal
GhcCabalHsColour -> builderProvenance $ GhcCabal
GhcPkg stage -> if stage > Stage0 then context Stage0 ghcPkg else Nothing
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
isInternal :: Builder -> Bool
isInternal = isJust . builderProvenance
-- TODO: Some builders are required only on certain platforms. For example,
-- Objdump is only required on OpenBSD and AIX, as mentioned in #211. Add
-- support for platform-specific optional builders as soon as we can reliably
......@@ -92,57 +61,6 @@ isOptional = \case
Objdump -> True
_ -> False
-- | Determine the location of a 'Builder'.
builderPath :: Builder -> Action FilePath
builderPath builder = case programPath =<< builderProvenance builder of
Just path -> return path
Nothing -> case builder of
Alex -> fromKey "alex"
Ar -> fromKey "ar"
Cc _ Stage0 -> fromKey "system-cc"
Cc _ _ -> fromKey "cc"
-- We can't ask configure for the path to configure!
Configure _ -> return "bash configure"
Ghc _ Stage0 -> fromKey "system-ghc"
GhcPkg Stage0 -> fromKey "system-ghc-pkg"
Happy -> fromKey "happy"
HsColour -> fromKey "hscolour"
HsCpp -> fromKey "hs-cpp"
Ld -> fromKey "ld"
Make _ -> fromKey "make"
Nm -> fromKey "nm"
Objdump -> fromKey "objdump"
Patch -> fromKey "patch"
Perl -> fromKey "perl"
Ranlib -> fromKey "ranlib"
Tar -> fromKey "tar"
_ -> error $ "Cannot determine builderPath for " ++ show builder
where
fromKey key = do
let unpack = fromMaybe . error $ "Cannot find path to builder "
++ quote key ++ " in system.config file. Did you skip configure?"
path <- unpack <$> askConfig key
if null path
then do
unless (isOptional builder) . error $ "Non optional builder "
++ quote key ++ " is not specified in system.config file."
return "" -- TODO: Use a safe interface.
else fixAbsolutePathOnWindows =<< lookupInPath path
getBuilderPath :: Builder -> ReaderT a Action FilePath
getBuilderPath = lift . builderPath
-- | Write a Builder's path into a given environment variable.
builderEnvironment :: String -> Builder -> Action CmdOption
builderEnvironment variable builder = do
needBuilder builder
path <- builderPath builder
return $ AddEnv variable path
-- | Was the path to a given 'Builder' specified in configuration files?
specified :: Builder -> Action Bool
specified = fmap (not . null) . builderPath
-- | 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 'Builder' and an argument, this function should return
......@@ -154,14 +72,6 @@ trackedArgument _ = const True
threadArg :: String -> Bool
threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="]
-- | Make sure a Builder exists on the given path and rebuild it if out of date.
needBuilder :: Builder -> Action ()
needBuilder = \case
Configure dir -> need [dir -/- "configure"]
builder -> when (isInternal builder) $ do
path <- builderPath builder
need [path]
instance Binary Builder
instance Hashable Builder
instance NFData Builder
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings, LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module GHC (
array, base, binary, bytestring, cabal, checkApiAnnotations, compiler,
......@@ -9,10 +9,10 @@ module GHC (
parallel, pretty, primitive, process, rts, runGhc, stm, templateHaskell,
terminfo, time, touchy, transformers, unlit, unix, win32, xhtml,
defaultKnownPackages, stageDirectory, programPath
defaultKnownPackages, builderProvenance
) where
import Base
import Builder
import Context
import Package
import Stage
......@@ -91,46 +91,23 @@ xhtml = library "xhtml"
ghcSplit :: FilePath
ghcSplit = "inplace/lib/bin/ghc-split"
-- | Relative path to the directory containing build artefacts of a given 'Stage'.
stageDirectory :: Stage -> FilePath
stageDirectory = stageString
-- TODO: Create a separate rule for copying executables to inplace/bin
-- TODO: move to buildRootPath, see #113
-- | The 'FilePath' to a program executable in a given 'Context'.
programPath :: Context -> Maybe FilePath
programPath Context {..} = lookup (stage, package) exes
-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
-- 'Stage' and GHC 'Package').
builderProvenance :: Builder -> Maybe Context
builderProvenance = \case
DeriveConstants -> context Stage0 deriveConstants
GenApply -> context Stage0 genapply
GenPrimopCode -> context Stage0 genprimopcode
Ghc _ Stage0 -> Nothing
Ghc _ stage -> context (pred stage) ghc
GhcCabal -> context Stage0 ghcCabal
GhcCabalHsColour -> builderProvenance $ GhcCabal
GhcPkg stage -> if stage > Stage0 then context Stage0 ghcPkg else Nothing
Haddock -> context Stage2 haddock
Hpc -> context Stage1 hpcBin
Hsc2Hs -> context Stage0 hsc2hs
Unlit -> context Stage0 unlit
_ -> Nothing
where
exes = [ inplace2 checkApiAnnotations
, install1 compareSizes
, inplace0 deriveConstants
, inplace0 dllSplit
, inplace0 genapply
, inplace0 genprimopcode
, inplace0 ghc `setFile` "ghc-stage1"
, inplace1 ghc `setFile` "ghc-stage2"
, install0 ghcCabal
, inplace1 ghcCabal
, inplace0 ghcPkg
, install1 ghcPkg
, inplace2 ghcTags
, inplace2 haddock
, inplace0 hp2ps
, inplace1 hpcBin `setFile` "hpc"
, inplace0 hsc2hs
, install1 hsc2hs
, install1 iservBin
, inplace0 mkUserGuidePart
, inplace1 runGhc `setFile` "runhaskell"
, inplace0 touchy `setDir` "inplace/lib/bin"
, inplace0 unlit `setDir` "inplace/lib/bin" ]
inplace pkg = programInplacePath -/- pkgNameString pkg <.> exe
inplace0 pkg = ((Stage0, pkg), inplace pkg)
inplace1 pkg = ((Stage1, pkg), inplace pkg)
inplace2 pkg = ((Stage2, pkg), inplace pkg)
install stage pkg = pkgPath package -/- stageDirectory stage -/- "build/tmp"
-/- pkgNameString pkg <.> exe
install0 pkg = ((Stage0, pkg), install Stage0 pkg)
install1 pkg = ((Stage1, pkg), install Stage1 pkg)
setFile ((stage, pkg), x) y = ((stage, pkg), takeDirectory x -/- y <.> exe)
setDir ((stage, pkg), x) y = ((stage, pkg), y -/- takeFileName x)
context s p = Just $ vanillaContext s p
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Oracles.WindowsPath (
fixAbsolutePathOnWindows, topDirectory, getTopDirectory, windowsPathOracle
) where
-- TODO: Rename to Oracles.Path.
import Control.Monad.Trans.Reader
import Data.Char
import Base
import Oracles.Config.Setting
newtype WindowsPath = WindowsPath FilePath
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
-- | Path to the GHC source tree.
topDirectory :: Action FilePath
topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
getTopDirectory :: ReaderT a Action FilePath
getTopDirectory = lift topDirectory
-- | Fix an absolute path on Windows:
-- * "/c/" => "C:/"
-- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
fixAbsolutePathOnWindows :: FilePath -> Action FilePath
fixAbsolutePathOnWindows path = do
windows <- windowsHost
if windows
then do
let (dir, file) = splitFileName path
winDir <- askOracle $ WindowsPath dir
return $ winDir -/- file
else
return path
-- | Compute path mapping on Windows. This is slow and requires caching.
windowsPathOracle :: Rules ()
windowsPathOracle = 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
......@@ -2,7 +2,8 @@ module Rules.Actions (
build, buildWithCmdOptions, buildWithResources, copyFile, fixFile, moveFile,
removeFile, copyDirectory, copyDirectoryContent, createDirectory,
moveDirectory, removeDirectory, applyPatch, runBuilder, runBuilderWith,
makeExecutable, renderProgram, renderLibrary, Match(..)
makeExecutable, renderProgram, renderLibrary, Match(..), builderEnvironment,
needBuilder
) where
import qualified System.Directory.Extra as IO
......@@ -13,11 +14,13 @@ import Base
import CmdLineFlag
import Context
import Expression
import GHC
import Oracles.ArgsHash
import Oracles.DirectoryContent
import Oracles.WindowsPath
import Oracles.Path
import Settings
import Settings.Builders.Ar
import Settings.Paths
import Target
import UserSettings
......@@ -164,6 +167,23 @@ applyPatch dir patch = do
putBuild $ "| Apply patch " ++ file
quietly $ cmd Shell cmdEcho [Cwd dir] [path, "-p0 <", patch]
isInternal :: Builder -> Bool
isInternal = isJust . builderProvenance
-- | Make sure a 'Builder' exists and rebuild it if out of date.
needBuilder :: Builder -> Action ()
needBuilder (Configure dir) = need [dir -/- "configure"]
needBuilder builder = when (isInternal builder) $ do
path <- builderPath builder
need [path]
-- | Write a Builder's path into a given environment variable.
builderEnvironment :: String -> Builder -> Action CmdOption
builderEnvironment variable builder = do
needBuilder builder
path <- builderPath builder
return $ AddEnv variable path
runBuilder :: Builder -> [String] -> Action ()
runBuilder = runBuilderWith []
......
......@@ -33,7 +33,7 @@ buildPackageDocumentation context@Context {..} =
-- HsColour sources
-- TODO: what is the output of GhcCabalHsColour?
whenM (specified HsColour) $ do
whenM (isSpecified HsColour) $ do
pkgConf <- pkgConfFile context
need [ cabalFile, pkgConf ] -- TODO: check if need pkgConf
build $ Target context GhcCabalHsColour [cabalFile] []
......
......@@ -8,6 +8,7 @@ import Oracles.Config.Flag
import Oracles.Config.Setting
import Rules.Generators.Common
import Settings
import Settings.Paths
import UserSettings
generateConfigHs :: Expr String
......
......@@ -4,6 +4,7 @@ import Base
import Expression
import Oracles.Config.Setting
import Rules.Generators.Common
import Settings.Paths
ghcSplitSource :: FilePath
ghcSplitSource = "driver/split/ghc-split.prl"
......
......@@ -8,7 +8,7 @@ import qualified Oracles.DirectoryContent
import qualified Oracles.LookupInPath
import qualified Oracles.ModuleFiles
import qualified Oracles.PackageData
import qualified Oracles.WindowsPath
import qualified Oracles.Path
oracleRules :: Rules ()
oracleRules = do
......@@ -19,4 +19,4 @@ oracleRules = do
Oracles.LookupInPath.lookupInPathOracle
Oracles.ModuleFiles.moduleFilesOracle
Oracles.PackageData.packageDataOracle
Oracles.WindowsPath.windowsPathOracle
Oracles.Path.windowsPathOracle
......@@ -18,11 +18,6 @@ import Settings.Paths
import Target
import UserSettings
-- TODO: Move to buildRootPath, see #113.
-- | Directory for wrapped binaries.
programInplaceLibPath :: FilePath
programInplaceLibPath = "inplace/lib/bin"
-- | Wrapper is an expression depending on the 'FilePath' to the wrapped binary.
type Wrapper = FilePath -> Expr String
......
......@@ -7,9 +7,10 @@ import Flavour
import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Oracles.WindowsPath
import Oracles.Path
import Rules.Actions
import Settings
import Settings.Paths
import Target
-- TODO: clean up after testing
......
......@@ -2,7 +2,7 @@ module Rules.Wrappers.Ghc (ghcWrapper) where
import Base
import Expression
import Oracles.WindowsPath
import Oracles.Path
ghcWrapper :: FilePath -> Expr String
ghcWrapper program = do
......
......@@ -2,7 +2,7 @@ module Rules.Wrappers.GhcPkg (ghcPkgWrapper) where
import Base
import Expression
import Oracles.WindowsPath
import Oracles.Path
import Settings.Paths
ghcPkgWrapper :: FilePath -> Expr String
......
......@@ -5,7 +5,7 @@ module Settings.Builders.Common (
module Oracles.Config.Flag,
module Oracles.Config.Setting,
module Oracles.PackageData,
module Oracles.WindowsPath,
module Oracles.Path,
module Predicate,
module Settings,
module Settings.Paths,
......@@ -20,7 +20,7 @@ import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Oracles.PackageData
import Oracles.WindowsPath
import Oracles.Path
import Predicate
import Settings
import Settings.Paths
......
......@@ -18,8 +18,8 @@ deriveConstantsBuilderArgs = builder DeriveConstants ? do
, arg "--gcc-program", arg =<< getBuilderPath (Cc CompileC Stage1)
, append $ concatMap (\a -> ["--gcc-flag", a]) cFlags
, arg "--nm-program", arg =<< getBuilderPath Nm
, specified Objdump ? mconcat [ arg "--objdump-program"
, arg =<< getBuilderPath Objdump ]
, isSpecified Objdump ? mconcat [ arg "--objdump-program"
, arg =<< getBuilderPath Objdump ]
, arg "--target-os", argSetting TargetOs ]
includeCcArgs :: Args
......
......@@ -4,6 +4,7 @@ module Settings.Builders.GhcCabal (
import Context
import Flavour
import Rules.Actions
import Settings.Builders.Common
ghcCabalBuilderArgs :: Args
......@@ -98,7 +99,7 @@ withBuilderKey b = case b of
-- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
with :: Builder -> Args
with b = specified b ? do
with b = isSpecified b ? do
top <- getTopDirectory
path <- getBuilderPath b
lift $ needBuilder b
......
......@@ -39,10 +39,9 @@ haddockBuilderArgs = builder Haddock ? do
, Just depPkg <- [findKnownPackage $ PackageName depName]
, depPkg /= rts ]
, append [ "--optghc=" ++ opt | opt <- ghcOpts ]
, specified HsColour ?
arg "--source-module=src/%{MODULE/./-}.html"
, specified HsColour ?
arg "--source-entity=src/%{MODULE/./-}.html\\#%{NAME}"
, isSpecified HsColour ?
append [ "--source-module=src/%{MODULE/./-}.html"
, "--source-entity=src/%{MODULE/./-}.html\\#%{NAME}" ]
, append =<< getInputs
, arg "+RTS"
, arg $ "-t" ++ path -/- "haddock.t"
......
......@@ -6,7 +6,7 @@ import Base
import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Oracles.WindowsPath
import Oracles.Path
import Predicate
import Settings
import Settings.Paths
......
......@@ -3,7 +3,8 @@ module Settings.Paths (
pkgLibraryFile0, pkgGhciLibraryFile, gmpBuildPath, gmpObjects, gmpLibraryH,
gmpBuildInfoPath, generatedPath, libffiBuildPath, shakeFilesPath, pkgConfFile,
packageDbDirectory, packageDbStamp, bootPackageConstraints, packageDependencies,
objectPath
objectPath, builderPath, getBuilderPath, isSpecified, programPath,
programInplaceLibPath
) where
import Base
......@@ -11,6 +12,7 @@ import Context
import Expression
import GHC
import Oracles.PackageData
import Oracles.Path
import UserSettings
-- | Path to the directory containing the Shake database and other auxiliary
......@@ -31,6 +33,15 @@ packageDependencies = shakeFilesPath -/- "package-dependencies"
generatedPath :: FilePath
generatedPath = buildRootPath -/- "generated"
-- | Relative path to the directory containing build artefacts of a given 'Stage'.
stageDirectory :: Stage -> FilePath
stageDirectory = stageString
-- TODO: Move to buildRootPath, see #113.
-- | Directory for wrapped binaries.
programInplaceLibPath :: FilePath
programInplaceLibPath = "inplace/lib/bin"
-- | Path to the directory containing build artefacts of a given 'Context'.
buildPath :: Context -> FilePath
buildPath Context {..} = buildRootPath -/- stageDirectory stage -/- pkgPath package
......@@ -127,3 +138,54 @@ objectPath context@Context {..} src
where
extension = drop 1 $ takeExtension src
obj = src -<.> osuf way
-- | Determine the location of a 'Builder'.
builderPath :: Builder -> Action FilePath
builderPath builder = case programPath =<< builderProvenance builder of
Just path -> return path
Nothing -> systemBuilderPath builder
getBuilderPath :: Builder -> ReaderT a Action FilePath
getBuilderPath = lift . builderPath
-- | Was the path to a given 'Builder' specified in configuration files?
isSpecified :: Builder -> Action Bool
isSpecified = fmap (not . null) . builderPath
-- | The 'FilePath' to a program executable in a given 'Context'.
programPath :: Context -> Maybe FilePath
programPath Context {..} = lookup (stage, package) exes
where
exes = [ inplace2 checkApiAnnotations
, install1 compareSizes
, inplace0 deriveConstants
, inplace0 dllSplit
, inplace0 genapply
, inplace0 genprimopcode
, inplace0 ghc `setFile` "ghc-stage1"
, inplace1 ghc `setFile` "ghc-stage2"
, install0 ghcCabal
, inplace1 ghcCabal
, inplace0 ghcPkg
, install1 ghcPkg
, inplace2 ghcTags
, inplace2 haddock
, inplace0 hp2ps
, inplace1 hpcBin `setFile` "hpc"
, inplace0 hsc2hs
, install1 hsc2hs
, install1 iservBin
, inplace0 mkUserGuidePart
, inplace1 runGhc `setFile` "runhaskell"
, inplace0 touchy `setDir` programInplaceLibPath
, inplace0 unlit `setDir` programInplaceLibPath ]
inplace pkg = programInplacePath -/- pkgNameString pkg <.> exe
inplace0 pkg = ((Stage0, pkg), inplace pkg)
inplace1 pkg = ((Stage1, pkg), inplace pkg)
inplace2 pkg = ((Stage2, pkg), inplace pkg)
install stage pkg = pkgPath package -/- stageDirectory stage -/- "build/tmp"
-/- pkgNameString pkg <.> exe
install0 pkg = ((Stage0, pkg), install Stage0 pkg)
install1 pkg = ((Stage1, pkg), install Stage1 pkg)
setFile ((stage, pkg), x) y = ((stage, pkg), takeDirectory x -/- y <.> exe)
setDir ((stage, pkg), x) y = ((stage, pkg), y -/- takeFileName x)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment