From 480c19da5f745f25c01f8a7e1772b4ca670f95be Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 10 Jan 2024 19:45:03 +0000 Subject: [PATCH] Build Haskell modules accounting for TH Creates a new module Distribution.Simple.GHC.Build.Modules which, in the same spirit as ...GHC.Build.ExtraModules, defines a 'BuildM' action which builds all the Haskell modules of the component being built. This function clarifies and re-implements the logic of building Haskell modules in the different possible ways, while accounting for Template Haskell special "way requirements", which was previously duplicated in a non-obvious manner in gbuild and buildOrReplLib. The Note [Building Haskell modules accounting for TH] in that module explains the big picture, and the implementation is re-done in light of it. A standalone part of the refactor of gbuild vs buildOrReplLib (#9389) --- Cabal/Cabal.cabal | 7 +- Cabal/src/Distribution/Simple/Build/Monad.hs | 58 ++- Cabal/src/Distribution/Simple/GHC.hs | 22 +- Cabal/src/Distribution/Simple/GHC/Build.hs | 349 ++++++------------ .../Simple/{ => GHC}/Build/ExtraSources.hs | 38 +- .../Distribution/Simple/GHC/Build/Modules.hs | 331 +++++++++++++++++ .../Distribution/Simple/GHC/BuildGeneric.hs | 154 ++------ .../Distribution/Simple/GHC/BuildOrRepl.hs | 94 +---- Cabal/src/Distribution/Simple/GHC/Internal.hs | 5 +- Cabal/src/Distribution/Simple/GHCJS.hs | 4 +- 10 files changed, 568 insertions(+), 494 deletions(-) rename Cabal/src/Distribution/Simple/{ => GHC}/Build/ExtraSources.hs (91%) create mode 100644 Cabal/src/Distribution/Simple/GHC/Build/Modules.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 52f1c1b09e0..68f49321def 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -88,7 +88,6 @@ library Distribution.Simple Distribution.Simple.Bench Distribution.Simple.Build - Distribution.Simple.Build.ExtraSources Distribution.Simple.Build.Macros Distribution.Simple.Build.Monad Distribution.Simple.Build.PackageInfoModule @@ -334,8 +333,12 @@ library Distribution.Simple.Build.PackageInfoModule.Z Distribution.Simple.Build.PathsModule.Z Distribution.Simple.GHC.Build - Distribution.Simple.GHC.BuildOrRepl + Distribution.Simple.GHC.Build.ExtraSources + Distribution.Simple.GHC.Build.Link + Distribution.Simple.GHC.Build.Modules + Distribution.Simple.GHC.Build.Utils Distribution.Simple.GHC.BuildGeneric + Distribution.Simple.GHC.BuildOrRepl Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.Internal Distribution.Simple.GHC.ImplInfo diff --git a/Cabal/src/Distribution/Simple/Build/Monad.hs b/Cabal/src/Distribution/Simple/Build/Monad.hs index b3d68f66276..6fa18c0d487 100644 --- a/Cabal/src/Distribution/Simple/Build/Monad.hs +++ b/Cabal/src/Distribution/Simple/Build/Monad.hs @@ -1,11 +1,20 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE NamedFieldPuns #-} - module Distribution.Simple.Build.Monad ( BuildM (..) , runBuildM , PreBuildComponentInputs (..) + -- * A few queries on @'BuildM'@ + , buildVerbosity + , buildWhat + , buildComponent + , buildCLBI + , buildBI + , buildLBI + , buildCompiler + , buildTarget + -- * Re-exports , BuildingWhat (..) , LocalBuildInfo (..) @@ -20,6 +29,11 @@ import Control.Monad.Reader import Distribution.Simple.Setup (BuildingWhat (..), buildingWhatDistPref, buildingWhatVerbosity) import Distribution.Types.LocalBuildInfo import Distribution.Types.TargetInfo +import Distribution.Verbosity +import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.BuildInfo +import Distribution.Simple.Compiler -- | The information required for a build computation (@'BuildM'@) -- which is available right before building each component, i.e. the pre-build @@ -35,9 +49,49 @@ data PreBuildComponentInputs = PreBuildComponentInputs -- | Computations carried out in the context of building a component (e.g. @'buildAllExtraSources'@) newtype BuildM a = BuildM (PreBuildComponentInputs -> IO a) - deriving (Functor, Applicative, Monad) via ReaderT PreBuildComponentInputs IO + deriving (Functor, Applicative, Monad, MonadReader PreBuildComponentInputs, MonadIO) via ReaderT PreBuildComponentInputs IO -- | Run a 'BuildM' action, i.e. a computation in the context of building a component. runBuildM :: BuildingWhat -> LocalBuildInfo -> TargetInfo -> BuildM a -> IO a runBuildM buildingWhat localBuildInfo targetInfo (BuildM f) = f PreBuildComponentInputs{buildingWhat, localBuildInfo, targetInfo} +{-# INLINE runBuildM #-} + +-- | Get the @'BuildingWhat'@ representing the kind of build we are doing with what flags (Normal vs Repl vs ...) +buildWhat :: BuildM BuildingWhat +buildWhat = asks buildingWhat +{-# INLINE buildWhat #-} + +-- | Get the @'Verbosity'@ from the context the component being built is in. +buildVerbosity :: BuildM Verbosity +buildVerbosity = buildingWhatVerbosity <$> buildWhat +{-# INLINE buildVerbosity #-} + +-- | Get the @'Component'@ being built. +buildComponent :: BuildM Component +buildComponent = asks (targetComponent . targetInfo) +{-# INLINE buildComponent #-} + +-- | Get the @'ComponentLocalBuildInfo'@ for the component being built. +buildCLBI :: BuildM ComponentLocalBuildInfo +buildCLBI = asks (targetCLBI . targetInfo) +{-# INLINE buildCLBI #-} + +-- | Get the @'BuildInfo'@ of the component being built. +buildBI :: BuildM BuildInfo +buildBI = componentBuildInfo <$> buildComponent +{-# INLINE buildBI #-} + +-- | Get the @'LocalBuildInfo'@ of the component being built. +buildLBI :: BuildM LocalBuildInfo +buildLBI = asks localBuildInfo +{-# INLINE buildLBI #-} + +buildCompiler :: BuildM Compiler +buildCompiler = compiler <$> buildLBI +{-# INLINE buildCompiler #-} + +-- | Get the @'TargetInfo'@ of the current component being built. +buildTarget :: BuildM TargetInfo +buildTarget = asks targetInfo + diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index f239eb9a824..53c51246490 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -56,7 +56,7 @@ module Distribution.Simple.GHC , libAbiHash , hcPkgInfo , registerPackage - , componentGhcOptions + , Internal.componentGhcOptions , Internal.componentCcGhcOptions , getGhcAppDir , getLibDir @@ -95,12 +95,7 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors import Distribution.Simple.Flag (Flag (..), toFlag) -import Distribution.Simple.GHC.Build - ( componentGhcOptions - , exeTargetName - , flibTargetName - , isDynamic - ) +import Distribution.Simple.GHC.Build.Utils import Distribution.Simple.GHC.EnvironmentParser import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal @@ -109,6 +104,7 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Program import Distribution.Simple.Program.Builtin (runghcProgram) +import Distribution.Types.TargetInfo import Distribution.Simple.Program.GHC import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Strip as Strip @@ -137,7 +133,7 @@ import System.FilePath ) import qualified System.Info #ifndef mingw32_HOST_OS -import Distribution.Simple.GHC.Build (flibBuildName) +import Distribution.Simple.GHC.Build.Utils (flibBuildName) import System.Directory (renameFile) import System.Posix (createSymbolicLink) #endif /* mingw32_HOST_OS */ @@ -579,7 +575,7 @@ buildLib -> Library -> ComponentLocalBuildInfo -> IO () -buildLib = buildOrReplLib . Left +buildLib = buildOrReplLib . BuildNormal replLib :: ReplFlags @@ -589,7 +585,7 @@ replLib -> Library -> ComponentLocalBuildInfo -> IO () -replLib = buildOrReplLib . Right +replLib = buildOrReplLib . BuildRepl -- | Start a REPL without loading any source files. startInterpreter @@ -632,7 +628,7 @@ replFLib -> ComponentLocalBuildInfo -> IO () replFLib replFlags njobs pkg lbi = - gbuild (BuildRepl replFlags) njobs pkg lbi . GReplFLib (replReplOptions replFlags) + gbuild (BuildRepl replFlags) njobs pkg lbi . GReplFLib replFlags -- | Build an executable with GHC. buildExe @@ -654,7 +650,7 @@ replExe -> ComponentLocalBuildInfo -> IO () replExe replFlags njobs pkg lbi = - gbuild (BuildRepl replFlags) njobs pkg lbi . GReplExe (replReplOptions replFlags) + gbuild (BuildRepl replFlags) njobs pkg lbi . GReplExe replFlags -- | Extracts a String representing a hash of the ABI of a built -- library. It can fail if the library has not yet been built. @@ -671,7 +667,7 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do comp = compiler lbi platform = hostPlatform lbi vanillaArgs = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + (Internal.componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash , ghcOptInputModules = toNubListR $ exposedModules lib diff --git a/Cabal/src/Distribution/Simple/GHC/Build.hs b/Cabal/src/Distribution/Simple/GHC/Build.hs index a00a0afaabd..6eb4769dfa4 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build.hs @@ -1,31 +1,18 @@ -module Distribution.Simple.GHC.Build - ( getRPaths - , runReplOrWriteFlags - , checkNeedsRecompilation - , replNoLoad - , componentGhcOptions - , supportsDynamicToo - , isDynamic - , findExecutableMain - , flibBuildName - , flibTargetName - , flibIsDynamic - , exeTargetName - , isCxx - , isC - , isHaskell - ) -where +{-# LANGUAGE BlockArguments #-} +module Distribution.Simple.GHC.Build where import Distribution.Compat.Prelude import Prelude () +import Data.Function +import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as BS import Distribution.Compat.Binary (encode) import Distribution.Compat.ResponseFile (escapeArgs) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Package -import Distribution.PackageDescription as PD +import Distribution.PackageDescription as PD hiding (buildInfo) +import qualified Distribution.PackageDescription as PD import Distribution.PackageDescription.Utils (cabalBug) import Distribution.Pretty import Distribution.Simple.BuildPaths @@ -43,237 +30,119 @@ import Distribution.Utils.NubList import Distribution.Utils.Path (getSymbolicPath) import Distribution.Verbosity import Distribution.Version -import System.Directory - ( createDirectoryIfMissing - , getCurrentDirectory - ) +import System.Directory hiding (exeExtension) import System.FilePath - ( isRelative - , replaceExtension - , takeExtension - , (<.>) - , () - ) - -exeTargetName :: Platform -> Executable -> String -exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform - -withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else "" - --- | Find the path to the entry point of an executable (typically specified in --- @main-is@, and found in @hs-source-dirs@). -findExecutableMain - :: Verbosity - -> FilePath - -- ^ Build directory - -> Executable - -> IO FilePath - -- ^ The path to the main source file. -findExecutableMain verbosity bdir Executable{buildInfo = bnfo, modulePath = modPath} = - findFileEx verbosity (bdir : map getSymbolicPath (hsSourceDirs bnfo)) modPath - --- | Target name for a foreign library (the actual file name) --- --- We do not use mkLibName and co here because the naming for foreign libraries --- is slightly different (we don't use "_p" or compiler version suffices, and we --- don't want the "lib" prefix on Windows). --- --- TODO: We do use `dllExtension` and co here, but really that's wrong: they --- use the OS used to build cabal to determine which extension to use, rather --- than the target OS (but this is wrong elsewhere in Cabal as well). -flibTargetName :: LocalBuildInfo -> ForeignLib -> String -flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> - "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> - "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - - os :: OS - os = - let (Platform _ os') = hostPlatform lbi - in os' - - -- If a foreign lib foo has lib-version-info 5:1:2 or - -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 - -- Libtool's version-info data is translated into library versions in a - -- nontrivial way: so refer to libtool documentation. - versionedExt :: String - versionedExt = - let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) - --- | Name for the library when building. --- --- If the `lib-version-info` field or the `lib-version-linux` field of --- a foreign library target is set, we need to incorporate that --- version into the SONAME field. --- --- If a foreign library foo has lib-version-info 5:1:2, it should be --- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. --- However, GHC does not allow overriding soname by setting linker --- options, as it sets a soname of its own (namely the output --- filename), after the user-supplied linker options. Hence, we have --- to compile the library with the soname as its filename. We rename --- the compiled binary afterwards. --- --- This method allows to adjust the name of the library at build time --- such that the correct soname can be set. -flibBuildName :: LocalBuildInfo -> ForeignLib -> String -flibBuildName lbi flib - -- On linux, if a foreign-library has version data, the first digit is used - -- to produce the SONAME. - | (os, foreignLibType flib) - == (Linux, ForeignLibNativeShared) = - let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) - | otherwise = flibTargetName lbi flib - where - os :: OS - os = - let (Platform _ os') = hostPlatform lbi - in os' - - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - -flibIsDynamic :: ForeignLib -> Bool -flibIsDynamic flib = - case foreignLibType flib of - ForeignLibNativeShared -> - ForeignLibStandalone `notElem` foreignLibOptions flib - ForeignLibNativeStatic -> - False - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - -isDynamic :: Compiler -> Bool -isDynamic = Internal.ghcLookupProperty "GHC Dynamic" - --- | Is this file a C++ source file, i.e. ends with .cpp, .cxx, or .c++? -isCxx :: FilePath -> Bool -isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] - --- | Is this a C source file, i.e. ends with .c? -isC :: FilePath -> Bool -isC fp = elem (takeExtension fp) [".c"] - --- | FilePath has a Haskell extension: .hs or .lhs -isHaskell :: FilePath -> Bool -isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - -componentGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi = - Internal.componentGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp +import Distribution.Simple.Build.Monad +import Distribution.Simple.GHC.Build.ExtraSources +import Distribution.Simple.GHC.Build.Modules +import Distribution.Types.ParStrat +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.Setup.Common (extraCompilationArtifacts) + +-- | The main build phase of building a component. +-- Includes building Haskell modules, extra build sources, and linking. +build :: Flag ParStrat + -> PackageDescription + -> BuildM () +build numJobs pkg_descr = do + verbosity <- buildVerbosity + what <- buildWhat + component <- buildComponent + lbi <- buildLBI + clbi <- buildCLBI + buildInfo <- buildBI + target <- buildTarget + + let isLib | CLib{} <- component = True + | otherwise = False + + {- + Where to place the build result (targetDir) and the build artifacts (buildTargetDir). + + * For libraries, targetDir == buildTargetDir, where both the library and + artifacts are put together. + + * For executables or foreign libs, buildTargetDir == targetDir/-tmp, where + the targetDir is the location where the target (e.g. the executable) is written to + and buildTargetDir is where the compilation artifacts (e.g. Main.o) will live + Arguably, this difference should not exist (#9498) (TODO) + + For instance, for a component `cabal-benchmarks`: + targetDir == /cabal-benchmarks + buildTargetDir == /cabal-benchmarks/cabal-benchmarks-tmp + + Or, for a library `Cabal`: + targetDir == /. + buildTargetDir == targetDir + + Furthermore, we need to account for the limit of characters in ghc + invocations that different OSes constrain us to. Cabal invocations can + rapidly reach this limit, in part, due to the long length of cabal v2 + prefixes. To minimize the likelihood, we use + `makeRelativeToCurrentDirectory` to shorten the paths used in invocations + (see da6321bb). + -} + let targetDir_absolute = componentBuildDir lbi clbi + buildTargetDir_absolute + -- Libraries use the target dir for building (see above) + | isLib = targetDir_absolute + + -- In other cases, use targetDir/-tmp + | targetDirName:_ <- reverse $ splitDirectories targetDir_absolute + = targetDir_absolute (targetDirName ++ "-tmp") + + | otherwise = error "GHC.build: targetDir is empty" + + liftIO do + createDirectoryIfMissingVerbose verbosity True targetDir_absolute + createDirectoryIfMissingVerbose verbosity True buildTargetDir_absolute + targetDir <- makeRelativeToCurrentDirectory targetDir_absolute & liftIO + buildTargetDir <- makeRelativeToCurrentDirectory buildTargetDir_absolute & liftIO + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) & liftIO + + -- ensure extra lib dirs exist before passing to ghc + cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs buildInfo) & liftIO + cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic buildInfo) & liftIO + + buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir + buildAllExtraSources ghcProg + + -- Now pattern match and call repl or link action for each kind of component + -- ROMES:TODO: Still a work in progress! + pure () + -- case what of + -- BuildRepl rflags -> do + -- -- TODO when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" + -- runReplOrWriteFlags ghcProg lbi rflags replOpts target (pkgName (PD.package pkg_descr)) & liftIO + + -- _build -> linkComponent + +-------------------------------------------------------------------------------- +-- * Utils, basically. +-------------------------------------------------------------------------------- replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a replNoLoad replFlags l | replOptionsNoLoad replFlags == Flag True = mempty | otherwise = l --- | Finds the object file name of the given source file -getObjectFileName :: FilePath -> GhcOptions -> FilePath -getObjectFileName filename opts = oname - where - odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext - --- | Returns True if the modification date of the given source file is newer than --- the object file we last compiled for it, or if no object file exists yet. -checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool -checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where - oname = getObjectFileName filename opts - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths - :: LocalBuildInfo - -> ComponentLocalBuildInfo - -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux = True - supportRPaths Windows = False - supportRPaths OSX = True - supportRPaths FreeBSD = - case compid of - CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True - _ -> False - supportRPaths OpenBSD = False - supportRPaths NetBSD = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Wasi = False - supportRPaths Hurd = True - supportRPaths Haiku = False - supportRPaths (OtherOS _) = False --- Do _not_ add a default case so that we get a warning here when a new OS --- is added. - -getRPaths _ _ = return mempty - runReplOrWriteFlags - :: Verbosity - -> ConfiguredProgram - -> Compiler - -> Platform - -> ReplOptions + :: ConfiguredProgram + -> LocalBuildInfo + -> ReplFlags -> GhcOptions - -> BuildInfo - -> ComponentLocalBuildInfo + -> TargetInfo -> PackageName -> IO () -runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts bi clbi pkg_name = - case replOptionsFlagOutput rflags of - NoFlag -> runGHC verbosity ghcProg comp platform replOpts +runReplOrWriteFlags ghcProg lbi rflags ghcOpts target pkg_name = + let bi = componentBuildInfo $ targetComponent target + clbi = targetCLBI target + comp = compiler lbi + platform = hostPlatform lbi + in + case replOptionsFlagOutput (replReplOptions rflags) of + NoFlag -> runGHC (fromFlag $ replVerbosity rflags) ghcProg comp platform ghcOpts Flag out_dir -> do src_dir <- getCurrentDirectory let uid = componentUnitId clbi @@ -299,4 +168,4 @@ runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts bi clbi pkg_ writeFileAtomic (out_dir this_unit) $ BS.pack $ escapeArgs $ - extra_opts ++ renderGhcOptions comp platform (replOpts{ghcOptMode = NoFlag}) + extra_opts ++ renderGhcOptions comp platform (ghcOpts{ghcOptMode = NoFlag}) diff --git a/Cabal/src/Distribution/Simple/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs similarity index 91% rename from Cabal/src/Distribution/Simple/Build/ExtraSources.hs rename to Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs index 82391c91743..c101d5cab6a 100644 --- a/Cabal/src/Distribution/Simple/Build/ExtraSources.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -3,7 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -module Distribution.Simple.Build.ExtraSources where +module Distribution.Simple.GHC.Build.ExtraSources where import Control.Monad import Data.Foldable @@ -12,24 +12,27 @@ import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.Simple.Program.GHC import Distribution.Simple.Utils -import Distribution.Simple.Program.Builtin (ghcProgram) import Distribution.Types.BuildInfo import Distribution.Types.Component import Distribution.Types.TargetInfo -import Distribution.Simple.GHC.Build +import Distribution.Simple.GHC.Build.Utils import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program (requireProgram) import Distribution.Types.ComponentName (componentNameRaw) import Distribution.Types.Executable import Distribution.Verbosity (Verbosity) import System.FilePath +import Distribution.Simple.Program.Types import Distribution.Simple.Build.Monad -buildAllExtraSources :: BuildM () +-- | An action that builds all the extra build sources of a component, i.e. C, +-- C++, Js, Asm, C-- sources. +buildAllExtraSources :: ConfiguredProgram + -- ^ The GHC configured program + -> BuildM () buildAllExtraSources = - sequence_ + sequence_ . sequence [ buildCSources , buildCxxSources , buildJsSources @@ -44,15 +47,14 @@ buildAllExtraSources = -- ROMES:PATCH:NOTE: Worry about mimicking the current behaviour first, and only -- later worry about dependency tracking and ghc -M, gcc -M, or ghc -optc-MD ... --- ROMES:TODO: --- How should we handle a C source depending on a stub generated from a foreign export? - buildCSources , buildCxxSources , buildJsSources , buildAsmSources , buildCmmSources - :: BuildM () + :: ConfiguredProgram + -- ^ The GHC configured program + -> BuildM () -- Currently, an executable main file may be a C++ or C file, in which case we want to -- compile it alongside other C/C++ sources. Eventually, we may be able to -- compile other main files as build sources (e.g. ObjC...). This functionality @@ -119,8 +121,10 @@ buildExtraSources -- @'Executable'@ components might additionally add the -- program entry point (@main-is@ file) to the extra sources, -- if it should be compiled as the rest of them. + -> ConfiguredProgram + -- ^ The GHC configured program -> BuildM () -buildExtraSources description componentSourceGhcOptions wantDyn viewSources = +buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcProg = BuildM \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> let bi = componentBuildInfo (targetComponent targetInfo) @@ -136,7 +140,6 @@ buildExtraSources description componentSourceGhcOptions wantDyn viewSources = forceSharedLib = doingTH && isGhcDynamic buildAction sourceFile = do - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) let runGhcProg = runGHC verbosity ghcProg comp platform let baseSrcOpts = @@ -222,9 +225,8 @@ buildExtraSources description componentSourceGhcOptions wantDyn viewSources = | CNotLibName{} <- cname = componentBuildDir lbi clbi componentNameRaw cname <> "-tmp" - in - do - -- build any sources - unless (null sources) $ do - info verbosity ("Building " ++ description ++ "...") - traverse_ buildAction sources + in do + -- build any sources + unless (null sources) $ do + info verbosity ("Building " ++ description ++ "...") + traverse_ buildAction sources diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs new file mode 100644 index 00000000000..272e80358b6 --- /dev/null +++ b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +module Distribution.Simple.GHC.Build.Modules + ( buildHaskellModules ) + where + +import Distribution.Compat.Prelude +import Control.Monad.IO.Class + +import Distribution.Types.ParStrat +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Utils +import Distribution.Utils.NubList +import System.FilePath +import Distribution.Simple.Build.Monad +import Distribution.Simple.GHC.Build.Utils +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.Setup.Common +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.GHC +import Distribution.Types.ForeignLib +import Distribution.Types.Executable +import Distribution.Types.TestSuite +import Distribution.Types.Benchmark +import Distribution.Types.BuildInfo +import qualified Data.Set as Set +import Data.List ((\\), sortOn) +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.ModuleName (ModuleName) +import Distribution.Types.TestSuiteInterface +import Distribution.Types.BenchmarkInterface +import Distribution.Pretty +import Distribution.CabalSpecVersion +import Distribution.Types.PackageName.Magic +import qualified Distribution.PackageDescription as PD + +{- +Note [Building Haskell Modules accounting for TH] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are multiple ways in which we may want to build our Haskell modules: + * The static way + * The dynamic/shared way + * The profiled way + +For libraries, we may /want/ to build modules in all three ways, or in any combination, depending on user options. +For executables, we just /want/ to build the executable in the requested way. + +In practice, however, we may /need/ to build modules in additional ways beyonds the ones that were requested. +This can happen because of Template Haskell. + +When we're using Template Haskell, we /need/ to additionally build modules with +the used GHC's default/vanilla ABI. This is because the code that TH needs to +run at compile time needs to be the vanilla ABI so it can be loaded up and run +by the compiler. With dynamic-by-default GHC the TH object files loaded at +compile-time need to be .dyn_o instead of .o. + + * If the GHC is dynamic by default, that means we may need to also build + the dynamic way in addition the wanted way. + + * If the GHC is static by default, we may need to build statically additionally. + +Of course, if the /wanted/ way is the way additionally /needed/ for TH, we don't need to do extra work. + +If it turns out that in the end we need to build both statically and +dynamically, we want to make use of GHC's --dynamic-too capability, which +builds modules in the two ways in a single invocation. + +If --dynamic-too is not supported by the GHC, then we need to be careful about +the order in which modules are built. Specifically, we must first build the +modules for TH with the vanilla ABI, and only afterwards the desired +(non-default) ways. + +A few examples: + +To build an executable with profiling, with a dynamic by default GHC, and TH is used: + * Build dynamic (needed) objects + * Build profiled objects + +To build a library with profiling and dynamically, with a static by default GHC, and TH is used: + * Build dynamic (wanted) and static (needed) objects together with --dynamic-too + * Build profiled objects + +To build an executable statically, with a static by default GHC, regardless of whether TH is used: + * Simply build static objects + +-} + +-- | Compile the Haskell modules of the component being built. +buildHaskellModules :: Flag ParStrat + -- ^ The parallelism strategy (e.g. num of jobs) + -> ConfiguredProgram + -- ^ The GHC configured program + -> PD.PackageDescription + -- ^ The package description + -> FilePath + -- ^ The path to the build directory for this target, which + -- has already been created. + -> BuildM () +-- See Note [Building Haskell Modules accounting for TH] +buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir = do + verbosity <- buildVerbosity + component <- buildComponent + clbi <- buildCLBI + lbi <- buildLBI + bi <- buildBI + what <- buildWhat + comp <- buildCompiler + + let isLib | CLib{} <- component = True + | otherwise = False + forRepl + | BuildRepl{} <- what = True + | otherwise = False + + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? FIX: what about exeName.hi-boot? + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = Flag $ Hpc.mixDir (buildTargetDir extraCompilationArtifacts) way + | otherwise = mempty + + (inputFiles, inputModules) <- componentInputs buildTargetDir pkg_descr + + let + runGhcProg = runGHC verbosity ghcProg comp platform + platform = hostPlatform lbi + + -- See Note [Building Haskell Modules accounting for TH] + doingTH = usesTemplateHaskellOrQQ bi + + baseOpts = Internal.componentGhcOptions verbosity lbi bi clbi buildTargetDir + vanillaOpts = + baseOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptNumJobs = numJobs + , ghcOptInputModules = toNubListR inputModules + , ghcOptInputFiles = + toNubListR $ + if PD.package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles + , ghcOptInputScripts = + toNubListR $ + if PD.package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [] + } + + staticOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticOnly + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + dynOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + -- TODO: Does it hurt to set -fPIC for executables? + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC bi + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + profOpts = + vanillaOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + (if isLib then True else False) + ((if isLib then withProfLibDetail else withProfExeDetail) lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcProfOptions GHC bi + , ghcOptHPCDir = hpcdir Hpc.Prof + } + dynTooOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "dyn_hi" + , ghcOptDynObjSuffix = toFlag "dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + + -- wantVanilla is underspecified, maybe we could deprecated it (TODO) + wantVanilla = if isLib then withVanillaLib lbi else False + wantStatic = if isLib then withStaticLib lbi else withFullyStaticExe lbi + wantDynamic = if isLib then withSharedLib lbi else withDynExe lbi + wantProf = if isLib then withProfLib lbi else withProfExe lbi + + defaultGhcWay = if isDynamic comp then DynWay else StaticWay + + -- If there aren't modules, or if we're loading the modules in repl, don't build. + unless (forRepl || (null inputFiles && null inputModules)) $ liftIO $ + + -- See Note [Building Haskell Modules accounting for TH] + let + wantedWays + = Set.fromList + $ [StaticWay | wantStatic] + <> [DynWay | wantDynamic ] + <> [ProfWay | wantProf ] + -- If no way is explicitly wanted, we take vanilla + <> [VanillaWay | wantVanilla || not (wantStatic || wantDynamic || wantProf) ] + -- ROMES:TODO: Is vanilla necessarily the same as defaultGhcWay? If so, + -- we can deal away with VanillaWay and be explicit in -dynamic vs + -- -static, or always default to -static. Would simplify further. + -- ROMES:TODO: Perhaps, if the component is indefinite, we only pick Vanilla? + -- To mimick the old behaviour we need at least profiled too (Vanilla + + -- Prof), and there's even a test for profiled signature, whatever that + -- means. So only doing vanilla way for indefinite components before seems wrong. + -- Consider... + + neededWays + = wantedWays + <> Set.fromList + -- TODO: You also don't need this if you are using an external interpreter!! + [defaultGhcWay | doingTH && defaultGhcWay `Set.notMember` wantedWays] + + -- If we need both static and dynamic, use dynamic-too instead of + -- compiling twice (if we support it) + useDynamicToo + -- TODO: These vanilla way are kind of bothersome. Ask Matthew. + = (StaticWay `Set.member` neededWays || VanillaWay `Set.member` neededWays) + && DynWay `Set.member` neededWays + && supportsDynamicToo comp + && null (hcSharedOptions GHC bi) + + -- The ways we'll build, in order + orderedBuilds + + -- If we can use dynamic-too, do it first. The default GHC way can only + -- be static or dynamic, so if we build both right away any TH-needed + -- modules possibly needed later (for prof.) are already built. + | useDynamicToo + = [ buildStaticAndDynamicToo ] ++ + (buildWay <$> Set.toList neededWays \\ [StaticWay, VanillaWay, DynWay]) + + -- Otherwise, we need to ensure the defaultGhcWay is built first. + | otherwise + = buildWay <$> sortOn (\w -> if w == defaultGhcWay then 0 else 1 :: Int) (Set.toList neededWays) + + buildWay = \case + StaticWay -> runGhcProg staticOpts + DynWay -> runGhcProg dynOpts + ProfWay -> runGhcProg profOpts + VanillaWay -> runGhcProg vanillaOpts + + buildStaticAndDynamicToo = do + runGhcProg dynTooOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Flag dynDir, Flag vanillaDir) -> + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir + _ -> return () + + in sequence_ orderedBuilds + +data BuildWay = StaticWay | DynWay | ProfWay | VanillaWay + deriving (Eq, Ord) + +-- | Returns a pair of the input files and Haskell modules of the component +-- being built. +componentInputs :: FilePath + -- ^ Target build dir + -> PD.PackageDescription + -> BuildM ([FilePath], [ModuleName]) +componentInputs buildTargetDir pkg_descr = do + verbosity <- buildVerbosity + component <- buildComponent + clbi <- buildCLBI + + case component of + CLib lib + -> pure ([], allLibModules lib clbi) + CFLib flib + -> pure ([], foreignLibModules flib) + CExe Executable{buildInfo=bi', modulePath} + -> exeLikeInputs verbosity bi' modulePath + CTest TestSuite{testBuildInfo=bi', testInterface = TestSuiteExeV10 _ mainFile } + -> exeLikeInputs verbosity bi' mainFile + CBench Benchmark{benchmarkBuildInfo=bi', benchmarkInterface = BenchmarkExeV10 _ mainFile } + -> exeLikeInputs verbosity bi' mainFile + CTest TestSuite{} -> error "testSuiteExeV10AsExe: wrong kind" + CBench Benchmark{} -> error "benchmarkExeV10asExe: wrong kind" + + where + exeLikeInputs verbosity bnfo modulePath = liftIO $ do + main <- findExecutableMain verbosity buildTargetDir (bnfo, modulePath) + let mainModName = exeMainModuleName bnfo + otherModNames = otherModules bnfo + + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if isHaskell main || PD.package pkg_descr == fakePackageId then + if PD.specVersion pkg_descr < CabalSpecV2_0 && (mainModName `elem` otherModNames) then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ + "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + return ([main], filter (/= mainModName) otherModNames) + else + return ([main], otherModNames) + else + return ([], otherModNames) diff --git a/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs b/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs index d9aa0f62c31..23244662fe2 100644 --- a/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs +++ b/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs @@ -8,22 +8,20 @@ module Distribution.Simple.GHC.BuildGeneric import Distribution.Compat.Prelude import Prelude () -import Control.Monad (msum) -import Data.Char (isLower) import Distribution.CabalSpecVersion import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName import Distribution.Package import Distribution.PackageDescription as PD import Distribution.PackageDescription.Utils (cabalBug) import Distribution.Pretty -import Distribution.Simple.Build.ExtraSources import Distribution.Simple.Build.Monad import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.GHC.Build +import Distribution.Simple.GHC.Build.ExtraSources +import Distribution.Simple.GHC.Build.Modules import qualified Distribution.Simple.GHC.Internal as Internal import qualified Distribution.Simple.Hpc as Hpc import Distribution.Simple.LocalBuildInfo @@ -49,6 +47,8 @@ import System.FilePath ( replaceExtension , () ) +import Distribution.Simple.GHC.Build.Utils +import Distribution.Simple.GHC.Build.Link (getRPaths) -- | A collection of: -- * C input files @@ -98,9 +98,9 @@ data RtsInfo = RtsInfo -- 'GBuildMode' distinguishes between the various kinds of operation. data GBuildMode = GBuildExe Executable - | GReplExe ReplOptions Executable + | GReplExe ReplFlags Executable | GBuildFLib ForeignLib - | GReplFLib ReplOptions ForeignLib + | GReplFLib ReplFlags ForeignLib gbuildInfo :: GBuildMode -> BuildInfo gbuildInfo (GBuildExe exe) = buildInfo exe @@ -163,9 +163,9 @@ gbuildSources verbosity pkgId specVer tmpDir bm = GReplFLib _ flib -> return $ flibSources flib where exeSources :: Executable -> IO BuildSources - exeSources exe@Executable{buildInfo = bnfo} = do - main <- findExecutableMain verbosity tmpDir exe - let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe + exeSources exe@Executable{buildInfo = bnfo, modulePath = path} = do + main <- findExecutableMain verbosity tmpDir (bnfo, path) + let mainModName = exeMainModuleName bnfo otherModNames = exeModules exe -- Scripts have fakePackageId and are always Haskell but can have any extension. @@ -291,57 +291,6 @@ hasThreaded bi = elem "-threaded" ghc where PerCompilerFlavor ghc _ = options bi --- | "Main" module name when overridden by @ghc-options: -main-is ...@ --- or 'Nothing' if no @-main-is@ flag could be found. --- --- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. -exeMainModuleName :: Executable -> Maybe ModuleName -exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts - where - ghcopts = hcOptions GHC bnfo - - findIsMainArgs [] = [] - findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest - findIsMainArgs (_ : rest) = findIsMainArgs rest - --- | Decode argument to '-main-is' --- --- Returns 'Nothing' if argument set only the function name. --- --- This code has been stolen/refactored from GHC's DynFlags.setMainIs --- function. The logic here is deliberately imperfect as it is --- intended to be bug-compatible with GHC's parser. See discussion in --- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. -decodeMainIsArg :: String -> Maybe ModuleName -decodeMainIsArg arg - | headOf main_fn isLower = - -- The arg looked like "Foo.Bar.baz" - Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = - Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = - Nothing - where - headOf :: String -> (Char -> Bool) -> Bool - headOf str pred' = any pred' (safeHead str) - - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - - splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) - splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - where - -- 'safeTail' drops the char satisfying 'pred' - (r_suf, r_pre) = break pred' (reverse str) -- | Generic build function. See comment for 'GBuildMode'. gbuild @@ -363,6 +312,7 @@ gbuild what numJobs pkg_descr lbi bm clbi = do comp = compiler lbi platform = hostPlatform lbi runGhcProg = runGHC verbosity ghcProg comp platform + target = TargetInfo clbi (gbuildComp bm) let bnfo = gbuildInfo bm @@ -384,7 +334,7 @@ gbuild what numJobs pkg_descr lbi bm clbi = do | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir extraCompilationArtifacts) way | otherwise = mempty - rpaths <- getRPaths lbi clbi + rpaths <- runBuildM what lbi target getRPaths buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm -- ensure extra lib dirs exist before passing to ghc @@ -398,8 +348,6 @@ gbuild what numJobs pkg_descr lbi bm clbi = do cmmSrcs = cmmSourceFiles buildSources inputFiles = inputSourceFiles buildSources inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp cLikeObjs = map (`replaceExtension` objExtension) cSrcs cxxObjs = map (`replaceExtension` objExtension) cxxSrcs jsObjs = if hasJsSupport then map (`replaceExtension` objExtension) jsSrcs else [] @@ -412,7 +360,7 @@ gbuild what numJobs pkg_descr lbi bm clbi = do -- build executables baseOpts = - (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + (Internal.componentGhcOptions verbosity lbi bnfo clbi tmpDir) `mappend` mempty { ghcOptMode = toFlag GhcModeMake , ghcOptInputFiles = @@ -457,14 +405,6 @@ gbuild what numJobs pkg_descr lbi bm clbi = do , ghcOptExtra = hcSharedOptions GHC bnfo , ghcOptHPCDir = hpcdir Hpc.Dyn } - dynTooOpts = - staticOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic - , ghcOptDynHiSuffix = toFlag "dyn_hi" - , ghcOptDynObjSuffix = toFlag "dyn_o" - , ghcOptHPCDir = hpcdir Hpc.Dyn - } linkerOpts = mempty { ghcOptLinkOptions = @@ -509,9 +449,9 @@ gbuild what numJobs pkg_descr lbi bm clbi = do { ghcOptExtra = Internal.filterGhciFlags (ghcOptExtra baseOpts) - <> replOptionsFlags replFlags - , ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules baseOpts) - , ghcOptInputFiles = replNoLoad replFlags (ghcOptInputFiles baseOpts) + <> replOptionsFlags (replReplOptions replFlags) + , ghcOptInputModules = replNoLoad (replReplOptions replFlags) (ghcOptInputModules baseOpts) + , ghcOptInputFiles = replNoLoad (replReplOptions replFlags) (ghcOptInputFiles baseOpts) } -- For a normal compile we do separate invocations of ghc for -- compiling as for linking. But for repl we have to do just @@ -527,64 +467,16 @@ gbuild what numJobs pkg_descr lbi bm clbi = do | needProfiling = profOpts | needDynamic = dynOpts | otherwise = staticOpts - compileOpts - | useDynToo = dynTooOpts - | otherwise = commonOpts - withStaticExe = not needProfiling && not needDynamic - - -- For building exe's that use TH with -prof or -dynamic we actually have - -- to build twice, once without -prof/-dynamic and then again with - -- -prof/-dynamic. This is because the code that TH needs to run at - -- compile time needs to be the vanilla ABI so it can be loaded up and run - -- by the compiler. - -- With dynamic-by-default GHC the TH object files loaded at compile-time - -- need to be .dyn_o instead of .o. - doingTH = usesTemplateHaskellOrQQ bnfo - -- Should we use -dynamic-too instead of compiling twice? - useDynToo = - dynamicTooSupported - && isGhcDynamic - && doingTH - && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts - | isGhcDynamic = dynOpts - | otherwise = staticOpts - compileForTH - | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ - runGhcProg - compileTHOpts - { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs - } - - -- Do not try to build anything if there are no input files. - -- This can happen if the cabal file ends up with only cSrcs - -- but no Haskell modules. - unless - ( (null inputFiles && null inputModules) - || gbuildIsRepl bm - ) - $ runGhcProg - compileOpts - { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs - } - runBuildM what lbi (TargetInfo clbi (gbuildComp bm)) buildAllExtraSources + runBuildM what lbi target (buildHaskellModules numJobs ghcProg pkg_descr tmpDir) + runBuildM what lbi target (buildAllExtraSources ghcProg) -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. case bm of - GReplExe _ _ -> runReplOrWriteFlags verbosity ghcProg comp platform replFlags replOpts bnfo clbi (pkgName (PD.package pkg_descr)) - GReplFLib _ _ -> runReplOrWriteFlags verbosity ghcProg comp platform replFlags replOpts bnfo clbi (pkgName (PD.package pkg_descr)) + GReplExe _ _ -> runReplOrWriteFlags ghcProg lbi replFlags replOpts target (pkgName (PD.package pkg_descr)) + GReplFLib _ _ -> runReplOrWriteFlags ghcProg lbi replFlags replOpts target (pkgName (PD.package pkg_descr)) GBuildExe _ -> do let linkOpts = commonOpts @@ -597,11 +489,11 @@ gbuild what numJobs pkg_descr lbi bm clbi = do info verbosity "Linking..." -- Work around old GHCs not relinking in this -- situation, see #3294 - let target = targetDir targetName + let target' = targetDir targetName when (compilerVersion comp < mkVersion [7, 7]) $ do - e <- doesFileExist target - when e (removeFile target) - runGhcProg linkOpts{ghcOptOutputFile = toFlag target} + e <- doesFileExist target' + when e (removeFile target') + runGhcProg linkOpts{ghcOptOutputFile = toFlag target'} GBuildFLib flib -> do let -- Instruct GHC to link against libHSrts. diff --git a/Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs b/Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs index 1f87d081107..8123112dd1a 100644 --- a/Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs +++ b/Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs @@ -6,17 +6,13 @@ import Prelude () import qualified Distribution.ModuleName as ModuleName import Distribution.Package import Distribution.PackageDescription as PD -import Distribution.Simple.Build.ExtraSources +import Distribution.Simple.GHC.Build.ExtraSources import Distribution.Simple.Build.Monad import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.GHC.Build - ( componentGhcOptions - , getRPaths - , isDynamic - , replNoLoad + ( replNoLoad , runReplOrWriteFlags - , supportsDynamicToo ) import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal @@ -26,14 +22,13 @@ import Distribution.Simple.Program import qualified Distribution.Simple.Program.Ar as Ar import Distribution.Simple.Program.GHC import qualified Distribution.Simple.Program.Ld as Ld -import Distribution.Simple.Setup.Build import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Repl import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ParStrat -import Distribution.Types.TargetInfo +import Distribution.Simple.GHC.Build.Modules import Distribution.Utils.NubList import Distribution.Version import System.Directory @@ -44,6 +39,7 @@ import System.FilePath ( replaceExtension , () ) +import Distribution.Simple.GHC.Build.Link buildOrReplLib :: BuildingWhat @@ -65,7 +61,7 @@ buildOrReplLib what numJobs pkg_descr lbi lib clbi = do when (forceStatic || withStaticLib lbi) whenGHCiLib = when (withGHCiLib lbi) forRepl = case what of BuildRepl{} -> True; _ -> False - whenReplLib f = case what of BuildRepl flags -> f (replReplOptions flags); _ -> pure () + whenReplLib f = case what of BuildRepl flags -> f flags; _ -> pure () replFlags = case what of BuildRepl flags -> replReplOptions flags; _ -> mempty comp = compiler lbi ghcVersion = compilerVersion comp @@ -74,6 +70,7 @@ buildOrReplLib what numJobs pkg_descr lbi lib clbi = do hasJsSupport = hostArch == JavaScript has_code = not (componentIsIndefinite clbi) verbosity = buildingWhatVerbosity what + target = TargetInfo clbi (CLib lib) relLibTargetDir <- makeRelativeToCurrentDirectory libTargetDir @@ -86,13 +83,6 @@ buildOrReplLib what numJobs pkg_descr lbi lib clbi = do cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs libBi) cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic libBi) - let isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = usesTemplateHaskellOrQQ libBi - forceVanillaLib = doingTH && not isGhcDynamic - forceSharedLib = doingTH && isGhcDynamic - -- TH always needs default libs, even when building for profiling - -- Determine if program coverage should be enabled and if so, what -- '-hpcdir' should be. let isCoverageEnabled = libCoverage lbi @@ -120,7 +110,7 @@ buildOrReplLib what numJobs pkg_descr lbi lib clbi = do else mempty ] cLikeObjs = map (`replaceExtension` objExtension) cLikeSources - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + baseOpts = Internal.componentGhcOptions verbosity lbi libBi clbi libTargetDir vanillaOpts = baseOpts `mappend` mempty @@ -130,30 +120,6 @@ buildOrReplLib what numJobs pkg_descr lbi lib clbi = do , ghcOptHPCDir = hpcdir Hpc.Vanilla } - profOpts = - vanillaOpts - `mappend` mempty - { ghcOptProfilingMode = toFlag True - , ghcOptProfilingAuto = - Internal.profDetailLevelFlag - True - (withProfLibDetail lbi) - , ghcOptHiSuffix = toFlag "p_hi" - , ghcOptObjSuffix = toFlag "p_o" - , ghcOptExtra = hcProfOptions GHC libBi - , ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = - vanillaOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcDynamicOnly - , ghcOptFPic = toFlag True - , ghcOptHiSuffix = toFlag "dyn_hi" - , ghcOptObjSuffix = toFlag "dyn_o" - , ghcOptExtra = hcSharedOptions GHC libBi - , ghcOptHPCDir = hpcdir Hpc.Dyn - } linkerOpts = mempty { ghcOptLinkOptions = @@ -201,54 +167,16 @@ buildOrReplLib what numJobs pkg_descr lbi lib clbi = do isInteractive = toFlag GhcModeInteractive - vanillaSharedOpts = - vanillaOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic - , ghcOptDynHiSuffix = toFlag "dyn_hi" - , ghcOptDynObjSuffix = toFlag "dyn_o" - , ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi)) $ - do - let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) - useDynToo = - dynamicTooSupported - && (forceVanillaLib || withVanillaLib lbi) - && (forceSharedLib || withSharedLib lbi) - && null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Flag dynDir, Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir - _ -> return () - else - if isGhcDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcProg profOpts) - runBuildM what lbi (TargetInfo clbi (CLib lib)) buildAllExtraSources + runBuildM what lbi target (buildHaskellModules numJobs ghcProg pkg_descr libTargetDir) + runBuildM what lbi target (buildAllExtraSources ghcProg) -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. whenReplLib $ \rflags -> do when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts libBi clbi (pkgName (PD.package pkg_descr)) + runReplOrWriteFlags ghcProg lbi rflags replOpts target (pkgName (PD.package pkg_descr)) -- link: when has_code . unless forRepl $ do @@ -349,7 +277,7 @@ buildOrReplLib what numJobs pkg_descr lbi lib clbi = do else return [] unless (null hObjs && null cLikeObjs && null stubObjs) $ do - rpaths <- getRPaths lbi clbi + rpaths <- runBuildM what lbi target getRPaths let staticObjectFiles = hObjs diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index 893d23210bf..4c7290aae48 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -507,13 +507,14 @@ componentJsGhcOptions verbosity lbi bi clbi odir filename = componentGhcOptions :: Verbosity - -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions -componentGhcOptions verbosity implInfo lbi bi clbi odir = +componentGhcOptions verbosity lbi bi clbi odir = + let implInfo = getImplInfo $ compiler lbi + in mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs index 43ef50ba82c..98daaabf981 100644 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ b/Cabal/src/Distribution/Simple/GHCJS.hs @@ -1777,9 +1777,7 @@ componentGhcOptions -> FilePath -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = - let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir - comp = compiler lbi - implInfo = getImplInfo comp + let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi }