From ddcd667c13e69a66f3b28deae67ca326d3d07089 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 11 Jan 2024 22:29:33 +0000 Subject: [PATCH] Refactor the linking invocations from gbuild/buildOrReplLib This is the third part of the refactor of gbuild and buildOrReplLib (#9389). It re-works the linker invocations, focusing on preserving existing behaviour before simplifying or fixing bugs any further. Follows the spirit of the two previous commits, with the end goal of (#9389) --- Cabal/Cabal.cabal | 2 - Cabal/src/Distribution/Simple/Build/Monad.hs | 43 +- Cabal/src/Distribution/Simple/GHC.hs | 111 +-- Cabal/src/Distribution/Simple/GHC/Build.hs | 253 +++---- .../Simple/GHC/Build/ExtraSources.hs | 110 +-- .../src/Distribution/Simple/GHC/Build/Link.hs | 660 ++++++++++++++++++ .../Distribution/Simple/GHC/Build/Modules.hs | 384 +++++----- .../Distribution/Simple/GHC/Build/Utils.hs | 221 ++++++ .../Distribution/Simple/GHC/BuildGeneric.hs | 553 --------------- .../Distribution/Simple/GHC/BuildOrRepl.hs | 405 ----------- Cabal/src/Distribution/Simple/GHC/Internal.hs | 149 ++-- 11 files changed, 1407 insertions(+), 1484 deletions(-) create mode 100644 Cabal/src/Distribution/Simple/GHC/Build/Link.hs create mode 100644 Cabal/src/Distribution/Simple/GHC/Build/Utils.hs delete mode 100644 Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs delete mode 100644 Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 68f49321def..c49493a1ac5 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -337,8 +337,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..c273f9e474d 100644 --- a/Cabal/src/Distribution/Simple/Build/Monad.hs +++ b/Cabal/src/Distribution/Simple/Build/Monad.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} + module Distribution.Simple.Build.Monad - ( BuildM (..) + ( -- * A Monad for building components + BuildM (BuildM) , runBuildM , PreBuildComponentInputs (..) - -- * A few queries on @'BuildM'@ + -- * Queries over the component being built , buildVerbosity , buildWhat , buildComponent + , buildIsLib , buildCLBI , buildBI , buildLBI @@ -26,14 +30,14 @@ where import Control.Monad.Reader +import Distribution.Simple.Compiler import Distribution.Simple.Setup (BuildingWhat (..), buildingWhatDistPref, buildingWhatVerbosity) +import Distribution.Types.BuildInfo +import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo 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 @@ -48,8 +52,16 @@ 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, MonadReader PreBuildComponentInputs, MonadIO) via ReaderT PreBuildComponentInputs IO +newtype BuildM a = BuildM' (ReaderT PreBuildComponentInputs IO a) + deriving (Functor, Applicative, Monad, MonadReader PreBuildComponentInputs, MonadIO) + +-- Ideally we'd use deriving via ReaderT PreBuildComponentInputs IO, but ghc 8.4 doesn't support it. + +-- | Construct a t'BuildM' action from an IO function on 'PreBuildComponentInputs'. +pattern BuildM :: (PreBuildComponentInputs -> IO a) -> BuildM a +pattern BuildM f = BuildM' (ReaderT f) + +{-# COMPLETE BuildM #-} -- | Run a 'BuildM' action, i.e. a computation in the context of building a component. runBuildM :: BuildingWhat -> LocalBuildInfo -> TargetInfo -> BuildM a -> IO a @@ -72,6 +84,16 @@ buildComponent :: BuildM Component buildComponent = asks (targetComponent . targetInfo) {-# INLINE buildComponent #-} +-- | Is the @'Component'@ being built a @'Library'@? +buildIsLib :: BuildM Bool +buildIsLib = do + component <- buildComponent + let isLib + | CLib{} <- component = True + | otherwise = False + return isLib +{-# INLINE buildIsLib #-} + -- | Get the @'ComponentLocalBuildInfo'@ for the component being built. buildCLBI :: BuildM ComponentLocalBuildInfo buildCLBI = asks (targetCLBI . targetInfo) @@ -87,6 +109,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 +117,4 @@ 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 53c51246490..89df6980d88 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -91,10 +91,12 @@ import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Package import Distribution.PackageDescription as PD import Distribution.Pretty +import Distribution.Simple.Build.Monad (runBuildM) 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.GHC.Build.Utils import Distribution.Simple.GHC.EnvironmentParser import Distribution.Simple.GHC.ImplInfo @@ -104,7 +106,6 @@ 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 @@ -114,6 +115,7 @@ import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ParStrat +import Distribution.Types.TargetInfo import Distribution.Utils.NubList import Distribution.Verbosity import Distribution.Version @@ -133,13 +135,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 @@ -575,7 +574,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 @@ -585,7 +585,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 @@ -617,7 +618,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 @@ -627,8 +629,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 @@ -639,7 +641,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 @@ -649,8 +652,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. @@ -734,7 +737,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 @@ -844,47 +847,47 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName whenShared $ if - -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. - -- See ghc issue #15837 and Cabal PR #5855. - | specVersion pkg < CabalSpecV3_0 -> do - sequence_ - [ installShared - builtDir - dynlibTargetDir - (mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "" : extraDynLibFlavours (libBuildInfo lib) - ] - | otherwise -> do - sequence_ - [ installShared - builtDir - dynlibTargetDir - ( mkGenericSharedLibName - platform - compiler_id - (getHSLibraryName uid ++ f) - ) - | f <- "" : extraDynLibFlavours (libBuildInfo lib) - ] - sequence_ - [ do - files <- getDirectoryContents builtDir - let l' = - mkGenericSharedBundledLibName - platform - compiler_id - l - forM_ files $ \file -> - when (l' `isPrefixOf` file) $ do - isFile <- doesFileExist (builtDir file) - when isFile $ do - installShared - builtDir - dynlibTargetDir - file - | l <- extraBundledLibs (libBuildInfo lib) - ] + -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. + -- See ghc issue #15837 and Cabal PR #5855. + | specVersion pkg < CabalSpecV3_0 -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + (mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + | otherwise -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + ( mkGenericSharedLibName + platform + compiler_id + (getHSLibraryName uid ++ f) + ) + | f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + sequence_ + [ do + files <- getDirectoryContents builtDir + let l' = + mkGenericSharedBundledLibName + platform + compiler_id + l + forM_ files $ \file -> + when (l' `isPrefixOf` file) $ do + isFile <- doesFileExist (builtDir file) + when isFile $ do + installShared + builtDir + dynlibTargetDir + file + | l <- extraBundledLibs (libBuildInfo lib) + ] where builtDir = componentBuildDir lbi clbi diff --git a/Cabal/src/Distribution/Simple/GHC/Build.hs b/Cabal/src/Distribution/Simple/GHC/Build.hs index 6eb4769dfa4..fa4c034fc1d 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build.hs @@ -1,171 +1,136 @@ -{-# 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 qualified Data.Set as Set 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.Build.Monad +import Distribution.Simple.Flag (Flag) +import Distribution.Simple.GHC.Build.ExtraSources +import Distribution.Simple.GHC.Build.Link +import Distribution.Simple.GHC.Build.Modules +import Distribution.Simple.GHC.Build.Utils (withDynFLib) 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 Distribution.Types.ComponentLocalBuildInfo (componentIsIndefinite) +import Distribution.Types.ParStrat 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.Types.ParStrat -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.Setup.Common (extraCompilationArtifacts) + +{- +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). + +However, in executables, we don't do this. It seems that we don't need to do it +for executable-like components because the linking step, instead of passing as +an argument the path to each module, it simply passes the module name, the sources dir, and --make. +RM: I believe we can use --make + module names instead of paths-to-objects +for linking libraries too (2024-01) (TODO) +-} -- | The main build phase of building a component. -- Includes building Haskell modules, extra build sources, and linking. -build :: Flag ParStrat - -> PackageDescription - -> BuildM () +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). - -} + isLib <- buildIsLib + lbi <- buildLBI + clbi <- buildCLBI + + -- Create a few directories for building the component + -- 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) | isLib = targetDir_absolute - -- In other cases, use targetDir/-tmp - | targetDirName:_ <- reverse $ splitDirectories targetDir_absolute - = targetDir_absolute (targetDirName ++ "-tmp") - + | targetDirName : _ <- reverse $ splitDirectories targetDir_absolute = + targetDir_absolute (targetDirName ++ "-tmp") | otherwise = error "GHC.build: targetDir is empty" - liftIO do + 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 - -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}) + + -- See Note [Build Target Dir vs Target Dir] as well + _targetDir <- liftIO $ makeRelativeToCurrentDirectory targetDir_absolute + buildTargetDir <- + -- ROMES:TODO: To preserve the previous behaviour, we don't use relative + -- dirs for executables. Historically, this isn't needed to reduce the CLI + -- limit (unlike for libraries) because we link executables with the module + -- names instead of passing the path to object file -- that's something + -- else we can now fix after the refactor lands. + if isLib + then liftIO $ makeRelativeToCurrentDirectory buildTargetDir_absolute + else return buildTargetDir_absolute + + (ghcProg, _) <- liftIO $ requireProgram verbosity ghcProgram (withPrograms lbi) + + -- Determine in which ways we want to build the component + let + wantVanilla = if isLib then withVanillaLib lbi else False + -- ROMES:TODO: Arguably, wantStatic should be "withFullyStaticExe lbi" for + -- executables, but it was not before the refactor. + wantStatic = if isLib then withStaticLib lbi else not (wantDynamic || wantProf) + wantDynamic = case component of + CLib{} -> withSharedLib lbi + CFLib flib -> withDynFLib flib + CExe{} -> withDynExe lbi + CTest{} -> withDynExe lbi + CBench{} -> 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 + -- We build static by default if no other way is wanted. + -- For executables and foreign libraries, there should only be one wanted way. + wantedWays = + Set.fromList $ + -- If building a library, we accumulate all the ways, + -- otherwise, we take just one. + (if isLib then id else take 1) $ + [ProfWay | wantProf] + -- ROMES:TODO: I don't see why we shouldn't build with dynamic + -- indefinite components (being instantiated?). + <> [DynWay | wantDynamic && not (componentIsIndefinite clbi)] + <> [StaticWay | wantStatic || wantVanilla || not (wantDynamic || wantProf)] + + liftIO $ info verbosity ("Wanted build ways: " ++ show (Set.toList wantedWays)) + + -- 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, #3294). + buildOpts <- buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir_absolute wantedWays + extraSources <- buildAllExtraSources ghcProg buildTargetDir + linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir_absolute) (wantedWays, buildOpts) diff --git a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs index c101d5cab6a..bc00a127327 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -18,34 +17,30 @@ import Distribution.Types.TargetInfo import Distribution.Simple.GHC.Build.Utils import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentName (componentNameRaw) +import Distribution.Simple.Program.Types +import Distribution.System (Arch (JavaScript), Platform (..)) +import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.Executable import Distribution.Verbosity (Verbosity) -import System.FilePath -import Distribution.Simple.Program.Types import Distribution.Simple.Build.Monad -- | 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 - [ buildCSources - , buildCxxSources - , buildJsSources - , buildAsmSources - , 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 ... +buildAllExtraSources + :: ConfiguredProgram + -- ^ The GHC configured program + -> FilePath + -- ^ The build directory for this target + -> BuildM [FilePath] + -- ^ Returns the list of extra sources that were built +buildAllExtraSources = mconcat + [ buildCSources + , buildCxxSources + , buildJsSources + , buildAsmSources + , buildCmmSources + ] buildCSources , buildCxxSources @@ -54,13 +49,10 @@ 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. + -> FilePath + -- ^ The build directory for this target + -> BuildM [FilePath] + -- ^ Returns the list of extra sources that were built buildCSources = buildExtraSources "C Sources" @@ -83,12 +75,24 @@ buildCxxSources = CExe exe | isCxx (modulePath exe) -> [modulePath exe] _otherwise -> [] ) -buildJsSources = +buildJsSources ghcProg buildTargetDir = 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 + buildTargetDir buildAsmSources = buildExtraSources "Assembler Sources" @@ -123,9 +127,12 @@ buildExtraSources -- if it should be compiled as the rest of them. -> ConfiguredProgram -- ^ The GHC configured program - -> BuildM () -buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcProg = - BuildM \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> + -> FilePath + -- ^ The build directory for this target + -> BuildM [FilePath] + -- ^ Returns the list of extra sources that were built +buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcProg buildTargetDir = + BuildM $ \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> let bi = componentBuildInfo (targetComponent targetInfo) verbosity = buildingWhatVerbosity buildingWhat @@ -135,20 +142,21 @@ buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcP comp = compiler lbi platform = hostPlatform lbi + -- ROMES:TODO: Instead of keeping this logic here, we really just want to + -- receive as an input the `neededWays` and build accordingly 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 verbosity lbi bi clbi - buildDir' + buildTargetDir sourceFile vanillaSrcOpts -- Dynamic GHC requires C sources to be built @@ -198,9 +206,9 @@ 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:TODO: doesn't sound right "ProfExe" for FLib... compileIfNeeded profSrcOpts - | flibIsDynamic flib -> + | withDynFLib flib && wantDyn -> compileIfNeeded sharedSrcOpts | otherwise -> compileIfNeeded vanillaSrcOpts @@ -210,23 +218,15 @@ buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcP _exeLike | withProfExe lbi -> compileIfNeeded profSrcOpts - | withDynExe lbi -> + | withDynExe lbi && wantDyn -> compileIfNeeded sharedSrcOpts | otherwise -> compileIfNeeded vanillaSrcOpts - - -- Until we get rid of the "exename-tmp" directory within the executable - -- build dir, we need to accommodate that fact (see eg @tmpDir@ in @gbuild@) - -- This is a workaround for #9498 until it is fixed. - cname = componentName (targetComponent targetInfo) - buildDir' - | CLibName{} <- cname = - componentBuildDir lbi clbi - | CNotLibName{} <- cname = - componentBuildDir lbi clbi - componentNameRaw cname <> "-tmp" - in do + in -- build any sources - unless (null sources) $ do - info verbosity ("Building " ++ description ++ "...") - traverse_ buildAction sources + if (null sources || componentIsIndefinite clbi) + then return [] + else do + info verbosity ("Building " ++ description ++ "...") + traverse_ buildAction sources + return sources 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..d1229bfc7bf --- /dev/null +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -0,0 +1,660 @@ +{-# LANGUAGE LambdaCase #-} + +module Distribution.Simple.GHC.Build.Link where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Exception (assert) +import Control.Monad (forM_) +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.Set as Set +import Distribution.Compat.Binary (encode) +import Distribution.Compat.ResponseFile +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +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 Distribution.Simple.GHC.Build.Modules +import Distribution.Simple.GHC.Build.Utils (exeTargetName, flibBuildName, flibTargetName, withDynFLib) +import Distribution.Simple.GHC.ImplInfo +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.LocalBuildInfo +import qualified Distribution.Simple.PackageIndex as PackageIndex +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.Utils.NubList +import Distribution.Verbosity +import Distribution.Version +import System.Directory +import System.FilePath + +-- | 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 + -> (Set.Set BuildWay, BuildWay -> GhcOptions) + -- ^ The set of build ways wanted based on the user opts, and a function to + -- convert a build way into the set of ghc options that were used to build + -- that way. + -> BuildM () +linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) (wantedWays, buildOpts) = 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 <- liftIO $ filterM doesDirectoryExist (extraLibDirs bi) + cleanedExtraLibDirsStatic <- liftIO $ filterM doesDirectoryExist (extraLibDirsStatic bi) + + let + -- ROMES:TODO: If we fix the order to C++ then C, then we cannot keep this matching the + -- previous behaviour, because it would report C objects first, then C++ + -- objects. Delete this comment after acknowledge. + extraSourcesObjs = map (`replaceExtension` objExtension) extraSources + + linkerOpts rpaths = + mempty + { ghcOptLinkOptions = + PD.ldOptions bi + ++ [ "-static" + | withFullyStaticExe lbi -- ROMES:TODO: wb withStaticLib and flibs?? + ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + ++ 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? + -- We used to use this predicate for libraries too... + if withFullyStaticExe lbi + then extraLibsStatic bi + else extraLibs bi + , ghcOptLinkLibPath = + toNubListR $ + -- ROMES:TODO: what about withStaticLib and flibs?? + if withFullyStaticExe lbi + then cleanedExtraLibDirsStatic + else cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks bi + , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi + , ghcOptInputFiles = toNubListR [buildTargetDir x | x <- extraSourcesObjs] + , ghcOptNoLink = Flag False + , ghcOptRPaths = rpaths + } + case what of + BuildRepl replFlags -> liftIO $ do + let + -- For repl we use the vanilla (static) ghc options + staticOpts = buildOpts StaticWay + replOpts = + staticOpts + { -- Repl options use Static as the base, but doesn't need to pass -static. + -- ROMES:TODO: It could, but it didn't use to before the + -- refactor. I think it would be more uniform to just pass the flag. + ghcOptDynLinkMode = NoFlag + , ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra staticOpts) + <> replOptionsFlags (replReplOptions replFlags) + , ghcOptInputModules = replNoLoad (replReplOptions replFlags) (ghcOptInputModules staticOpts) + , ghcOptInputFiles = replNoLoad (replReplOptions replFlags) (ghcOptInputFiles staticOpts) + } + -- 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. + -- + -- ROMES:TODO: The repl doesn't use the runtime paths from linkerOpts + -- (ghcOptRPaths), which looks like a bug. After the refactor we + -- can fix this. + `mappend` linkerOpts mempty + `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 + -- If not building dynamically, we don't pass any runtime paths. + rpaths <- if DynWay `Set.member` wantedWays then getRPaths else return (toNubListR []) + liftIO $ do + info verbosity "Linking..." + let linkExeLike name = linkExecutable (linkerOpts rpaths) (wantedWays, buildOpts) targetDir name runGhcProg lbi + case component of + CLib lib -> linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays + CFLib flib -> linkFLib flib bi lbi (linkerOpts rpaths) (wantedWays, buildOpts) targetDir runGhcProg + CExe exe -> linkExeLike (exeName exe) + CTest test -> linkExeLike (testName test) + CBench bench -> linkExeLike (benchmarkName bench) + +-- | Link a library component +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 + -> Set.Set BuildWay + -- ^ Wanted build ways and corresponding build options + -> IO () +linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = 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 = mconcat + [ 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 sources dir (as is already + -- done), and GHC will pick up the right suffix (p_ for profile, dyn_ when + -- -shared...). + -- That would mean linking the lib would be just like the executable, and we could more easily merge the two. + -- + -- Right now, instead, we pass the path to each object file. + ghcBaseLinkArgs = + mempty + { -- ROMES:TODO: This basically duplicates componentGhcOptions. + -- I think we want to do the same as we do for executables: re-use the + -- base options, and link by module names, not object paths. + 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 + } + + -- 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 dynObjectFiles = + ghcBaseLinkArgs + { ghcOptShared = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , 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 + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths + } + ghcStaticLinkArgs staticObjectFiles = + ghcBaseLinkArgs + { ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs -- ROMES:TODO: why not extra dirs *static*??? + } + + staticObjectFiles <- getObjFiles StaticWay + profObjectFiles <- getObjFiles ProfWay + dynamicObjectFiles <- getObjFiles DynWay + + let + linkWay = \case + ProfWay -> 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 -> do + runGhcProg $ ghcSharedLinkArgs dynamicObjectFiles + StaticWay -> do + when (withVanillaLib lbi) $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + when (withGHCiLib lbi) $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles + verbosity + lbi + ldProg + ghciLibFilePath + staticObjectFiles + when (withStaticLib lbi) $ do + runGhcProg $ ghcStaticLinkArgs staticObjectFiles + + -- ROMES: Why exactly branch on staticObjectFiles, rather than any other build + -- kind that we might have wanted instead? + -- This would be simpler by not adding every object to the invocation, and + -- rather using module names. + unless (null staticObjectFiles) $ do + info verbosity (show (ghcOptPackages (Internal.componentGhcOptions verbosity lbi libBi clbi buildTargetDir))) + traverse_ linkWay wantedWays + +-- | Link the executable resulting from building this component, be it an +-- executable, test, or benchmark component. +linkExecutable + :: (GhcOptions) + -- ^ The linker-specific GHC options + -> (Set.Set BuildWay, 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 (wantedWays, buildOpts) targetDir targetName runGhcProg lbi = do + -- When building an executable, we should only "want" one build way. + assert (Set.size wantedWays == 1) $ + forM_ wantedWays $ \way -> do + let baseOpts = buildOpts way + linkOpts = + baseOpts + `mappend` linkerOpts + `mappend` mempty + { -- If there are no input Haskell files we pass -no-hs-main, and + -- assume there is a main function in another non-haskell object + ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles baseOpts == mempty && ghcOptInputScripts baseOpts == mempty) + } + 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) + -- ^ The linker-specific GHC options + -> (Set.Set BuildWay, 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 (wantedWays, buildOpts) targetDir runGhcProg = do + let + comp = compiler lbi + + -- 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 bi + supportsFLinkRts = compilerVersion comp >= mkVersion [9, 0] + rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = + [ if withDynFLib flib + 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 + linkOpts way = case foreignLibType flib of + ForeignLibNativeShared -> + (buildOpts way) + `mappend` linkerOpts + `mappend` rtsLinkOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag True + , ghcOptShared = toFlag True + , ghcOptFPic = toFlag True + , ghcOptLinkModDefFiles = toNubListR $ foreignLibModDefFile flib + } + 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 + -- There should not be more than one wanted way when building an flib + assert (Set.size wantedWays == 1) $ + -- ROMES:TODO: Using the "wantedWay" is a bit senseless here, we likely + -- just want to use the Way of each ForeignLib type. + forM_ wantedWays $ \way -> do + runGhcProg (linkOpts way){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 + bi <- buildBI + 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) <> toNubListR (extraLibDirs bi) + 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..507ea1e2876 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs @@ -1,49 +1,49 @@ -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} -module Distribution.Simple.GHC.Build.Modules - ( buildHaskellModules ) - where +{-# LANGUAGE TupleSections #-} + +module Distribution.Simple.GHC.Build.Modules (buildHaskellModules, BuildWay (..), buildWayPrefix) where -import Distribution.Compat.Prelude import Control.Monad.IO.Class +import Distribution.Compat.Prelude -import Distribution.Types.ParStrat -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Utils -import Distribution.Utils.NubList -import System.FilePath +import Data.List (sortOn, (\\)) +import qualified Data.Set as Set +import Distribution.CabalSpecVersion +import Distribution.ModuleName (ModuleName) +import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.Build.Monad +import Distribution.Simple.Compiler import Distribution.Simple.GHC.Build.Utils +import qualified Distribution.Simple.GHC.Internal as Internal import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.Setup.Common -import Distribution.Simple.Program.Types +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.GHC -import Distribution.Types.ForeignLib -import Distribution.Types.Executable -import Distribution.Types.TestSuite +import Distribution.Simple.Program.Types +import Distribution.Simple.Setup.Common +import Distribution.Simple.Utils 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.BuildInfo +import Distribution.Types.Executable +import Distribution.Types.ForeignLib import Distribution.Types.PackageName.Magic -import qualified Distribution.PackageDescription as PD +import Distribution.Types.ParStrat +import Distribution.Types.TestSuite +import Distribution.Types.TestSuiteInterface +import Distribution.Utils.NubList +import System.FilePath {- 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 +65,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 @@ -89,31 +89,38 @@ To build an executable statically, with a static by default GHC, regardless of w -} -- | 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 +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. + -> Set.Set BuildWay + -- ^ The set of wanted build ways according to user options + -> BuildM (BuildWay -> GhcOptions) + -- ^ Returns a mapping from build ways to the 'GhcOptions' used in the + -- invocation used to compile the component in that 'BuildWay'. + -- This can be useful in, eg, a linker invocation, in which we want to use the + -- same options and list the same inputs as those used for building. +buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir wantedWays = do + -- See Note [Building Haskell Modules accounting for TH] 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 + isLib <- buildIsLib + clbi <- buildCLBI + lbi <- buildLBI + bi <- buildBI + what <- buildWhat + comp <- buildCompiler + + let + -- If this component will be loaded into a repl, we don't compile the modules at all. + 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? @@ -135,11 +142,16 @@ 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' + baseOpts way = + (Internal.componentGhcOptions verbosity lbi bi clbi buildTargetDir) `mappend` mempty { ghcOptMode = toFlag GhcModeMake + , -- romes:TODO previously we didn't pass -no-link when building libs, + -- but I also think that could result in a bug (e.g. if a lib module + -- is called Main and exports main). So we really want nolink when building libs too. + ghcOptNoLink = if isLib then NoFlag else toFlag True , ghcOptNumJobs = numJobs , ghcOptInputModules = toNubListR inputModules , ghcOptInputFiles = @@ -152,110 +164,82 @@ buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir = do if PD.package pkg_descr == fakePackageId then filter (not . isHaskell) inputFiles else [] + , ghcOptExtra = fromMaybe mempty (buildWayExtraHcOptions way) GHC bi + , ghcOptHiSuffix = optSuffixFlag (buildWayPrefix way) "hi" + , ghcOptObjSuffix = optSuffixFlag (buildWayPrefix way) "o" + , ghcOptHPCDir = hpcdir (buildWayHpcWay way) -- maybe this should not be passed for vanilla? } + where + optSuffixFlag "" _ = NoFlag + optSuffixFlag pre x = toFlag (pre ++ x) - staticOpts = - vanillaOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcStaticOnly - , ghcOptHPCDir = hpcdir Hpc.Vanilla - } + -- ROMES:TODO: For libs we don't pass -static when building static, leaving it implicit. + -- We should just always pass -static, but we don't want to change behaviour when doing the refactor. + staticOpts = (baseOpts StaticWay){ghcOptDynLinkMode = if isLib then NoFlag else 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 -- use -dynamic + , -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True -- use -fPIC + } 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 - } + (baseOpts ProfWay) + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + (if isLib then True else False) + ((if isLib then withProfLibDetail else withProfExeDetail) lbi) + } + -- Options for building both static and dynamic way at the same time, using + -- the GHC flag -static and -dynamic-too 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 + (baseOpts StaticWay) + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too + , ghcOptDynHiSuffix = toFlag (buildWayPrefix DynWay ++ "hi") + , ghcOptDynObjSuffix = toFlag (buildWayPrefix DynWay ++ "o") + , ghcOptHPCDir = hpcdir Hpc.Dyn + -- ROMES:TODO: We don't pass hcSharedOpts to dyntoo? + -- (baseOtps StaticWay -> hcStaticOptions, not hcSharedOpts) + } + + -- Determines how to build for each way, also serves as the base options + -- for loading modules in 'linkOrLoadComponent' + buildOpts way = case way of + StaticWay -> staticOpts + DynWay -> dynOpts + ProfWay -> profOpts 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 $ - + unless (forRepl || (null inputFiles && null inputModules)) $ liftIO $ do -- 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!! + neededWays = + wantedWays + <> Set.fromList + -- ROMES: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) + useDynamicToo = + StaticWay `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 + -- 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] + ++ (runGhcProg . buildOpts <$> Set.toList neededWays \\ [StaticWay, DynWay]) + -- Otherwise, we need to ensure the defaultGhcWay is built first + | otherwise = + runGhcProg . buildOpts <$> sortOn (\w -> if w == defaultGhcWay then 0 else fromEnum w + 1) (Set.toList neededWays) buildStaticAndDynamicToo = do runGhcProg dynTooOpts @@ -269,37 +253,65 @@ buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir = do -- 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]) + in + -- REVIEW:ADD? info verbosity "Building Haskell Sources..." + sequence_ orderedBuilds + return buildOpts + +data BuildWay = StaticWay | DynWay | ProfWay + deriving (Eq, Ord, Show, Enum) + +-- | Returns the object/interface extension prefix for the given build way (e.g. "dyn_" for 'DynWay') +buildWayPrefix :: BuildWay -> String +buildWayPrefix = \case + StaticWay -> "" + ProfWay -> "p_" + DynWay -> "dyn_" + +-- | Returns the corresponding 'Hpc.Way' for a 'BuildWay' +buildWayHpcWay :: BuildWay -> Hpc.Way +buildWayHpcWay = \case + 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 + 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. +-- +-- The "input files" are either the path to the main Haskell module, or a repl +-- script (that does not necessarily have an extension). +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 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 + 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) @@ -307,25 +319,25 @@ componentInputs buildTargetDir pkg_descr = do 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) + 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/Build/Utils.hs b/Cabal/src/Distribution/Simple/GHC/Build/Utils.hs new file mode 100644 index 00000000000..3df05801682 --- /dev/null +++ b/Cabal/src/Distribution/Simple/GHC/Build/Utils.hs @@ -0,0 +1,221 @@ +module Distribution.Simple.GHC.Build.Utils where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Monad (msum) +import Data.Char (isLower) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD +import Distribution.PackageDescription.Utils (cabalBug) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup.Common +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.LocalBuildInfo +import Distribution.Utils.Path (getSymbolicPath) +import Distribution.Verbosity +import System.FilePath + ( replaceExtension + , takeExtension + , (<.>) + , () + ) + +-- | 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 + -> (BuildInfo, FilePath) + -- ^ The build info and module path of an executable-like component (Exe, Test, Bench) + -> IO FilePath + -- ^ The path to the main source file. +findExecutableMain verbosity bdir (bnfo, modPath) = + findFileEx verbosity (bdir : map getSymbolicPath (hsSourceDirs bnfo)) modPath + +-- | Does this compiler support the @-dynamic-too@ option +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" + +-- | Is this compiler's RTS dynamically linked? +isDynamic :: Compiler -> Bool +isDynamic = Internal.ghcLookupProperty "GHC Dynamic" + +-- | Should we dynamically link the foreign library, based on its 'foreignLibType'? +withDynFLib :: ForeignLib -> Bool +withDynFLib flib = + case foreignLibType flib of + ForeignLibNativeShared -> + ForeignLibStandalone `notElem` foreignLibOptions flib + ForeignLibNativeStatic -> + False + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + +-- | 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"] + +-- | 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 + +-- | 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 + +-- | 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 + +-- | Gets the target name (name of actual executable file) from the name of an +-- executable-like component ('Executable', 'TestSuite', 'Benchmark'). +exeTargetName :: Platform -> UnqualComponentName -> String +exeTargetName platform name = unUnqualComponentName name `withExt` exeExtension platform + where + withExt :: FilePath -> String -> FilePath + withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else "" + +-- | "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 + :: BuildInfo + -- ^ The build info of the executable-like component (Exe, Test, Bench) + -> ModuleName +exeMainModuleName 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'. + fromMaybe ModuleName.main $ 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) diff --git a/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs b/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs deleted file mode 100644 index 23244662fe2..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 <> toNubListR (extraLibDirs bnfo) - , 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 8123112dd1a..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 <> toNubListR (extraLibDirs libBi) - } - 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 diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index 4c7290aae48..3ab3c85be35 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -514,81 +514,80 @@ componentGhcOptions -> GhcOptions 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! - ghcOptVerbosity = toFlag (min verbosity normal) - , ghcOptCabal = toFlag True - , ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> - toFlag pk - _ | not (unitIdForExes implInfo) -> mempty - ExeComponentLocalBuildInfo{componentUnitId = uid} -> - toFlag (unUnitId uid) - TestComponentLocalBuildInfo{componentUnitId = uid} -> - toFlag (unUnitId uid) - BenchComponentLocalBuildInfo{componentUnitId = uid} -> - toFlag (unUnitId uid) - FLibComponentLocalBuildInfo{componentUnitId = uid} -> - toFlag (unUnitId uid) - , ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentComponentId = cid - , componentInstantiatedWith = insts - } -> - if null insts - then mempty - else toFlag cid - _ -> mempty - , ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> - insts - _ -> [] - , ghcOptNoCode = toFlag $ componentIsIndefinite clbi - , ghcOptHideAllPackages = toFlag True - , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi - , ghcOptSplitSections = toFlag (splitSections lbi) - , ghcOptSplitObjs = toFlag (splitObjs lbi) - , ghcOptSourcePathClear = toFlag True - , ghcOptSourcePath = - toNubListR $ - map getSymbolicPath (hsSourceDirs bi) - ++ [odir] - ++ [autogenComponentModulesDir lbi clbi] - ++ [autogenPackageModulesDir lbi] - , ghcOptCppIncludePath = - toNubListR $ - [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi - , odir - ] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi] - , ghcOptCppOptions = cppOptions bi - , ghcOptCppIncludes = - toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName] - , ghcOptFfiIncludes = toNubListR $ includes bi - , ghcOptObjDir = toFlag odir - , ghcOptHiDir = toFlag odir - , ghcOptHieDir = bool NoFlag (toFlag $ odir extraCompilationArtifacts "hie") $ flagHie implInfo - , ghcOptStubDir = toFlag odir - , ghcOptOutputDir = toFlag odir - , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) - , ghcOptDebugInfo = toFlag (withDebugInfo lbi) - , ghcOptExtra = hcOptions GHC bi - , ghcOptExtraPath = toNubListR $ exe_paths - , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)) - , -- Unsupported extensions have already been checked by configure - ghcOptExtensions = toNubListR $ usedExtensions bi - , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (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! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptCabal = toFlag True + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ | not (unitIdForExes implInfo) -> mempty + ExeComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + TestComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + BenchComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + FLibComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentComponentId = cid + , componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag cid + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptNoCode = toFlag $ componentIsIndefinite clbi + , ghcOptHideAllPackages = toFlag True + , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi + , ghcOptSplitSections = toFlag (splitSections lbi) + , ghcOptSplitObjs = toFlag (splitObjs lbi) + , ghcOptSourcePathClear = toFlag True + , ghcOptSourcePath = + toNubListR $ + map getSymbolicPath (hsSourceDirs bi) + ++ [odir] + ++ [autogenComponentModulesDir lbi clbi] + ++ [autogenPackageModulesDir lbi] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptCppOptions = cppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [autogenComponentModulesDir lbi clbi cppHeaderName] + , ghcOptFfiIncludes = toNubListR $ includes bi + , ghcOptObjDir = toFlag odir + , ghcOptHiDir = toFlag odir + , ghcOptHieDir = bool NoFlag (toFlag $ odir extraCompilationArtifacts "hie") $ flagHie implInfo + , ghcOptStubDir = toFlag odir + , ghcOptOutputDir = toFlag odir + , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) + , ghcOptDebugInfo = toFlag (withDebugInfo lbi) + , ghcOptExtra = hcOptions GHC bi + , ghcOptExtraPath = toNubListR $ exe_paths + , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)) + , -- Unsupported extensions have already been checked by configure + ghcOptExtensions = toNubListR $ usedExtensions bi + , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) + } where exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt)