diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 17191faa46e..f34feb53b2d 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -336,8 +336,6 @@ library 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 6fa18c0d487..82816b1e2b4 100644 --- a/Cabal/src/Distribution/Simple/Build/Monad.hs +++ b/Cabal/src/Distribution/Simple/Build/Monad.hs @@ -87,6 +87,7 @@ buildLBI :: BuildM LocalBuildInfo buildLBI = asks localBuildInfo {-# INLINE buildLBI #-} +-- | Get the @'Compiler'@ being used to build the component. buildCompiler :: BuildM Compiler buildCompiler = compiler <$> buildLBI {-# INLINE buildCompiler #-} @@ -94,4 +95,5 @@ buildCompiler = compiler <$> buildLBI -- | Get the @'TargetInfo'@ of the current component being built. buildTarget :: BuildM TargetInfo buildTarget = asks targetInfo +{-# INLINE buildTarget #-} diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 82231e5aa9a..2fee627039e 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -93,6 +93,8 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors import Distribution.Simple.Flag (Flag (..), toFlag) +import qualified Distribution.Simple.GHC.Build as GHC +import Distribution.Simple.Build.Monad (runBuildM) import Distribution.Simple.GHC.Build.Utils import Distribution.Simple.GHC.EnvironmentParser import Distribution.Simple.GHC.ImplInfo @@ -131,13 +133,10 @@ import System.FilePath ) import qualified System.Info #ifndef mingw32_HOST_OS -import Distribution.Simple.GHC.Build.Utils (flibBuildName) import System.Directory (renameFile) import System.Posix (createSymbolicLink) #endif /* mingw32_HOST_OS */ -import Distribution.Simple.GHC.BuildGeneric (GBuildMode (..), gbuild) -import Distribution.Simple.GHC.BuildOrRepl (buildOrReplLib) import Distribution.Simple.Setup (BuildingWhat (..)) import Distribution.Simple.Setup.Build @@ -567,7 +566,8 @@ buildLib -> Library -> ComponentLocalBuildInfo -> IO () -buildLib = buildOrReplLib . BuildNormal +buildLib flags numJobs pkg lbi lib clbi + = runBuildM (BuildNormal flags) lbi (TargetInfo clbi (CLib lib)) (GHC.build numJobs pkg) replLib :: ReplFlags @@ -577,7 +577,8 @@ replLib -> Library -> ComponentLocalBuildInfo -> IO () -replLib = buildOrReplLib . BuildRepl +replLib flags numJobs pkg lbi lib clbi + = runBuildM (BuildRepl flags) lbi (TargetInfo clbi (CLib lib)) (GHC.build numJobs pkg) -- | Start a REPL without loading any source files. startInterpreter @@ -609,7 +610,8 @@ buildFLib -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib v njobs pkg lbi = gbuild (BuildNormal mempty{buildVerbosity = toFlag v}) njobs pkg lbi . GBuildFLib +buildFLib v njobs pkg lbi flib clbi + = runBuildM (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CFLib flib)) (GHC.build njobs pkg) replFLib :: ReplFlags @@ -619,8 +621,8 @@ replFLib -> ForeignLib -> ComponentLocalBuildInfo -> IO () -replFLib replFlags njobs pkg lbi = - gbuild (BuildRepl replFlags) njobs pkg lbi . GReplFLib replFlags +replFLib replFlags njobs pkg lbi flib clbi + = runBuildM (BuildRepl replFlags) lbi (TargetInfo clbi (CFLib flib)) (GHC.build njobs pkg) -- | Build an executable with GHC. buildExe @@ -631,7 +633,8 @@ buildExe -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe v njobs pkg lbi = gbuild (BuildNormal mempty{buildVerbosity = toFlag v}) njobs pkg lbi . GBuildExe +buildExe v njobs pkg lbi exe clbi + = runBuildM (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CExe exe)) (GHC.build njobs pkg) replExe :: ReplFlags @@ -641,8 +644,8 @@ replExe -> Executable -> ComponentLocalBuildInfo -> IO () -replExe replFlags njobs pkg lbi = - gbuild (BuildRepl replFlags) njobs pkg lbi . GReplExe replFlags +replExe replFlags njobs pkg lbi exe clbi + = runBuildM (BuildRepl replFlags) lbi (TargetInfo clbi (CExe exe)) (GHC.build njobs pkg) -- | Extracts a String representing a hash of the ABI of a built -- library. It can fail if the library has not yet been built. @@ -724,7 +727,7 @@ installExe exe = do createDirectoryIfMissingVerbose verbosity True binDir let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeTargetName (hostPlatform lbi) exe + exeFileName = exeTargetName (hostPlatform lbi) (exeName exe) fixedExeBaseName = progprefix ++ exeName' ++ progsuffix installBinary dest = do installExecutableFile diff --git a/Cabal/src/Distribution/Simple/GHC/Build.hs b/Cabal/src/Distribution/Simple/GHC/Build.hs index 6eb4769dfa4..1b9eb60e346 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build.hs @@ -6,38 +6,49 @@ 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 hiding (buildInfo) -import qualified Distribution.PackageDescription as PD -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.Pretty -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.Flag (Flag (..), fromFlag, fromFlagOrDefault) -import Distribution.Simple.GHC.ImplInfo -import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.Flag (Flag) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup.Repl import Distribution.Simple.Utils -import Distribution.System -import Distribution.Utils.NubList -import Distribution.Utils.Path (getSymbolicPath) -import Distribution.Verbosity -import Distribution.Version import System.Directory hiding (exeExtension) import System.FilePath import Distribution.Simple.Build.Monad import Distribution.Simple.GHC.Build.ExtraSources import Distribution.Simple.GHC.Build.Modules +import Distribution.Simple.GHC.Build.Link import Distribution.Types.ParStrat -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.Setup.Common (extraCompilationArtifacts) +import qualified Data.Set as Set + +{- +Note [Build Target Dir vs Target Dir] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +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). +-} -- | The main build phase of building a component. -- Includes building Haskell modules, extra build sources, and linking. @@ -46,42 +57,14 @@ build :: Flag ParStrat -> 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). - -} + -- See Note [Build Target Dir vs Target Dir] let targetDir_absolute = componentBuildDir lbi clbi buildTargetDir_absolute -- Libraries use the target dir for building (see above) @@ -101,71 +84,49 @@ build numJobs pkg_descr = do (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 - -runReplOrWriteFlags - :: ConfiguredProgram - -> LocalBuildInfo - -> ReplFlags - -> GhcOptions - -> TargetInfo - -> PackageName - -> IO () -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 - this_unit = prettyShow uid - reexported_modules = [mn | LibComponentLocalBuildInfo{} <- [clbi], IPI.ExposedModule mn (Just{}) <- componentExposedModules clbi] - hidden_modules = otherModules bi - extra_opts = - concat $ - [ ["-this-package-name", prettyShow pkg_name] - , ["-working-dir", src_dir] - ] - ++ [ ["-reexported-module", prettyShow m] | m <- reexported_modules - ] - ++ [ ["-hidden-module", prettyShow m] | m <- hidden_modules - ] - -- Create "paths" subdirectory if it doesn't exist. This is where we write - -- information about how the PATH was augmented. - createDirectoryIfMissing False (out_dir "paths") - -- Write out the PATH information into `paths` subdirectory. - writeFileAtomic (out_dir "paths" this_unit) (encode ghcProg) - -- Write out options for this component into a file ready for loading into - -- the multi-repl - writeFileAtomic (out_dir this_unit) $ - BS.pack $ - escapeArgs $ - extra_opts ++ renderGhcOptions comp platform (ghcOpts{ghcOptMode = NoFlag}) + let + -- 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 + + -- See also Note [Building Haskell Modules accounting for TH] in Distribution.Simple.GHC.Build.Modules + 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... + -- ROMES:TODO: Perhaps for executables we want to limit the "wanted" + -- ways to just one? + + -- ROMES:TODO: From #3294, this may now be possible, after the refactor? + -- In the case that there are no C source files that depend on FFI exports, I + -- think there is one more way that this can be fixed: we should revert to + -- pre-#842 and do compilation and linking in one go. This will obviously make + -- the GHC code more complicated, but I suspect it will pay its way: we'll + -- also get faster compilation for new versions of GHC since we don't have to + -- call GHC twice. Duncan previously claimed that the performance hit from + -- calling GHC a second time should not be large, but actually there is a + -- substantial performance hit when module graphs are large, as GHC recomputes + -- the module graph on every computation (one of the reasons why Shake is so + -- much faster.) + + -- We need a separate build and link phase, and C sources must be compiled + -- after Haskell modules, because C sources may depend on stub headers + -- generated from compiling Haskell modules (#842). + (vanillaOpts, wantedWaysMap) + <- buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir wantedWays + extraSources <- buildAllExtraSources ghcProg + linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) vanillaOpts wantedWaysMap + diff --git a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs index c101d5cab6a..83d04ff2856 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -23,6 +23,8 @@ import Distribution.Types.Executable import Distribution.Verbosity (Verbosity) import System.FilePath import Distribution.Simple.Program.Types +import Distribution.System (Platform(..), Arch(JavaScript)) +import Distribution.Types.ComponentLocalBuildInfo import Distribution.Simple.Build.Monad @@ -30,9 +32,12 @@ import Distribution.Simple.Build.Monad -- C++, Js, Asm, C-- sources. buildAllExtraSources :: ConfiguredProgram -- ^ The GHC configured program - -> BuildM () + -> BuildM [FilePath] + -- ^ Returns the list of extra sources that were built buildAllExtraSources = - sequence_ . sequence + fmap concat + . sequence + . sequence [ buildCSources , buildCxxSources , buildJsSources @@ -40,13 +45,6 @@ buildAllExtraSources = , buildCmmSources ] --- ROMES:TODO: --- unless (not hasJsSupport || null jsSrcs) $ ... and (not has_code) --- where has_code = not (componentIsIndefinite clbi) - --- 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 ... - buildCSources , buildCxxSources , buildJsSources @@ -54,13 +52,8 @@ buildCSources , buildCmmSources :: 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 --- may also be provided in standalone packages, since nothing precludes users --- from writing their own build rules for declared foreign modules in main-is --- and eventually custom stanzas. + -> BuildM [FilePath] + -- ^ Returns the list of extra sources that were built buildCSources = buildExtraSources "C Sources" @@ -83,12 +76,24 @@ buildCxxSources = CExe exe | isCxx (modulePath exe) -> [modulePath exe] _otherwise -> [] ) -buildJsSources = +buildJsSources ghcProg = do + Platform hostArch _ <- hostPlatform <$> buildLBI + let hasJsSupport = hostArch == JavaScript buildExtraSources "JS Sources" Internal.componentJsGhcOptions False - (jsSources . componentBuildInfo) + ( \c -> + if hasJsSupport + then -- JS files are C-like with GHC's JS backend: they are + -- "compiled" into `.o` files (renamed with a header). + -- This is a difference from GHCJS, for which we only + -- pass the JS files at link time. + jsSources (componentBuildInfo c) + else mempty + + ) + ghcProg buildAsmSources = buildExtraSources "Assembler Sources" @@ -123,7 +128,8 @@ buildExtraSources -- if it should be compiled as the rest of them. -> ConfiguredProgram -- ^ The GHC configured program - -> BuildM () + -> BuildM [FilePath] + -- ^ Returns the list of extra sources that were built buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcProg = BuildM \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> let @@ -138,9 +144,9 @@ buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcP isGhcDynamic = isDynamic comp doingTH = usesTemplateHaskellOrQQ bi forceSharedLib = doingTH && isGhcDynamic + runGhcProg = runGHC verbosity ghcProg comp platform buildAction sourceFile = do - let runGhcProg = runGHC verbosity ghcProg comp platform let baseSrcOpts = componentSourceGhcOptions @@ -198,7 +204,7 @@ buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcP -- For foreign libraries, we determine with which options to build the -- objects (vanilla vs shared vs profiled) CFLib flib - | withProfExe lbi -> -- ROMES: hmm... doesn't sound right. + | withProfExe lbi -> -- ROMES: doesn't sound right "ProfExe" for FLib... compileIfNeeded profSrcOpts | flibIsDynamic flib -> compileIfNeeded sharedSrcOpts @@ -227,6 +233,9 @@ buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcP componentNameRaw cname <> "-tmp" in do -- build any sources - unless (null sources) $ do + if (null sources || componentIsIndefinite clbi) then do info verbosity ("Building " ++ description ++ "...") traverse_ buildAction sources + return sources + else + return [] diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs new file mode 100644 index 00000000000..3b0ac5ca988 --- /dev/null +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -0,0 +1,620 @@ +{-# LANGUAGE LambdaCase #-} +module Distribution.Simple.GHC.Build.Link where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Exception (assert) +import Data.Function ((&)) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Compat.ResponseFile +import qualified Data.ByteString.Lazy.Char8 as BS +import Distribution.Compat.Binary (encode) +import Control.Monad (forM_) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +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.Monad +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.LocalBuildInfo +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Repl +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Utils.NubList +import Distribution.Verbosity +import Distribution.Version +import System.Directory +import System.FilePath +import Distribution.Simple.GHC.ImplInfo +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Simple.GHC.Build.Modules +import qualified Distribution.Simple.Program.Ar as Ar +import Distribution.Simple.GHC.Build.Utils (exeTargetName, flibBuildName, flibTargetName) +import qualified Distribution.Simple.Program.Ld as Ld +import Control.Monad.IO.Class +import qualified Data.Map as Map + +-- | Links together the object files of the Haskell modules and extra sources +-- using the context in which the component is being built. +-- +-- If the build kind is 'BuildRepl', we load the component into GHCi instead of linking. +linkOrLoadComponent :: ConfiguredProgram + -- ^ The configured GHC program that will be used for linking + -> PackageDescription + -- ^ The package description containing the component being built + -> [FilePath] + -- ^ The full list of extra build sources (all C, C++, Js, + -- Asm, and Cmm sources), which were compiled to object + -- files. + -> (FilePath, FilePath) + -- ^ The build target dir, and the target dir. + -- See Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build + -> GhcOptions + -- ^ The vanilla base options used across build invocations + -- of GHC, which may be used for loading the component in the repl. + -> Map.Map BuildWay GhcOptions + -- ^ The set of build ways wanted based on the user opts + -> BuildM () +linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) vanillaOpts wantedWaysMap = do + verbosity <- buildVerbosity + target <- buildTarget + component <- buildComponent + what <- buildWhat + lbi <- buildLBI + bi <- buildBI + clbi <- buildCLBI + + -- ensure extra lib dirs exist before passing to ghc + cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs bi) & liftIO + cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic bi) & liftIO + + let + extraSourcesObjs = map (`replaceExtension` objExtension) extraSources + + linkerOpts = + mempty + { ghcOptLinkOptions = + PD.ldOptions bi + ++ [ "-static" + | withFullyStaticExe lbi -- ROMES:TODO: wb withStaticLib?? + ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + -- ROMES:TODO: Why not for the dyn linker opts too? + ++ maybe + [] + programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)) + , ghcOptLinkLibs = + -- ROMES:TODO: Looks wrong, why would we only check for fully + -- static exec, when we could be building libs or foreign libs? + if withFullyStaticExe lbi + then extraLibsStatic bi + else extraLibs bi + , ghcOptLinkLibPath = + toNubListR $ + -- ROMES:TODO: wb withStaticLib?? + if withFullyStaticExe lbi + then cleanedExtraLibDirsStatic + else cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks bi + , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi + , ghcOptInputFiles = toNubListR [buildTargetDir x | x <- extraSourcesObjs] + } + case what of + BuildRepl replFlags -> liftIO $ do + let + replOpts = + vanillaOpts + { ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra vanillaOpts) + <> replOptionsFlags (replReplOptions replFlags) + , ghcOptInputModules = replNoLoad (replReplOptions replFlags) (ghcOptInputModules vanillaOpts) + , ghcOptInputFiles = replNoLoad (replReplOptions replFlags) (ghcOptInputFiles vanillaOpts) + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptOptimisation = toFlag GhcNoOptimisation + } + + -- 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. + when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $ warn verbosity "No exposed modules" + runReplOrWriteFlags ghcProg lbi replFlags replOpts (pkgName (PD.package pkg_descr)) target + + _otherwise -> + let + runGhcProg = runGHC verbosity ghcProg comp platform + platform = hostPlatform lbi + comp = compiler lbi + in when (not $ componentIsIndefinite clbi) $ do + rpaths <- if DynWay `elem` Map.keys wantedWaysMap then getRPaths else return (toNubListR []) + liftIO $ do + info verbosity "Linking..." + case component of + CLib lib -> linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWaysMap + CFLib flib -> linkFLib flib bi lbi (linkerOpts, rpaths) wantedWaysMap targetDir runGhcProg + CExe exe -> linkExecutable (linkerOpts, rpaths) wantedWaysMap targetDir (exeName exe) runGhcProg lbi + CTest test -> linkExecutable (linkerOpts, rpaths) wantedWaysMap targetDir (testName test) runGhcProg lbi + CBench bench -> linkExecutable (linkerOpts, rpaths) wantedWaysMap targetDir (benchmarkName bench) runGhcProg lbi + +-- ROMES:TODO: This module can still be very much refactored. I'm pretty sure we +-- can merge all implementations of link for each component into one simpler +-- one, and that we don't need to pass the path to each object file in each way +-- to the linker invocation. GHC can probably find the right object files to +-- link based on the suffix prefix. + +linkLibrary :: FilePath + -- ^ The library target build directory + -> [FilePath] + -- ^ The list of extra lib dirs that exist (aka cleaned) + -> PackageDescription + -- ^ The package description containing this library + -> Verbosity + -> (GhcOptions -> IO ()) + -- ^ Run the configured Ghc program + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> [FilePath] + -- ^ Extra build sources (that were compiled to objects) + -> NubListR FilePath + -- ^ A list with the runtime-paths (rpaths), or empty if not linking dynamically + -> Map.Map BuildWay GhcOptions + -- ^ Wanted build ways and corresponding build options + -> IO () +linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWaysMap = do + let + compiler_id = compilerId comp + comp = compiler lbi + ghcVersion = compilerVersion comp + implInfo = getImplInfo comp + uid = componentUnitId clbi + libBi = libBuildInfo lib + Platform _hostArch hostOS = hostPlatform lbi + vanillaLibFilePath = buildTargetDir mkLibName uid + profileLibFilePath = buildTargetDir mkProfLibName uid + sharedLibFilePath = + buildTargetDir + mkSharedLibName (hostPlatform lbi) compiler_id uid + staticLibFilePath = + buildTargetDir + mkStaticLibName (hostPlatform lbi) compiler_id uid + ghciLibFilePath = buildTargetDir Internal.mkGHCiLibName uid + ghciProfLibFilePath = buildTargetDir Internal.mkGHCiProfLibName uid + libInstallPath = + libdir $ + absoluteComponentInstallDirs + pkg_descr + lbi + uid + NoCopyDest + sharedLibInstallPath = + libInstallPath + mkSharedLibName (hostPlatform lbi) compiler_id uid + + getObjFiles way = concat <$> sequenceA + [ Internal.getHaskellObjects + implInfo + lib + lbi + clbi + buildTargetDir + (buildWayPrefix way ++ objExtension) + True + , pure $ + map (buildTargetDir ) $ + map ((`replaceExtension` (buildWayPrefix way ++ objExtension))) extraSources + , catMaybes <$> sequenceA + [ findFileWithExtension + [buildWayPrefix way ++ objExtension] + [buildTargetDir] + (ModuleName.toFilePath x ++ "_stub") + | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi + ] + ] + + -- ROMES:TODO: I'm fairly certain that, just like the executable, we can keep just the + -- module input list, and point to the right output dir (as is already + -- done), and GHC will pick up the right suffix (p_ for profile, dyn_ when + -- -shared...). That would mean the size of linking the lib would be just + -- like the executable, and we could merge the two. + + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs dynOpts dynObjectFiles = + dynOpts + { ghcOptMode = toFlag GhcModeLink + , ghcOptShared = toFlag True + , ghcOptInputFiles = toNubListR dynObjectFiles + , ghcOptOutputFile = toFlag sharedLibFilePath + , -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. This only applies to GHC < 7.8 - see the + -- discussion in #1660. + ghcOptDylibName = + if hostOS == OSX + && ghcVersion < mkVersion [7, 8] + then toFlag sharedLibInstallPath + else mempty + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths + } + ghcStaticLinkArgs staticOpts staticObjectFiles = + staticOpts + { ghcOptMode = toFlag GhcModeLink + , ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs -- ROMES:TODO: why not extra dirs static??? + } + -- ROMES:TODO: Try to figure out if we could do the same "commonOpt `mappend` linkerOpts" as we do for repl here + + staticObjectFiles <- getObjFiles StaticWay + profObjectFiles <- getObjFiles ProfWay + dynamicObjectFiles <- getObjFiles DynWay + + let + linkWay = \case + (VanillaWay, _vanillaOpts) -> do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + when (withGHCiLib lbi) $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles + verbosity + lbi + ldProg + ghciLibFilePath + staticObjectFiles + (ProfWay, _profOpts) -> do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + when (withGHCiLib lbi) $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles + verbosity + lbi + ldProg + ghciProfLibFilePath + profObjectFiles + (DynWay, dynOpts) -> do + runGhcProg $ ghcSharedLinkArgs dynOpts dynamicObjectFiles + (StaticWay, staticOpts) -> + runGhcProg $ ghcStaticLinkArgs staticOpts staticObjectFiles + + -- ROMES: Why exactly branch on staticObjectFiles, rather than any other build + -- kind that we might have wanted instead? + unless (null staticObjectFiles) $ do + + info verbosity (show (ghcOptPackages (Internal.componentGhcOptions verbosity lbi libBi clbi buildTargetDir))) + + traverse_ linkWay (Map.toList wantedWaysMap) + + +-- ROMES:TODO: Have to be careful about target dir vs build dir here! They are +-- not the same on exes, and we don't want to conflate them for now, even +-- though we want to drop the distinction eventually. + +-- | Link the executable resulting from building this component, be it an +-- executable, test, or benchmark component. +linkExecutable :: (GhcOptions, NubListR FilePath) + -- ^ The linker-specific GHC options, and the RPaths to include + -- in dynamically linked binaries + -> Map.Map BuildWay GhcOptions + -- ^ The wanted build ways and corresponding GhcOptions that were + -- used to compile the modules in that way. + -> FilePath + -- ^ The target dir (2024-01:note: not the same as build target + -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build) + -> UnqualComponentName + -- ^ Name of executable-like target + -> (GhcOptions -> IO ()) + -- ^ Run the configured GHC program + -> LocalBuildInfo + -> IO () +linkExecutable (linkerOpts, rpaths) wantedWaysMap targetDir targetName runGhcProg lbi = + -- When building an executable, we should only "want" one build way. + assert (Map.size wantedWaysMap == 1) $ + forM_ wantedWaysMap $ \opts -> do + let linkOpts = + opts + `mappend` linkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles opts == mempty) + } + & (if withDynExe lbi then \x -> x{ghcOptRPaths = rpaths} else id) + comp = compiler lbi + + -- Work around old GHCs not relinking in this + -- situation, see #3294 + let target = targetDir exeTargetName (hostPlatform lbi) targetName + when (compilerVersion comp < mkVersion [7, 7]) $ do + e <- doesFileExist target + when e (removeFile target) + runGhcProg linkOpts{ghcOptOutputFile = toFlag target} + + +-- | Link a foreign library component +linkFLib :: ForeignLib -> BuildInfo -> LocalBuildInfo + -> (GhcOptions, NubListR FilePath) + -- ^ The linker-specific GHC options, and the RPaths to include + -- in dynamically linked binaries + -> Map.Map BuildWay GhcOptions + -- ^ The wanted build ways and corresponding GhcOptions that were + -- used to compile the modules in that way. + -> FilePath + -- ^ The target dir (2024-01:note: not the same as build target + -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build) + -> (GhcOptions -> IO ()) + -- ^ Run the configured GHC program + -> IO () +linkFLib flib bi lbi (linkerOpts, rpaths) wantedWaysMap targetDir runGhcProg = do + let + comp = compiler lbi + + -- Instruct GHC to link against libHSrts. + rtsLinkOpts :: BuildWay -> GhcOptions + rtsLinkOpts way + | supportsFLinkRts = + mempty + { ghcOptLinkRts = toFlag True + } + | otherwise = + mempty + { ghcOptLinkLibs = rtsOptLinkLibs + , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo + } + where + threaded = hasThreaded bi + supportsFLinkRts = compilerVersion comp >= mkVersion [9, 0] + rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = + [ if way == DynWay + then + if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else + if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] + + linkOpts :: (BuildWay, GhcOptions) + -- ^ Opts for the way in which we want to build the FLib + -> GhcOptions + linkOpts (way,opts) = case foreignLibType flib of + ForeignLibNativeShared -> + opts + `mappend` linkerOpts + `mappend` rtsLinkOpts way + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag True + , ghcOptShared = toFlag True + , ghcOptFPic = toFlag True + , ghcOptLinkModDefFiles = toNubListR $ foreignLibModDefFile flib + } + & (if withDynExe lbi then \x -> x{ghcOptRPaths = rpaths} else id) + ForeignLibNativeStatic -> + -- this should be caught by buildFLib + -- (and if we do implement this, we probably don't even want to call + -- ghc here, but rather Ar.createArLibArchive or something) + cabalBug "static libraries not yet implemented" + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + -- We build under a (potentially) different filename to set a + -- soname on supported platforms. See also the note for + -- @flibBuildName@. + let buildName = flibBuildName lbi flib + assert (Map.size wantedWaysMap == 1) $ + forM_ (Map.toList wantedWaysMap) $ \opts -> do + runGhcProg (linkOpts opts){ghcOptOutputFile = toFlag (targetDir buildName)} + renameFile (targetDir buildName) (targetDir flibTargetName lbi flib) + +-- | Calculate the RPATHs for the component we are building. +-- +-- Calculates relative RPATHs when 'relocatable' is set. +getRPaths :: BuildM (NubListR FilePath) +getRPaths = do + lbi <- buildLBI + clbi <- buildCLBI + + let + (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. + + if supportRPaths hostOS + then do + libraryPaths <- liftIO $ 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 + else + return mempty + +data DynamicRtsInfo = DynamicRtsInfo + { dynRtsVanillaLib :: FilePath + , dynRtsThreadedLib :: FilePath + , dynRtsDebugLib :: FilePath + , dynRtsEventlogLib :: FilePath + , dynRtsThreadedDebugLib :: FilePath + , dynRtsThreadedEventlogLib :: FilePath + } + +data StaticRtsInfo = StaticRtsInfo + { statRtsVanillaLib :: FilePath + , statRtsThreadedLib :: FilePath + , statRtsDebugLib :: FilePath + , statRtsEventlogLib :: FilePath + , statRtsThreadedDebugLib :: FilePath + , statRtsThreadedEventlogLib :: FilePath + , statRtsProfilingLib :: FilePath + , statRtsThreadedProfilingLib :: FilePath + } + +data RtsInfo = RtsInfo + { rtsDynamicInfo :: DynamicRtsInfo + , rtsStaticInfo :: StaticRtsInfo + , rtsLibPaths :: [FilePath] + } + +-- | Extract (and compute) information about the RTS library +-- +-- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can +-- find this information somewhere. We can lookup the 'hsLibraries' field of +-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which +-- doesn't really help. +extractRtsInfo :: LocalBuildInfo -> RtsInfo +extractRtsInfo lbi = + case PackageIndex.lookupPackageName + (installedPkgs lbi) + (mkPackageName "rts") of + [(_, [rts])] -> aux rts + _otherwise -> error "No (or multiple) ghc rts package is registered" + where + aux :: InstalledPackageInfo -> RtsInfo + aux rts = + RtsInfo + { rtsDynamicInfo = + DynamicRtsInfo + { dynRtsVanillaLib = withGhcVersion "HSrts" + , dynRtsThreadedLib = withGhcVersion "HSrts_thr" + , dynRtsDebugLib = withGhcVersion "HSrts_debug" + , dynRtsEventlogLib = withGhcVersion "HSrts_l" + , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" + , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" + } + , rtsStaticInfo = + StaticRtsInfo + { statRtsVanillaLib = "HSrts" + , statRtsThreadedLib = "HSrts_thr" + , statRtsDebugLib = "HSrts_debug" + , statRtsEventlogLib = "HSrts_l" + , statRtsThreadedDebugLib = "HSrts_thr_debug" + , statRtsThreadedEventlogLib = "HSrts_thr_l" + , statRtsProfilingLib = "HSrts_p" + , statRtsThreadedProfilingLib = "HSrts_thr_p" + } + , rtsLibPaths = InstalledPackageInfo.libraryDirs rts + } + withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) + +-- | Determine whether the given 'BuildInfo' is intended to link against the +-- threaded RTS. This is used to determine which RTS to link against when +-- building a foreign library with a GHC without support for @-flink-rts@. +hasThreaded :: BuildInfo -> Bool +hasThreaded bi = elem "-threaded" ghc + where + PerCompilerFlavor ghc _ = options bi + + +-- | Load a target component into a repl, or write to disk a script which runs +-- GHCi with the GHC options Cabal elaborated to load the component interactively. +runReplOrWriteFlags + :: ConfiguredProgram + -> LocalBuildInfo + -> ReplFlags + -> GhcOptions + -> PackageName + -> TargetInfo + -> IO () +runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target = + 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 + this_unit = prettyShow uid + reexported_modules = [mn | LibComponentLocalBuildInfo{} <- [clbi], IPI.ExposedModule mn (Just{}) <- componentExposedModules clbi] + hidden_modules = otherModules bi + extra_opts = + concat $ + [ ["-this-package-name", prettyShow pkg_name] + , ["-working-dir", src_dir] + ] + ++ [ ["-reexported-module", prettyShow m] | m <- reexported_modules + ] + ++ [ ["-hidden-module", prettyShow m] | m <- hidden_modules + ] + -- Create "paths" subdirectory if it doesn't exist. This is where we write + -- information about how the PATH was augmented. + createDirectoryIfMissing False (out_dir "paths") + -- Write out the PATH information into `paths` subdirectory. + writeFileAtomic (out_dir "paths" this_unit) (encode ghcProg) + -- Write out options for this component into a file ready for loading into + -- the multi-repl + writeFileAtomic (out_dir this_unit) $ + BS.pack $ + escapeArgs $ + extra_opts ++ renderGhcOptions comp platform (ghcOpts{ghcOptMode = NoFlag}) + +replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a +replNoLoad replFlags l + | replOptionsNoLoad replFlags == Flag True = mempty + | otherwise = l + diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs index 272e80358b6..7e24aa7f9d2 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs @@ -1,13 +1,15 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} module Distribution.Simple.GHC.Build.Modules - ( buildHaskellModules ) + ( buildHaskellModules, BuildWay(..), buildWayPrefix ) where import Distribution.Compat.Prelude import Control.Monad.IO.Class +import Data.Function ((&)) import Distribution.Types.ParStrat import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo @@ -26,6 +28,7 @@ import Distribution.Types.TestSuite import Distribution.Types.Benchmark import Distribution.Types.BuildInfo import qualified Data.Set as Set +import qualified Data.Map as Map import Data.List ((\\), sortOn) import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.ModuleName (ModuleName) @@ -41,9 +44,9 @@ 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 + * The static way (-static) + * The dynamic/shared way (-dynamic) + * The profiled way (-prof) 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. @@ -65,7 +68,7 @@ compile-time need to be .dyn_o instead of .o. 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 +dynamically, we want to make use of GHC's -static -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 @@ -98,9 +101,17 @@ buildHaskellModules :: Flag ParStrat -> FilePath -- ^ The path to the build directory for this target, which -- has already been created. - -> BuildM () + -> Set.Set BuildWay + -- ^ The set of wanted build ways according to user options + -> BuildM (GhcOptions, Map.Map BuildWay GhcOptions) + -- ^ Returns a mapping from the wanted build ways to the + -- GhcOptions used in the invocation to compile in each + -- wanted way, plus the base 'GhcOptions' used in each + -- invocation of GHC across build ways. The base options + -- may then be used for loading the component in the repl + -- as well. -- See Note [Building Haskell Modules accounting for TH] -buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir = do +buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir wantedWays = do verbosity <- buildVerbosity component <- buildComponent clbi <- buildCLBI @@ -135,92 +146,69 @@ buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir = do -- See Note [Building Haskell Modules accounting for TH] doingTH = usesTemplateHaskellOrQQ bi - baseOpts = Internal.componentGhcOptions verbosity lbi bi clbi buildTargetDir - vanillaOpts = - baseOpts + -- We define the base opts which are shared across different build ways in + -- 'buildHaskellModules', and also serves as the base options for loading + -- modules in 'linkOrLoadComponent' (hence we return them). + baseOpts way = + (Internal.componentGhcOptions verbosity lbi bi clbi buildTargetDir) `mappend` mempty { ghcOptMode = toFlag GhcModeMake , ghcOptNumJobs = numJobs , ghcOptInputModules = toNubListR inputModules , ghcOptInputFiles = + -- ROMES:TODO: Do we still need to do this? Couldn't the + -- inputFiles contain .c files? toNubListR $ if PD.package pkg_descr == fakePackageId then filter isHaskell inputFiles else inputFiles + -- ROMES:TODO: We're doing something wrong here, because + -- componentInputs doesn't return non-haskell inputFiles. + -- Re-think. , 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 + , ghcOptExtra = fromMaybe mempty (buildWayExtraHcOptions way) GHC bi } + -- We only want to add these options in if not building Vanilla. + -- Otherwise, we can omit them. + & if way == VanillaWay + then id + else + \x -> x{ ghcOptHiSuffix = toFlag (buildWayPrefix way ++ "hi") + , ghcOptObjSuffix = toFlag (buildWayPrefix way ++ "o") + , ghcOptHPCDir = hpcdir (buildWayHpcWay way) + } + + vanillaOpts = baseOpts VanillaWay + + staticOpts = (baseOpts StaticWay){ghcOptDynLinkMode = toFlag GhcStaticOnly} 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 - } + (baseOpts DynWay) + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + -- TODO: Does it hurt to set -fPIC for executables? + , ghcOptFPic = toFlag True + } profOpts = - vanillaOpts - `mappend` mempty + (baseOpts ProfWay) { 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 + dynTooOpts = (baseOpts DynWay){ghcOptDynLinkMode = toFlag GhcStaticAndDynamic} 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 $ + if (forRepl || (null inputFiles && null inputModules)) then 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 @@ -241,8 +229,8 @@ buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir = do 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. + -- be static or dynamic, so, if we build both right away, any modules + -- possibly needed by TH later (e.g. if building profiled) are already built. | useDynamicToo = [ buildStaticAndDynamicToo ] ++ (buildWay <$> Set.toList neededWays \\ [StaticWay, VanillaWay, DynWay]) @@ -251,11 +239,11 @@ buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir = do | 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 + buildWay way = uncurry Map.singleton . (way,) <$> case way of + StaticWay -> runGhcProg staticOpts >> return staticOpts + DynWay -> runGhcProg dynOpts >> return dynOpts + ProfWay -> runGhcProg profOpts >> return profOpts + VanillaWay -> runGhcProg vanillaOpts >> return vanillaOpts buildStaticAndDynamicToo = do runGhcProg dynTooOpts @@ -269,18 +257,47 @@ buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir = do -- both ways. copyDirectoryRecursive verbosity dynDir vanillaDir _ -> return () + return (Map.fromList [(StaticWay, staticOpts), (DynWay, dynOpts)]) - in sequence_ orderedBuilds + in (baseOpts VanillaWay,) . Map.unions <$> sequence orderedBuilds + else + return mempty data BuildWay = StaticWay | DynWay | ProfWay | VanillaWay deriving (Eq, Ord) --- | Returns a pair of the input files and Haskell modules of the component --- being built. +-- | Returns the object/interface extension prefix for the given build way (e.g. "dyn_" for 'DynWay') +buildWayPrefix :: BuildWay -> String +buildWayPrefix = \case + VanillaWay -> "" + StaticWay -> "" + ProfWay -> "p_" + DynWay -> "dyn_" + +-- | Returns the corresponding 'Hpc.Way' for a 'BuildWay' +buildWayHpcWay :: BuildWay -> Hpc.Way +buildWayHpcWay = \case + VanillaWay -> Hpc.Vanilla + StaticWay -> Hpc.Vanilla + ProfWay -> Hpc.Prof + DynWay -> Hpc.Dyn + +-- | Returns a function to extract the extra haskell compiler options from a +-- 'BuildInfo' and 'CompilerFlavor' +buildWayExtraHcOptions :: BuildWay -> Maybe (CompilerFlavor -> BuildInfo -> [String]) +buildWayExtraHcOptions = \case + VanillaWay -> Nothing + StaticWay -> Just hcStaticOptions + ProfWay -> Just hcProfOptions + DynWay -> Just hcSharedOptions + +-- | Returns a pair of the Haskell input files and Haskell modules of the +-- component being built. componentInputs :: FilePath -- ^ Target build dir -> PD.PackageDescription -> BuildM ([FilePath], [ModuleName]) + -- ^ The Haskell input files, and the Haskell modules componentInputs buildTargetDir pkg_descr = do verbosity <- buildVerbosity component <- buildComponent diff --git a/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs b/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs deleted file mode 100644 index 2fe6d758156..00000000000 --- a/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs +++ /dev/null @@ -1,553 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Distribution.Simple.GHC.BuildGeneric - ( GBuildMode (..) - , gbuild - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.ModuleName (ModuleName) -import Distribution.Package -import Distribution.PackageDescription as PD -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.Pretty -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 -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup.Common -import Distribution.Simple.Setup.Repl -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Types.PackageName.Magic -import Distribution.Types.ParStrat -import Distribution.Utils.NubList -import Distribution.Verbosity -import Distribution.Version -import System.Directory - ( doesDirectoryExist - , doesFileExist - , removeFile - , renameFile - ) -import System.FilePath - ( replaceExtension - , () - ) -import Distribution.Simple.GHC.Build.Utils -import Distribution.Simple.GHC.Build.Link (getRPaths) - --- | A collection of: --- * C input files --- * C++ input files --- * GHC input files --- * GHC input modules --- --- Used to correctly build and link sources. -data BuildSources = BuildSources - { cSourcesFiles :: [FilePath] - , cxxSourceFiles :: [FilePath] - , jsSourceFiles :: [FilePath] - , asmSourceFiles :: [FilePath] - , cmmSourceFiles :: [FilePath] - , inputSourceFiles :: [FilePath] - , inputSourceModules :: [ModuleName] - } - -data DynamicRtsInfo = DynamicRtsInfo - { dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath - , dynRtsThreadedEventlogLib :: FilePath - } - -data StaticRtsInfo = StaticRtsInfo - { statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath - , statRtsThreadedProfilingLib :: FilePath - } - -data RtsInfo = RtsInfo - { rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] - } - --- | Building an executable, starting the REPL, and building foreign --- libraries are all very similar and implemented in 'gbuild'. The --- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode - = GBuildExe Executable - | GReplExe ReplFlags Executable - | GBuildFLib ForeignLib - | GReplFLib ReplFlags ForeignLib - -gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe -gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib - -gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False -gbuildIsRepl (GReplExe _ _) = True -gbuildIsRepl (GBuildFLib _) = False -gbuildIsRepl (GReplFLib _ _) = True - -gbuildModDefFiles :: GBuildMode -> [FilePath] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] -gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib -gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib - -gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe -gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib - -gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib - -gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool -gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> flibIsDynamic flib - GReplFLib _ flib -> flibIsDynamic flib - -gbuildComp :: GBuildMode -> Component -gbuildComp = \case - GBuildExe exe -> CExe exe - GReplExe _ exe -> CExe exe - GBuildFLib flib -> CFLib flib - GReplFLib _ flib -> CFLib flib - --- | Locate and return the 'BuildSources' required to build and link. -gbuildSources - :: Verbosity - -> PackageId - -> CabalSpecVersion - -> FilePath - -> GBuildMode - -> IO BuildSources -gbuildSources verbosity pkgId specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib - where - exeSources :: Executable -> IO BuildSources - 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. - if isHaskell main || pkgId == fakePackageId - then - if specVer < 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 - BuildSources - { cSourcesFiles = cSources bnfo - , cxxSourceFiles = cxxSources bnfo - , jsSourceFiles = jsSources bnfo - , asmSourceFiles = asmSources bnfo - , cmmSourceFiles = cmmSources bnfo - , inputSourceFiles = [main] - , inputSourceModules = - filter (/= mainModName) $ - exeModules exe - } - else - return - BuildSources - { cSourcesFiles = cSources bnfo - , cxxSourceFiles = cxxSources bnfo - , jsSourceFiles = jsSources bnfo - , asmSourceFiles = asmSources bnfo - , cmmSourceFiles = cmmSources bnfo - , inputSourceFiles = [main] - , inputSourceModules = exeModules exe - } - else - let (csf, cxxsf) - | isCxx main = (cSources bnfo, main : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) - in return - BuildSources - { cSourcesFiles = csf - , cxxSourceFiles = cxxsf - , jsSourceFiles = jsSources bnfo - , asmSourceFiles = asmSources bnfo - , cmmSourceFiles = cmmSources bnfo - , inputSourceFiles = [] - , inputSourceModules = exeModules exe - } - - flibSources :: ForeignLib -> BuildSources - flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources - { cSourcesFiles = cSources bnfo - , cxxSourceFiles = cxxSources bnfo - , jsSourceFiles = jsSources bnfo - , asmSourceFiles = asmSources bnfo - , cmmSourceFiles = cmmSources bnfo - , inputSourceFiles = [] - , inputSourceModules = foreignLibModules flib - } - --- | Extract (and compute) information about the RTS library --- --- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can --- find this information somewhere. We can lookup the 'hsLibraries' field of --- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which --- doesn't really help. -extractRtsInfo :: LocalBuildInfo -> RtsInfo -extractRtsInfo lbi = - case PackageIndex.lookupPackageName - (installedPkgs lbi) - (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" - where - aux :: InstalledPackageInfo -> RtsInfo - aux rts = - RtsInfo - { rtsDynamicInfo = - DynamicRtsInfo - { dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = - StaticRtsInfo - { statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } - withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) - --- | Determine whether the given 'BuildInfo' is intended to link against the --- threaded RTS. This is used to determine which RTS to link against when --- building a foreign library with a GHC without support for @-flink-rts@. -hasThreaded :: BuildInfo -> Bool -hasThreaded bi = elem "-threaded" ghc - where - PerCompilerFlavor ghc _ = options bi - - --- | Generic build function. See comment for 'GBuildMode'. -gbuild - :: BuildingWhat - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> GBuildMode - -> ComponentLocalBuildInfo - -> IO () -gbuild what numJobs pkg_descr lbi bm clbi = do - let verbosity = buildingWhatVerbosity what - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - runGhcProg = runGHC verbosity ghcProg comp platform - target = TargetInfo clbi (gbuildComp bm) - - let bnfo = gbuildInfo bm - - -- the name that GHC really uses (e.g., with .exe on Windows for executables) - let targetName = gbuildTargetName lbi bm - let targetDir = buildDir lbi (gbuildName bm) - let tmpDir = targetDir (gbuildName bm ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True tmpDir - - -- 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 = exeCoverage lbi - hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir extraCompilationArtifacts) way - | otherwise = mempty - - 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 - cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs bnfo) - cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic bnfo) - - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - jsSrcs = jsSourceFiles buildSources - asmSrcs = asmSourceFiles buildSources - cmmSrcs = cmmSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - cLikeObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - jsObjs = if hasJsSupport then map (`replaceExtension` objExtension) jsSrcs else [] - asmObjs = map (`replaceExtension` objExtension) asmSrcs - cmmObjs = map (`replaceExtension` objExtension) cmmSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi - Platform hostArch _ = hostPlatform lbi - hasJsSupport = hostArch == JavaScript - - -- build executables - baseOpts = - (Internal.componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty - { ghcOptMode = toFlag GhcModeMake - , ghcOptInputFiles = - toNubListR $ - if package pkg_descr == fakePackageId - then filter isHaskell inputFiles - else inputFiles - , ghcOptInputScripts = - toNubListR $ - if package pkg_descr == fakePackageId - then filter (not . isHaskell) inputFiles - else [] - , ghcOptInputModules = toNubListR inputModules - } - staticOpts = - baseOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcStaticOnly - , ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = - baseOpts - `mappend` mempty - { ghcOptProfilingMode = toFlag True - , ghcOptProfilingAuto = - Internal.profDetailLevelFlag - False - (withProfExeDetail lbi) - , ghcOptHiSuffix = toFlag "p_hi" - , ghcOptObjSuffix = toFlag "p_o" - , ghcOptExtra = hcProfOptions GHC bnfo - , ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = - baseOpts - `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 bnfo - , ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = - mempty - { ghcOptLinkOptions = - PD.ldOptions bnfo - ++ [ "-static" - | withFullyStaticExe lbi - ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe - [] - programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)) - , ghcOptLinkLibs = - if withFullyStaticExe lbi - then extraLibsStatic bnfo - else extraLibs bnfo - , ghcOptLinkLibPath = - toNubListR $ - if withFullyStaticExe lbi - then cleanedExtraLibDirsStatic - else cleanedExtraLibDirs - , ghcOptLinkFrameworks = - toNubListR $ - PD.frameworks bnfo - , ghcOptLinkFrameworkDirs = - toNubListR $ - PD.extraFrameworkDirs bnfo - , ghcOptInputFiles = - toNubListR - [tmpDir x | x <- cLikeObjs ++ cxxObjs ++ jsObjs ++ cmmObjs ++ asmObjs] - } - dynLinkerOpts = - mempty - { ghcOptRPaths = rpaths - , ghcOptInputFiles = - toNubListR - [tmpDir x | x <- cLikeObjs ++ cxxObjs ++ cmmObjs ++ asmObjs] - } - replOpts = - baseOpts - { ghcOptExtra = - Internal.filterGhciFlags - (ghcOptExtra 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 - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty - { ghcOptMode = toFlag GhcModeInteractive - , ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts - | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - - 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 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 - `mappend` linkerOpts - `mappend` mempty - { ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) - - info verbosity "Linking..." - -- Work around old GHCs not relinking in this - -- situation, see #3294 - let target' = targetDir targetName - when (compilerVersion comp < mkVersion [7, 7]) $ do - e <- doesFileExist target' - when e (removeFile target') - runGhcProg linkOpts{ghcOptOutputFile = toFlag target'} - GBuildFLib flib -> do - let - -- Instruct GHC to link against libHSrts. - rtsLinkOpts :: GhcOptions - rtsLinkOpts - | supportsFLinkRts = - mempty - { ghcOptLinkRts = toFlag True - } - | otherwise = - mempty - { ghcOptLinkLibs = rtsOptLinkLibs - , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo - } - where - threaded = hasThreaded (gbuildInfo bm) - supportsFLinkRts = compilerVersion comp >= mkVersion [9, 0] - rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = - [ if needDynamic - then - if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else - if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] - - linkOpts :: GhcOptions - linkOpts = case foreignLibType flib of - ForeignLibNativeShared -> - commonOpts - `mappend` linkerOpts - `mappend` dynLinkerOpts - `mappend` rtsLinkOpts - `mappend` mempty - { ghcOptLinkNoHsMain = toFlag True - , ghcOptShared = toFlag True - , ghcOptFPic = toFlag True - , ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm - } - ForeignLibNativeStatic -> - -- this should be caught by buildFLib - -- (and if we do implement this, we probably don't even want to call - -- ghc here, but rather Ar.createArLibArchive or something) - cabalBug "static libraries not yet implemented" - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -- We build under a (potentially) different filename to set a - -- soname on supported platforms. See also the note for - -- @flibBuildName@. - info verbosity "Linking..." - let buildName = flibBuildName lbi flib - runGhcProg linkOpts{ghcOptOutputFile = toFlag (targetDir buildName)} - renameFile (targetDir buildName) (targetDir targetName) diff --git a/Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs b/Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs deleted file mode 100644 index 0cbe14728b3..00000000000 --- a/Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs +++ /dev/null @@ -1,405 +0,0 @@ -module Distribution.Simple.GHC.BuildOrRepl (buildOrReplLib) where - -import Distribution.Compat.Prelude -import Prelude () - -import qualified Distribution.ModuleName as ModuleName -import Distribution.Package -import Distribution.PackageDescription as PD -import Distribution.Simple.GHC.Build.ExtraSources -import Distribution.Simple.Build.Monad -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.GHC.Build - ( replNoLoad - , runReplOrWriteFlags - ) -import Distribution.Simple.GHC.ImplInfo -import qualified Distribution.Simple.GHC.Internal as Internal -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.LocalBuildInfo -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.Common -import Distribution.Simple.Setup.Repl -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ParStrat -import Distribution.Simple.GHC.Build.Modules -import Distribution.Utils.NubList -import Distribution.Version -import System.Directory - ( doesDirectoryExist - , makeRelativeToCurrentDirectory - ) -import System.FilePath - ( replaceExtension - , () - ) -import Distribution.Simple.GHC.Build.Link - -buildOrReplLib - :: BuildingWhat - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO () -buildOrReplLib what numJobs pkg_descr lbi lib clbi = do - let uid = componentUnitId clbi - libTargetDir = componentBuildDir lbi clbi - whenVanillaLib forceVanilla = - when (forceVanilla || withVanillaLib lbi) - whenProfLib = when (withProfLib lbi) - whenSharedLib forceShared = - when (forceShared || withSharedLib lbi) - whenStaticLib forceStatic = - when (forceStatic || withStaticLib lbi) - whenGHCiLib = when (withGHCiLib lbi) - forRepl = case what of BuildRepl{} -> True; _ -> False - 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 - implInfo = getImplInfo comp - platform@(Platform hostArch hostOS) = hostPlatform lbi - hasJsSupport = hostArch == JavaScript - has_code = not (componentIsIndefinite clbi) - verbosity = buildingWhatVerbosity what - target = TargetInfo clbi (CLib lib) - - relLibTargetDir <- makeRelativeToCurrentDirectory libTargetDir - - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let runGhcProg = runGHC verbosity ghcProg comp platform - - let libBi = libBuildInfo lib - - -- ensure extra lib dirs exist before passing to ghc - cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs libBi) - cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic libBi) - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir extraCompilationArtifacts) way - | otherwise = mempty - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? - let cLikeSources = - fromNubListR $ - mconcat - [ toNubListR (cSources libBi) - , toNubListR (cxxSources libBi) - , toNubListR (cmmSources libBi) - , toNubListR (asmSources libBi) - , if hasJsSupport - then -- JS files are C-like with GHC's JS backend: they are - -- "compiled" into `.o` files (renamed with a header). - -- This is a difference from GHCJS, for which we only - -- pass the JS files at link time. - toNubListR (jsSources libBi) - else mempty - ] - cLikeObjs = map (`replaceExtension` objExtension) cLikeSources - baseOpts = Internal.componentGhcOptions verbosity lbi libBi clbi libTargetDir - vanillaOpts = - baseOpts - `mappend` mempty - { ghcOptMode = toFlag GhcModeMake - , ghcOptNumJobs = numJobs - , ghcOptInputModules = toNubListR $ allLibModules lib clbi - , ghcOptHPCDir = hpcdir Hpc.Vanilla - } - - linkerOpts = - mempty - { ghcOptLinkOptions = - PD.ldOptions libBi - ++ [ "-static" - | withFullyStaticExe lbi - ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe - [] - programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)) - , ghcOptLinkLibs = - if withFullyStaticExe lbi - then extraLibsStatic libBi - else extraLibs libBi - , ghcOptLinkLibPath = - toNubListR $ - if withFullyStaticExe lbi - then cleanedExtraLibDirsStatic - else cleanedExtraLibDirs - , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi - , ghcOptLinkFrameworkDirs = - toNubListR $ - PD.extraFrameworkDirs libBi - , ghcOptInputFiles = - toNubListR - [relLibTargetDir x | x <- cLikeObjs] - } - replOpts = - vanillaOpts - { ghcOptExtra = - Internal.filterGhciFlags - (ghcOptExtra vanillaOpts) - <> replOptionsFlags replFlags - , ghcOptNumJobs = mempty - , ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts) - } - `mappend` linkerOpts - `mappend` mempty - { ghcOptMode = isInteractive - , ghcOptOptimisation = toFlag GhcNoOptimisation - } - - isInteractive = toFlag GhcModeInteractive - - - 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 ghcProg lbi rflags replOpts target (pkgName (PD.package pkg_descr)) - - -- link: - when has_code . unless forRepl $ do - info verbosity "Linking..." - let cLikeProfObjs = - map - (`replaceExtension` ("p_" ++ objExtension)) - cLikeSources - cLikeSharedObjs = - map - (`replaceExtension` ("dyn_" ++ objExtension)) - cLikeSources - compiler_id = compilerId (compiler lbi) - vanillaLibFilePath = relLibTargetDir mkLibName uid - profileLibFilePath = relLibTargetDir mkProfLibName uid - sharedLibFilePath = - relLibTargetDir - mkSharedLibName (hostPlatform lbi) compiler_id uid - staticLibFilePath = - relLibTargetDir - mkStaticLibName (hostPlatform lbi) compiler_id uid - ghciLibFilePath = relLibTargetDir Internal.mkGHCiLibName uid - ghciProfLibFilePath = relLibTargetDir Internal.mkGHCiProfLibName uid - libInstallPath = - libdir $ - absoluteComponentInstallDirs - pkg_descr - lbi - uid - NoCopyDest - sharedLibInstallPath = - libInstallPath - mkSharedLibName (hostPlatform lbi) compiler_id uid - - stubObjs <- - catMaybes - <$> sequenceA - [ findFileWithExtension - [objExtension] - [libTargetDir] - (ModuleName.toFilePath x ++ "_stub") - | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi - ] - stubProfObjs <- - catMaybes - <$> sequenceA - [ findFileWithExtension - ["p_" ++ objExtension] - [libTargetDir] - (ModuleName.toFilePath x ++ "_stub") - | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi - ] - stubSharedObjs <- - catMaybes - <$> sequenceA - [ findFileWithExtension - ["dyn_" ++ objExtension] - [libTargetDir] - (ModuleName.toFilePath x ++ "_stub") - | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi - ] - - hObjs <- - Internal.getHaskellObjects - implInfo - lib - lbi - clbi - relLibTargetDir - objExtension - True - hProfObjs <- - if withProfLib lbi - then - Internal.getHaskellObjects - implInfo - lib - lbi - clbi - relLibTargetDir - ("p_" ++ objExtension) - True - else return [] - hSharedObjs <- - if withSharedLib lbi - then - Internal.getHaskellObjects - implInfo - lib - lbi - clbi - relLibTargetDir - ("dyn_" ++ objExtension) - False - else return [] - - unless (null hObjs && null cLikeObjs && null stubObjs) $ do - rpaths <- runBuildM what lbi target getRPaths - - let staticObjectFiles = - hObjs - ++ map (relLibTargetDir ) cLikeObjs - ++ stubObjs - profObjectFiles = - hProfObjs - ++ map (relLibTargetDir ) cLikeProfObjs - ++ stubProfObjs - dynamicObjectFiles = - hSharedObjs - ++ map (relLibTargetDir ) cLikeSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - mempty - { ghcOptShared = toFlag True - , ghcOptDynLinkMode = toFlag GhcDynamicOnly - , ghcOptInputFiles = toNubListR dynamicObjectFiles - , ghcOptOutputFile = toFlag sharedLibFilePath - , ghcOptExtra = hcSharedOptions GHC libBi - , -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - ghcOptDylibName = - if hostOS == OSX - && ghcVersion < mkVersion [7, 8] - then toFlag sharedLibInstallPath - else mempty - , ghcOptHideAllPackages = toFlag True - , ghcOptNoAutoLinkPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> - toFlag pk - _ -> mempty - , ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts - } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty - , ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts - } -> - insts - _ -> [] - , ghcOptPackages = - toNubListR $ - Internal.mkGhcOptPackages mempty clbi - , ghcOptLinkLibs = extraLibs libBi - , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs - , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi - , ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi - , ghcOptRPaths = rpaths - } - ghcStaticLinkArgs = - mempty - { ghcOptStaticLib = toFlag True - , ghcOptInputFiles = toNubListR staticObjectFiles - , ghcOptOutputFile = toFlag staticLibFilePath - , ghcOptExtra = hcStaticOptions GHC libBi - , ghcOptHideAllPackages = toFlag True - , ghcOptNoAutoLinkPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> - toFlag pk - _ -> mempty - , ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts - } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty - , ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts - } -> - insts - _ -> [] - , ghcOptPackages = - toNubListR $ - Internal.mkGhcOptPackages mempty clbi - , ghcOptLinkLibs = extraLibs libBi - , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs - } - - info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) - - whenVanillaLib False $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles - verbosity - lbi - ldProg - ghciLibFilePath - staticObjectFiles - - whenProfLib $ do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles - verbosity - lbi - ldProg - ghciProfLibFilePath - profObjectFiles - - whenSharedLib False $ - runGhcProg ghcSharedLinkArgs - - whenStaticLib False $ - runGhcProg ghcStaticLinkArgs