Commit 897ba61d authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add CompilerMode to Cc and Ghc builders.

See #223.
parent 96dec149
{-# LANGUAGE DeriveGeneric, LambdaCase #-}
module Builder (
Builder (..), isStaged, builderPath, getBuilderPath, specified, needBuilder
CompilerMode (..), Builder (..),
isStaged, builderPath, getBuilderPath, specified, needBuilder
) where
import Control.Monad.Trans.Reader
......@@ -14,27 +15,28 @@ import Oracles.LookupInPath
import Oracles.WindowsPath
import Stage
-- TODO: Add Link mode?
-- | A C or Haskell compiler can be used in two modes: for compiling sources
-- into object files, or for extracting source dependencies, e.g. by passing -M
-- command line option.
data CompilerMode = Compile | FindDependencies deriving (Show, Eq, Generic)
-- TODO: Do we really need HsCpp builder? Can't we use Cc instead?
-- | A 'Builder' is an external command invoked in separate process using 'Shake.cmd'
--
-- @Ghc Stage0@ is the bootstrapping compiler
-- @Ghc StageN@, N > 0, is the one built on stage (N - 1)
-- @GhcPkg Stage0@ is the bootstrapping @GhcPkg@
-- @GhcPkg StageN@, N > 0, is the one built in Stage0 (TODO: need only Stage1?)
-- TODO: Do we really need HsCpp builder? Can't we use a generic Cpp
-- builder instead? It would also be used instead of CcM.
-- TODO: why are Cc/CcM staged?
-- TODO: use Cc CcMode, where CcMode = Compile | FindDeps instead of Cc & CcM.
data Builder = Alex
| Ar
| DeriveConstants
| Cc Stage
| CcM Stage -- synonym for 'Cc -MM'
| Cc CompilerMode Stage
| GenApply
| GenPrimopCode
| Ghc Stage
| Ghc CompilerMode Stage
| GhcCabal
| GhcCabalHsColour -- synonym for 'GhcCabal hscolour'
| GhcM Stage -- synonym for 'Ghc -M'
| GhcPkg Stage
| Haddock
| Happy
......@@ -61,8 +63,8 @@ builderProvenance = \case
DeriveConstants -> context Stage0 deriveConstants
GenApply -> context Stage0 genapply
GenPrimopCode -> context Stage0 genprimopcode
Ghc stage -> if stage == Stage0 then Nothing else context (pred stage) ghc
GhcM stage -> builderProvenance $ Ghc stage
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
......@@ -79,12 +81,10 @@ isInternal = isJust . builderProvenance
isStaged :: Builder -> Bool
isStaged = \case
(Cc _) -> True
(CcM _) -> True
(Ghc _) -> True
(GhcM _) -> True
(GhcPkg _) -> True
_ -> False
(Cc _ _) -> True
(Ghc _ _) -> True
(GhcPkg _) -> True
_ -> False
-- TODO: Some builders are required only on certain platforms. For example,
-- Objdump is only required on OpenBSD and AIX, as mentioned in #211. Add
......@@ -103,26 +103,23 @@ builderPath builder = case builderProvenance builder of
Just context -> return . fromJust $ programPath context
Nothing -> do
let builderKey = case builder of
Alex -> "alex"
Ar -> "ar"
Cc Stage0 -> "system-cc"
Cc _ -> "cc"
CcM Stage0 -> "system-cc"
CcM _ -> "cc"
Ghc Stage0 -> "system-ghc"
GhcM Stage0 -> "system-ghc"
GhcPkg Stage0 -> "system-ghc-pkg"
Happy -> "happy"
HsColour -> "hscolour"
HsCpp -> "hs-cpp"
Ld -> "ld"
Make -> "make"
Nm -> "nm"
Objdump -> "objdump"
Patch -> "patch"
Perl -> "perl"
Ranlib -> "ranlib"
Tar -> "tar"
Alex -> "alex"
Ar -> "ar"
Cc _ Stage0 -> "system-cc"
Cc _ _ -> "cc"
Ghc _ Stage0 -> "system-ghc"
GhcPkg Stage0 -> "system-ghc-pkg"
Happy -> "happy"
HsColour -> "hscolour"
HsCpp -> "hs-cpp"
Ld -> "ld"
Make -> "make"
Nm -> "nm"
Objdump -> "objdump"
Patch -> "patch"
Perl -> "perl"
Ranlib -> "ranlib"
Tar -> "tar"
_ -> error $ "Cannot determine builderKey for " ++ show builder
path <- askConfigWithDefault builderKey . putError $
"\nCannot find path to '" ++ builderKey
......@@ -155,11 +152,14 @@ needBuilder laxDependencies builder = when (isInternal builder) $ do
where
allowOrderOnlyDependency :: Builder -> Bool
allowOrderOnlyDependency = \case
Ghc _ -> True
GhcM _ -> True
_ -> False
Ghc _ _ -> True
_ -> False
-- Instances for storing in the Shake database
instance Binary CompilerMode
instance Hashable CompilerMode
instance NFData CompilerMode
instance Binary Builder
instance Hashable Builder
instance NFData Builder
{-# LANGUAGE LambdaCase #-}
-- | Convenient predicates
module Predicates (
stage, package, builder, stagedBuilder, builderCc, builderGhc, file, way,
......@@ -19,17 +20,23 @@ package p = (p ==) <$> getPackage
builder :: Builder -> Predicate
builder b = (b ==) <$> getBuilder
-- TODO: Use type classes to unify various builder predicates (also needBuilder,
-- builderPath, etc).
-- | Is a certain builder used in the current stage?
stagedBuilder :: (Stage -> Builder) -> Predicate
stagedBuilder stageBuilder = builder . stageBuilder =<< getStage
-- | Are we building with GCC?
-- | Are we building with a C compiler?
builderCc :: Predicate
builderCc = stagedBuilder Cc ||^ stagedBuilder CcM
builderCc = getBuilder >>= \case
Cc _ _ -> return True
_ -> return False
-- | Are we building with GHC?
builderGhc :: Predicate
builderGhc = stagedBuilder Ghc ||^ stagedBuilder GhcM
builderGhc = getBuilder >>= \case
Ghc _ _ -> return True
_ -> return False
-- | Does any of the output files match a given pattern?
file :: FilePattern -> Predicate
......
......@@ -17,7 +17,7 @@ compilePackage rs context@Context {..} = do
then do
(src, deps) <- dependencies path $ hi -<.> osuf way
need $ src : deps
buildWithResources rs $ Target context (Ghc stage) [src] [hi]
buildWithResources rs $ Target context (Ghc Compile stage) [src] [hi]
else need [ hi -<.> osuf way ]
path <//> "*" <.> hibootsuf way %> \hiboot ->
......@@ -25,7 +25,7 @@ compilePackage rs context@Context {..} = do
then do
(src, deps) <- dependencies path $ hiboot -<.> obootsuf way
need $ src : deps
buildWithResources rs $ Target context (Ghc stage) [src] [hiboot]
buildWithResources rs $ Target context (Ghc Compile stage) [src] [hiboot]
else need [ hiboot -<.> obootsuf way ]
-- TODO: add dependencies for #include of .h and .hs-incl files (gcc -MM?)
......@@ -34,12 +34,12 @@ compilePackage rs context@Context {..} = do
if ("//*.c" ?== src)
then do
need $ src : deps
build $ Target context (Cc stage) [src] [obj]
build $ Target context (Cc Compile stage) [src] [obj]
else do
if compileInterfaceFilesSeparately && "//*.hs" ?== src
then need $ (obj -<.> hisuf way) : src : deps
else need $ src : deps
buildWithResources rs $ Target context (Ghc stage) [src] [obj]
buildWithResources rs $ Target context (Ghc Compile stage) [src] [obj]
-- TODO: get rid of these special cases
path <//> "*" <.> obootsuf way %> \obj -> do
......@@ -47,4 +47,4 @@ compilePackage rs context@Context {..} = do
if compileInterfaceFilesSeparately
then need $ (obj -<.> hibootsuf way) : src : deps
else need $ src : deps
buildWithResources rs $ Target context (Ghc stage) [src] [obj]
buildWithResources rs $ Target context (Ghc Compile stage) [src] [obj]
......@@ -20,14 +20,15 @@ buildPackageDependencies rs context@Context {..} =
[ "//*.c.deps", "//*.cmm.deps", "//*.S.deps" ] |%> \out -> do
let src = dep2src context out
need [src]
build $ Target context (CcM stage) [src] [out]
build $ Target context (Cc FindDependencies stage) [src] [out]
hDepFile %> \out -> do
srcs <- haskellSources context
need srcs
if srcs == []
then writeFileChanged out ""
else buildWithResources rs $ Target context (GhcM stage) srcs [out]
else buildWithResources rs $
Target context (Ghc FindDependencies stage) srcs [out]
removeFileIfExists $ out <.> "bak"
-- TODO: don't accumulate *.deps into .dependencies
......
......@@ -37,7 +37,7 @@ gmpPatches = (gmpBase -/-) <$> ["gmpsrc.patch", "tarball/gmp-5.0.4.patch"]
-- TODO: See Libffi.hs about removing code duplication.
configureEnvironment :: Action [CmdOption]
configureEnvironment = do
sequence [ builderEnv "CC" $ Cc Stage1
sequence [ builderEnv "CC" $ Cc Compile Stage1
, builderEnv "AR" Ar
, builderEnv "NM" Nm ]
where
......
......@@ -43,8 +43,8 @@ configureEnvironment = do
[ cArgs
, argStagedSettingList ConfCcArgs ]
ldFlags <- interpretInContext libffiContext $ fromDiffExpr ldArgs
sequence [ builderEnv "CC" $ Cc Stage0
, builderEnv "CXX" $ Cc Stage0
sequence [ builderEnv "CC" $ Cc Compile Stage0
, builderEnv "CXX" $ Cc Compile Stage0
, builderEnv "LD" Ld
, builderEnv "AR" Ar
, builderEnv "NM" Nm
......
......@@ -99,7 +99,8 @@ buildBinary rs context@(Context stage package _) bin = do
then [ pkgPath package -/- src <.> "hs" | src <- hSrcs ]
else objs
need $ binDeps ++ libs
buildWithResources rs $ Target context (Ghc stage) binDeps [bin]
-- TODO: Use Link mode instead of Compile.
buildWithResources rs $ Target context (Ghc Compile stage) binDeps [bin]
synopsis <- interpretInContext context $ getPkgData Synopsis
putSuccess $ renderProgram
("'" ++ pkgNameString package ++ "' (" ++ show stage ++ ").")
......
......@@ -15,7 +15,7 @@ import Settings.User
testRules :: Rules ()
testRules = do
"validate" ~> do
needBuilder False $ Ghc Stage2 -- TODO: get rid of False parameters
needBuilder False $ Ghc Compile Stage2 -- TODO: get rid of False
needBuilder False $ GhcPkg Stage1
needBuilder False $ Hpc
runMakeVerbose "testsuite/tests" ["fast"]
......@@ -28,7 +28,7 @@ testRules = do
| pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
windows <- windowsHost
top <- topDirectory
compiler <- builderPath $ Ghc Stage2
compiler <- builderPath $ Ghc Compile Stage2
ghcPkg <- builderPath $ GhcPkg Stage1
haddock <- builderPath Haddock
threads <- shakeThreads <$> getShakeOptions
......
......@@ -51,7 +51,6 @@ defaultBuilderArgs = mconcat
[ alexBuilderArgs
, arBuilderArgs
, ccBuilderArgs
, ccMBuilderArgs
, deriveConstantsBuilderArgs
, genApplyBuilderArgs
, genPrimopCodeBuilderArgs
......
module Settings.Builders.Cc (ccBuilderArgs, ccMBuilderArgs) where
module Settings.Builders.Cc (ccBuilderArgs) where
import Development.Shake.FilePath
import Expression
......@@ -8,26 +8,26 @@ import Predicates (stagedBuilder)
import Settings
import Settings.Builders.Common (cIncludeArgs)
-- TODO: handle custom $1_$2_MKDEPENDC_OPTS and
ccBuilderArgs :: Args
ccBuilderArgs = stagedBuilder Cc ?
mconcat [ commonCcArgs
, arg "-c", arg =<< getInput
, arg "-o", arg =<< getOutput ]
ccBuilderArgs = mconcat
[ stagedBuilder (Cc Compile) ?
mconcat [ commonCcArgs
, arg "-c", arg =<< getInput
, arg "-o", arg =<< getOutput ]
-- TODO: handle custom $1_$2_MKDEPENDC_OPTS and
ccMBuilderArgs :: Args
ccMBuilderArgs = stagedBuilder CcM ? do
output <- getOutput
mconcat [ arg "-E"
, arg "-MM"
, commonCcArgs
, arg "-MF"
, arg output
, arg "-MT"
, arg $ dropExtension output -<.> "o"
, arg "-x"
, arg "c"
, arg =<< getInput ]
, stagedBuilder (Cc FindDependencies) ? do
output <- getOutput
mconcat [ arg "-E"
, arg "-MM"
, commonCcArgs
, arg "-MF"
, arg output
, arg "-MT"
, arg $ dropExtension output -<.> "o"
, arg "-x"
, arg "c"
, arg =<< getInput ] ]
commonCcArgs :: Args
commonCcArgs = mconcat [ append =<< getPkgDataList CcArgs
......
......@@ -20,7 +20,7 @@ deriveConstantsBuilderArgs = builder DeriveConstants ? do
, file "//GHCConstantsHaskellExports.hs" ? arg "--gen-haskell-exports"
, arg "-o", arg output
, arg "--tmpdir", arg tempDir
, arg "--gcc-program", arg =<< getBuilderPath (Cc Stage1)
, arg "--gcc-program", arg =<< getBuilderPath (Cc Compile Stage1)
, append . concat $ map (\a -> ["--gcc-flag", a]) cFlags
, arg "--nm-program", arg =<< getBuilderPath Nm
, specified Objdump ? mconcat [ arg "--objdump-program"
......
......@@ -18,7 +18,7 @@ import Settings.Builders.Common (cIncludeArgs)
-- $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno
-- $$(addsuffix .$$(dyn_osuf)-boot,$$(basename $$@)))
ghcBuilderArgs :: Args
ghcBuilderArgs = stagedBuilder Ghc ? do
ghcBuilderArgs = stagedBuilder (Ghc Compile) ? do
output <- getOutput
stage <- getStage
way <- getWay
......@@ -61,7 +61,7 @@ splitObjectsArgs = splitObjects ? do
arg "-split-objs"
ghcMBuilderArgs :: Args
ghcMBuilderArgs = stagedBuilder GhcM ? do
ghcMBuilderArgs = stagedBuilder (Ghc FindDependencies) ? do
ways <- getLibraryWays
mconcat [ arg "-M"
, commonGhcArgs
......
......@@ -25,14 +25,14 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
, arg path
, arg dir
, dll0Args
, withStaged Ghc
, withStaged $ Ghc Compile
, withStaged GhcPkg
, bootPackageDbArgs
, libraryArgs
, with HsColour
, configureArgs
, packageConstraints
, withStaged Cc
, withStaged $ Cc Compile
, notStage0 ? with Ld
, with Ar
, with Alex
......@@ -85,7 +85,7 @@ configureArgs = do
, conf "--with-gmp-includes" $ argSetting GmpIncludeDir
, conf "--with-gmp-libraries" $ argSetting GmpLibDir
, crossCompiling ? (conf "--host" $ argSetting TargetPlatformFull)
, conf "--with-cc" $ argStagedBuilderPath Cc ]
, conf "--with-cc" $ argStagedBuilderPath (Cc Compile) ]
newtype PackageDbKey = PackageDbKey Stage
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
......@@ -114,8 +114,8 @@ withBuilderKey :: Builder -> String
withBuilderKey b = case b of
Ar -> "--with-ar="
Ld -> "--with-ld="
Cc _ -> "--with-gcc="
Ghc _ -> "--with-ghc="
Cc _ _ -> "--with-gcc="
Ghc _ _ -> "--with-ghc="
Alex -> "--with-alex="
Happy -> "--with-happy="
GhcPkg _ -> "--with-ghc-pkg="
......
......@@ -18,7 +18,7 @@ templateHsc = "inplace/lib/template-hsc.h"
hsc2hsBuilderArgs :: Args
hsc2hsBuilderArgs = builder Hsc2Hs ? do
stage <- getStage
ccPath <- getBuilderPath $ Cc stage
ccPath <- getBuilderPath $ Cc Compile stage
gmpDir <- getSetting GmpIncludeDir
cFlags <- getCFlags
lFlags <- getLFlags
......
......@@ -2,7 +2,7 @@ module Settings.Packages.Directory (directoryPackageArgs) where
import Expression
import GHC (directory)
import Predicates (stagedBuilder, package)
import Predicates (builderCc, package)
-- TODO: I had to define symbol __GLASGOW_HASKELL__ as otherwise directory.c is
-- effectively empty. I presume it was expected that GHC will be used for
......@@ -10,4 +10,4 @@ import Predicates (stagedBuilder, package)
-- only file which requires special treatment when using GCC.
directoryPackageArgs :: Args
directoryPackageArgs = package directory ?
stagedBuilder Cc ? arg "-D__GLASGOW_HASKELL__"
builderCc ? arg "-D__GLASGOW_HASKELL__"
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