From acd31e51d9a98bc0fba9e92ef659c7dbea6c6ac0 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Tue, 9 Jan 2024 13:35:29 +0000 Subject: [PATCH] Refactor the core component building logic 1. Refactors the duplicated `buildExtraSources` function from `gbuild` and `buildOrReplLib` into a standalone monadic computation in the context of building a component. This refactor allows us to share the code for building an extra source amongst the two functions. 2. Creates a new module Distribution.Simple.GHC.Build.Modules which, in the same spirit as ...GHC.Build.ExtraModules, defines an action which builds all the Haskell modules of the component being built. This function clarifies and re-implements the logic of building Haskell modules in the different possible ways, while accounting for Template Haskell special "way requirements", which was previously duplicated in a non-obvious manner in gbuild and buildOrReplLib. The Note [Building Haskell modules accounting for TH] in that module explains the big picture, and the implementation is re-done in light of it. 3. Re-work the linker invocations, focusing on preserving existing behaviour before simplifying or fixing bugs any further. Fixes #9389. --- Cabal/Cabal.cabal | 7 +- Cabal/src/Distribution/Simple/Build.hs | 103 +-- Cabal/src/Distribution/Simple/Build/Inputs.hs | 74 ++ Cabal/src/Distribution/Simple/GHC.hs | 74 +- Cabal/src/Distribution/Simple/GHC/Build.hs | 382 +++------ .../Simple/GHC/Build/ExtraSources.hs | 242 ++++++ .../src/Distribution/Simple/GHC/Build/Link.hs | 662 ++++++++++++++++ .../Distribution/Simple/GHC/Build/Modules.hs | 352 +++++++++ .../Distribution/Simple/GHC/Build/Utils.hs | 217 +++++ .../Distribution/Simple/GHC/BuildGeneric.hs | 747 ------------------ .../Distribution/Simple/GHC/BuildOrRepl.hs | 541 ------------- Cabal/src/Distribution/Simple/GHC/Internal.hs | 167 ++-- Cabal/src/Distribution/Simple/GHCJS.hs | 23 +- Cabal/src/Distribution/Simple/Setup.hs | 38 +- Cabal/src/Distribution/Simple/Utils.hs | 26 +- 15 files changed, 1900 insertions(+), 1755 deletions(-) create mode 100644 Cabal/src/Distribution/Simple/Build/Inputs.hs create mode 100644 Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs create mode 100644 Cabal/src/Distribution/Simple/GHC/Build/Link.hs create mode 100644 Cabal/src/Distribution/Simple/GHC/Build/Modules.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 e6187ce9a18..cbd52b5a6e8 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -88,6 +88,7 @@ library Distribution.Simple Distribution.Simple.Bench Distribution.Simple.Build + Distribution.Simple.Build.Inputs Distribution.Simple.Build.Macros Distribution.Simple.Build.PackageInfoModule Distribution.Simple.Build.PathsModule @@ -332,8 +333,10 @@ library Distribution.Simple.Build.PackageInfoModule.Z Distribution.Simple.Build.PathsModule.Z Distribution.Simple.GHC.Build - Distribution.Simple.GHC.BuildOrRepl - Distribution.Simple.GHC.BuildGeneric + Distribution.Simple.GHC.Build.ExtraSources + Distribution.Simple.GHC.Build.Link + Distribution.Simple.GHC.Build.Modules + Distribution.Simple.GHC.Build.Utils Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.Internal Distribution.Simple.GHC.ImplInfo diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 429afced1ba..afe571d7196 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -161,7 +161,7 @@ build pkg_descr lbi flags suffixes = do NoFlag -> Serial mb_ipi <- buildComponent - verbosity + flags par_strat pkg_descr lbi' @@ -301,7 +301,7 @@ repl pkg_descr lbi flags suffixes args = do lbi' = lbiForComponent comp lbi preBuildComponent verbosity lbi subtarget buildComponent - verbosity + mempty{buildVerbosity = toFlag verbosity} NoFlag pkg_descr lbi' @@ -316,9 +316,8 @@ repl pkg_descr lbi flags suffixes args = do let clbi = targetCLBI target comp = targetComponent target lbi' = lbiForComponent comp lbi - replFlags = replReplOptions flags preBuildComponent verbosity lbi target - replComponent replFlags verbosity pkg_descr lbi' suffixes comp clbi distPref + replComponent flags verbosity pkg_descr lbi' suffixes comp clbi distPref -- | Start an interpreter without loading any package files. startInterpreter @@ -335,7 +334,7 @@ startInterpreter verbosity programDb comp platform packageDBs = _ -> dieWithException verbosity REPLNotSupported buildComponent - :: Verbosity + :: BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo @@ -344,12 +343,12 @@ buildComponent -> ComponentLocalBuildInfo -> FilePath -> IO (Maybe InstalledPackageInfo) -buildComponent verbosity _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = - dieWithException verbosity $ NoSupportBuildingTestSuite tt -buildComponent verbosity _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = - dieWithException verbosity $ NoSupportBuildingBenchMark tt +buildComponent flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = + dieWithException (fromFlag $ buildVerbosity flags) $ NoSupportBuildingTestSuite tt +buildComponent flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = + dieWithException (fromFlag $ buildVerbosity flags) $ NoSupportBuildingBenchMark tt buildComponent - verbosity + flags numJobs pkg_descr lbi0 @@ -364,6 +363,7 @@ buildComponent -- built. distPref = do + let verbosity = fromFlag $ buildVerbosity flags pwd <- getCurrentDirectory let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd @@ -378,7 +378,7 @@ buildComponent (maybeComponentInstantiatedWith clbi) let libbi = libBuildInfo lib lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir} - buildLib verbosity numJobs pkg lbi lib' libClbi + buildLib flags numJobs pkg lbi lib' libClbi -- NB: need to enable multiple instances here, because on 7.10+ -- the package name is the same as the library, and we still -- want the registration to go through. @@ -399,7 +399,7 @@ buildComponent buildExe verbosity numJobs pkg_descr lbi exe' exeClbi return Nothing -- Can't depend on test suite buildComponent - verbosity + flags numJobs pkg_descr lbi @@ -408,6 +408,7 @@ buildComponent clbi distPref = do + let verbosity = fromFlag $ buildVerbosity flags preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi setupMessage' @@ -430,7 +431,7 @@ buildComponent libbi } - buildLib verbosity numJobs pkg_descr lbi lib' clbi + buildLib flags numJobs pkg_descr lbi lib' clbi let oneComponentRequested (OneComponentRequestedSpec _) = True oneComponentRequested _ = False @@ -573,7 +574,7 @@ addSrcDir bi extra = bi{hsSourceDirs = new} new = ordNub (unsafeMakeSymbolicPath extra : hsSourceDirs bi) replComponent - :: ReplOptions + :: ReplFlags -> Verbosity -> PackageDescription -> LocalBuildInfo @@ -604,7 +605,7 @@ replComponent extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} - replLib replFlags verbosity pkg lbi lib' libClbi + replLib replFlags pkg lbi lib' libClbi replComponent replFlags verbosity @@ -621,23 +622,23 @@ replComponent CLib lib -> do let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} - replLib replFlags verbosity pkg_descr lbi lib' clbi + replLib replFlags pkg_descr lbi lib' clbi CFLib flib -> - replFLib replFlags verbosity pkg_descr lbi flib clbi + replFLib replFlags pkg_descr lbi flib clbi CExe exe -> do let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} - replExe replFlags verbosity pkg_descr lbi exe' clbi + replExe replFlags pkg_descr lbi exe' clbi CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do let exe = testSuiteExeV10AsExe test let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} - replExe replFlags verbosity pkg_descr lbi exe' clbi + replExe replFlags pkg_descr lbi exe' clbi CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do let exe = benchmarkExeV10asExe bm let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} - replExe replFlags verbosity pkg_descr lbi exe' clbi + replExe replFlags pkg_descr lbi exe' clbi #if __GLASGOW_HASKELL__ < 811 -- silence pattern-match warnings prior to GHC 9.0 _ -> error "impossible" @@ -822,20 +823,21 @@ addInternalBuildTools pkg lbi bi progs = -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style test suites buildLib - :: Verbosity + :: BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity numJobs pkg_descr lbi lib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi - GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi - UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi - HaskellSuite{} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi - _ -> dieWithException verbosity BuildingNotSupportedWithCompiler +buildLib flags numJobs pkg_descr lbi lib clbi = + let verbosity = fromFlag $ buildVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi + GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + HaskellSuite{} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler -- | Build a foreign library -- @@ -870,47 +872,48 @@ buildExe verbosity numJobs pkg_descr lbi exe clbi = _ -> dieWithException verbosity BuildingNotSupportedWithCompiler replLib - :: ReplOptions - -> Verbosity + :: ReplFlags -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -replLib replFlags verbosity pkg_descr lbi lib clbi = - case compilerFlavor (compiler lbi) of - -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass - -- NoFlag as the numJobs parameter. - GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi - GHCJS -> GHCJS.replLib (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi lib clbi - _ -> dieWithException verbosity REPLNotSupported +replLib replFlags pkg_descr lbi lib clbi = + let verbosity = fromFlag $ replVerbosity replFlags + opts = replReplOptions replFlags + in case compilerFlavor (compiler lbi) of + -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass + -- NoFlag as the numJobs parameter. + GHC -> GHC.replLib replFlags NoFlag pkg_descr lbi lib clbi + GHCJS -> GHCJS.replLib (replOptionsFlags opts) verbosity NoFlag pkg_descr lbi lib clbi + _ -> dieWithException verbosity REPLNotSupported replExe - :: ReplOptions - -> Verbosity + :: ReplFlags -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () -replExe replFlags verbosity pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi - GHCJS -> GHCJS.replExe (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi exe clbi - _ -> dieWithException verbosity REPLNotSupported +replExe flags pkg_descr lbi exe clbi = + let verbosity = fromFlag $ replVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.replExe flags NoFlag pkg_descr lbi exe clbi + GHCJS -> GHCJS.replExe (replOptionsFlags $ replReplOptions flags) verbosity NoFlag pkg_descr lbi exe clbi + _ -> dieWithException verbosity REPLNotSupported replFLib - :: ReplOptions - -> Verbosity + :: ReplFlags -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () -replFLib replFlags verbosity pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.replFLib replFlags verbosity NoFlag pkg_descr lbi exe clbi - _ -> dieWithException verbosity REPLNotSupported +replFLib flags pkg_descr lbi exe clbi = + let verbosity = fromFlag $ replVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi + _ -> dieWithException verbosity REPLNotSupported -- | Pre-build steps for a component: creates the autogenerated files -- for a particular configured component. diff --git a/Cabal/src/Distribution/Simple/Build/Inputs.hs b/Cabal/src/Distribution/Simple/Build/Inputs.hs new file mode 100644 index 00000000000..48b3b60a12b --- /dev/null +++ b/Cabal/src/Distribution/Simple/Build/Inputs.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Distribution.Simple.Build.Inputs + ( -- * Inputs of actions for building components + PreBuildComponentInputs (..) + + -- * Queries over the component being built + , buildVerbosity + , buildComponent + , buildIsLib + , buildCLBI + , buildBI + , buildCompiler + + -- * Re-exports + , BuildingWhat (..) + , LocalBuildInfo (..) + , TargetInfo (..) + , buildingWhatVerbosity + , buildingWhatDistPref + ) +where + +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 + +-- | The information required for a build computation which is available right +-- before building each component, i.e. the pre-build component inputs. +data PreBuildComponentInputs = PreBuildComponentInputs + { buildingWhat :: BuildingWhat + -- ^ What kind of build are we doing? + , localBuildInfo :: LocalBuildInfo + -- ^ Information about the package + , targetInfo :: TargetInfo + -- ^ Information about an individual component + } + +-- | Get the @'Verbosity'@ from the context the component being built is in. +buildVerbosity :: PreBuildComponentInputs -> Verbosity +buildVerbosity = buildingWhatVerbosity . buildingWhat + +-- | Get the @'Component'@ being built. +buildComponent :: PreBuildComponentInputs -> Component +buildComponent = targetComponent . targetInfo + +-- | Is the @'Component'@ being built a @'Library'@? +buildIsLib :: PreBuildComponentInputs -> 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 :: PreBuildComponentInputs -> ComponentLocalBuildInfo +buildCLBI = targetCLBI . targetInfo + +-- | Get the @'BuildInfo'@ of the component being built. +buildBI :: PreBuildComponentInputs -> BuildInfo +buildBI = componentBuildInfo . buildComponent + +-- | Get the @'Compiler'@ being used to build the component. +buildCompiler :: PreBuildComponentInputs -> Compiler +buildCompiler = compiler . localBuildInfo diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 1a6d0d5d86d..449dc695a69 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -56,8 +56,8 @@ module Distribution.Simple.GHC , libAbiHash , hcPkgInfo , registerPackage - , componentGhcOptions - , componentCcGhcOptions + , Internal.componentGhcOptions + , Internal.componentCcGhcOptions , getGhcAppDir , getLibDir , isDynamic @@ -91,16 +91,13 @@ import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Package import Distribution.PackageDescription as PD import Distribution.Pretty +import Distribution.Simple.Build.Inputs (PreBuildComponentInputs (..)) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors import Distribution.Simple.Flag (Flag (..), toFlag) -import Distribution.Simple.GHC.Build - ( componentGhcOptions - , exeTargetName - , flibTargetName - , isDynamic - ) +import qualified Distribution.Simple.GHC.Build as GHC +import Distribution.Simple.GHC.Build.Utils import Distribution.Simple.GHC.EnvironmentParser import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal @@ -118,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 @@ -137,13 +135,12 @@ import System.FilePath ) import qualified System.Info #ifndef mingw32_HOST_OS -import Distribution.Simple.GHC.Build (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 -- ----------------------------------------------------------------------------- -- Configuring @@ -570,25 +567,28 @@ getInstalledPackagesMonitorFiles verbosity platform progdb = -- Building a library buildLib - :: Verbosity + :: BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -buildLib = buildOrReplLib Nothing +buildLib flags numJobs pkg lbi lib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs (BuildNormal flags) lbi (TargetInfo clbi (CLib lib)) replLib - :: ReplOptions - -> Verbosity + :: ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -replLib = buildOrReplLib . Just +replLib flags numJobs pkg lbi lib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs (BuildRepl flags) lbi (TargetInfo clbi (CLib lib)) -- | Start a REPL without loading any source files. startInterpreter @@ -620,19 +620,21 @@ buildFLib -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib +buildFLib v numJobs pkg lbi flib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CFLib flib)) replFLib - :: ReplOptions - -> Verbosity + :: ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () -replFLib replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplFLib replFlags +replFLib replFlags njobs pkg lbi flib clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs (BuildRepl replFlags) lbi (TargetInfo clbi (CFLib flib)) -- | Build an executable with GHC. buildExe @@ -643,19 +645,21 @@ buildExe -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe +buildExe v njobs pkg lbi exe clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CExe exe)) replExe - :: ReplOptions - -> Verbosity + :: ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () -replExe replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplExe replFlags +replExe replFlags njobs pkg lbi exe clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs (BuildRepl replFlags) lbi (TargetInfo clbi (CExe exe)) -- | Extracts a String representing a hash of the ABI of a built -- library. It can fail if the library has not yet been built. @@ -672,7 +676,7 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do comp = compiler lbi platform = hostPlatform lbi vanillaArgs = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + (Internal.componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash , ghcOptInputModules = toNubListR $ exposedModules lib @@ -713,20 +717,6 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do return (takeWhile (not . isSpace) hash) -componentCcGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - -- ----------------------------------------------------------------------------- -- Installing @@ -753,7 +743,7 @@ installExe exe = do createDirectoryIfMissingVerbose verbosity True binDir let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeTargetName (hostPlatform lbi) exe + exeFileName = exeTargetName (hostPlatform lbi) (exeName exe) fixedExeBaseName = progprefix ++ exeName' ++ progsuffix installBinary dest = do installExecutableFile diff --git a/Cabal/src/Distribution/Simple/GHC/Build.hs b/Cabal/src/Distribution/Simple/GHC/Build.hs index 4afd2a03a2f..cc50e3bdb3c 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build.hs @@ -1,262 +1,140 @@ -module Distribution.Simple.GHC.Build - ( getRPaths - , runReplOrWriteFlags - , checkNeedsRecompilation - , replNoLoad - , componentGhcOptions - , supportsDynamicToo - , isDynamic - , flibBuildName - , flibTargetName - , exeTargetName - ) -where +module Distribution.Simple.GHC.Build where import Distribution.Compat.Prelude import Prelude () -import qualified Data.ByteString.Lazy.Char8 as BS -import Distribution.Compat.Binary (encode) -import Distribution.Compat.ResponseFile (escapeArgs) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Package -import Distribution.PackageDescription as PD -import Distribution.PackageDescription.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 Control.Monad.IO.Class +import qualified Data.Set as Set +import Distribution.PackageDescription as PD hiding (buildInfo) +import Distribution.Simple.Build.Inputs +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.Verbosity -import Distribution.Version -import System.Directory - ( createDirectoryIfMissing - , getCurrentDirectory - ) +import Distribution.Types.ComponentLocalBuildInfo (componentIsIndefinite) +import Distribution.Types.ParStrat +import Distribution.Utils.NubList (fromNubListR) +import System.Directory hiding (exeExtension) import System.FilePath - ( isRelative - , replaceExtension - , takeExtension - , (<.>) - , () - ) -exeTargetName :: Platform -> Executable -> String -exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform - -withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else "" - --- | 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 - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - -isDynamic :: Compiler -> Bool -isDynamic = Internal.ghcLookupProperty "GHC Dynamic" - -componentGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi = - Internal.componentGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - -replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a -replNoLoad replFlags l - | replOptionsNoLoad replFlags == Flag True = mempty - | otherwise = l - --- | Finds the object file name of the given source file -getObjectFileName :: FilePath -> GhcOptions -> FilePath -getObjectFileName filename opts = oname - where - odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext - --- | Returns True if the modification date of the given source file is newer than --- the object file we last compiled for it, or if no object file exists yet. -checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool -checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where - oname = getObjectFileName filename opts - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths - :: LocalBuildInfo - -> ComponentLocalBuildInfo - -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux = True - supportRPaths Windows = False - supportRPaths OSX = True - supportRPaths FreeBSD = - case compid of - CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True - _ -> False - supportRPaths OpenBSD = False - supportRPaths NetBSD = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Wasi = False - supportRPaths Hurd = True - supportRPaths Haiku = False - supportRPaths (OtherOS _) = False --- Do _not_ add a default case so that we get a warning here when a new OS --- is added. - -getRPaths _ _ = return mempty - -runReplOrWriteFlags - :: Verbosity - -> ConfiguredProgram - -> Compiler - -> Platform - -> ReplOptions - -> GhcOptions - -> BuildInfo - -> ComponentLocalBuildInfo - -> PackageName +{- +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 + -> PreBuildComponentInputs + -- ^ The context and component being built in it. -> IO () -runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts bi clbi pkg_name = - case replOptionsFlagOutput rflags of - NoFlag -> runGHC verbosity ghcProg comp platform replOpts - 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 (replOpts{ghcOptMode = NoFlag}) +build numJobs pkg_descr pbci = do + let + verbosity = buildVerbosity pbci + component = buildComponent pbci + isLib = buildIsLib pbci + lbi = localBuildInfo pbci + clbi = buildCLBI pbci + + -- 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") + | otherwise = error "GHC.build: targetDir is empty" + + liftIO $ do + createDirectoryIfMissingVerbose verbosity True targetDir_absolute + createDirectoryIfMissingVerbose verbosity True buildTargetDir_absolute + + -- See Note [Build Target Dir vs Target Dir] as well + _targetDir <- liftIO $ makeRelativeToCurrentDirectory targetDir_absolute + buildTargetDir <- + -- 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 + -- 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] + -- I don't see why we shouldn't build with dynamic + -- indefinite components. + <> [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 pbci + extraSources <- buildAllExtraSources ghcProg buildTargetDir pbci + linkOrLoadComponent ghcProg pkg_descr (fromNubListR extraSources) (buildTargetDir, targetDir_absolute) (wantedWays, buildOpts) pbci diff --git a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs new file mode 100644 index 00000000000..07ad6ac31d8 --- /dev/null +++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Distribution.Simple.GHC.Build.ExtraSources where + +import Control.Monad +import Data.Foldable +import Distribution.Simple.Flag +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.Program.GHC +import Distribution.Simple.Utils +import Distribution.Utils.NubList + +import Distribution.Types.BuildInfo +import Distribution.Types.Component +import Distribution.Types.TargetInfo + +import Distribution.Simple.GHC.Build.Utils +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.Types +import Distribution.System (Arch (JavaScript), Platform (..)) +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.Executable +import Distribution.Verbosity (Verbosity) + +import Distribution.Simple.Build.Inputs + +-- | 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 + -> FilePath + -- ^ The build directory for this target + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (NubListR FilePath) + -- ^ Returns the (nubbed) list of extra sources that were built +buildAllExtraSources = + mconcat + [ buildCSources + , buildCxxSources + , buildJsSources + , buildAsmSources + , buildCmmSources + ] + +buildCSources + , buildCxxSources + , buildJsSources + , buildAsmSources + , buildCmmSources + :: ConfiguredProgram + -- ^ The GHC configured program + -> FilePath + -- ^ The build directory for this target + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (NubListR FilePath) + -- ^ Returns the list of extra sources that were built +buildCSources = + buildExtraSources + "C Sources" + Internal.componentCcGhcOptions + True + ( \c -> + cSources (componentBuildInfo c) + ++ case c of + CExe exe | isC (modulePath exe) -> [modulePath exe] + _otherwise -> [] + ) +buildCxxSources = + buildExtraSources + "C++ Sources" + Internal.componentCxxGhcOptions + True + ( \c -> + cxxSources (componentBuildInfo c) + ++ case c of + CExe exe | isCxx (modulePath exe) -> [modulePath exe] + _otherwise -> [] + ) +buildJsSources ghcProg buildTargetDir = do + Platform hostArch _ <- hostPlatform <$> localBuildInfo + let hasJsSupport = hostArch == JavaScript + buildExtraSources + "JS Sources" + Internal.componentJsGhcOptions + False + ( \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" + Internal.componentAsmGhcOptions + True + (asmSources . componentBuildInfo) +buildCmmSources = + buildExtraSources + "C-- Sources" + Internal.componentCmmGhcOptions + True + (cmmSources . componentBuildInfo) + +-- | Create 'PreBuildComponentRules' for a given type of extra build sources +-- which are compiled via a GHC invocation with the given options. Used to +-- define built-in extra sources, such as, C, Cxx, Js, Asm, and Cmm sources. +buildExtraSources + :: String + -- ^ String describing the extra sources being built, for printing. + -> (Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions) + -- ^ Function to determine the @'GhcOptions'@ for the + -- invocation of GHC when compiling these extra sources (e.g. + -- @'Internal.componentCxxGhcOptions'@, + -- @'Internal.componentCmmGhcOptions'@) + -> Bool + -- ^ Some types of build sources should not be built in the dynamic way, namely, JS sources. + -- I'm not entirely sure this remains true after we migrate to supporting GHC's JS backend rather than GHCJS. + -- Boolean for "do we allow building these sources the dynamic way?" + -> (Component -> [FilePath]) + -- ^ View the extra sources of a component, typically from + -- the build info (e.g. @'asmSources'@, @'cSources'@). + -- @'Executable'@ components might additionally add the + -- program entry point (@main-is@ file) to the extra sources, + -- if it should be compiled as the rest of them. + -> ConfiguredProgram + -- ^ The GHC configured program + -> FilePath + -- ^ The build directory for this target + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (NubListR FilePath) + -- ^ Returns the list of extra sources that were built +buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcProg buildTargetDir = + \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> + let + bi = componentBuildInfo (targetComponent targetInfo) + verbosity = buildingWhatVerbosity buildingWhat + clbi = targetCLBI targetInfo + + sources = viewSources (targetComponent targetInfo) + + comp = compiler lbi + platform = hostPlatform lbi + -- Instead of keeping this logic here, we really just want to + -- receive as an input the `neededWays` from GHC/Build.build and build + -- accordingly, since we've already determined the extra needed ways + -- needed for e.g. template haskell. Although we'd have to account for 'wantDyn'. + isGhcDynamic = isDynamic comp + doingTH = usesTemplateHaskellOrQQ bi + forceSharedLib = doingTH && isGhcDynamic + runGhcProg = runGHC verbosity ghcProg comp platform + + buildAction sourceFile = do + let baseSrcOpts = + componentSourceGhcOptions + verbosity + lbi + bi + clbi + buildTargetDir + sourceFile + vanillaSrcOpts + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + | isGhcDynamic && wantDyn = baseSrcOpts{ghcOptFPic = toFlag True} + | otherwise = baseSrcOpts + profSrcOpts = + vanillaSrcOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedSrcOpts = + vanillaSrcOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + -- TODO: Placing all Haskell, C, & C++ objects in a single directory + -- Has the potential for file collisions. In general we would + -- consider this a user error. However, we should strive to + -- add a warning if this occurs. + odir = fromFlag (ghcOptObjDir vanillaSrcOpts) + compileIfNeeded opts = do + needsRecomp <- checkNeedsRecompilation sourceFile opts + when needsRecomp $ runGhcProg opts + + -- TODO: This whole section can be streamlined to the + -- wantedWays+neededWays logic used in Build/Modules.hs + createDirectoryIfMissingVerbose verbosity True odir + case targetComponent targetInfo of + -- For libraries, we compile extra objects in the three ways: vanilla, shared, and profiled. + -- We suffix shared objects with .dyn_o and profiled ones with .p_o. + CLib _lib + -- Unless for repl, in which case we only need the vanilla way + | BuildRepl _ <- buildingWhat -> + compileIfNeeded vanillaSrcOpts + | otherwise -> + do + compileIfNeeded vanillaSrcOpts + when (wantDyn && (forceSharedLib || withSharedLib lbi)) $ + compileIfNeeded sharedSrcOpts{ghcOptObjSuffix = toFlag "dyn_o"} + when (withProfLib lbi) $ + compileIfNeeded profSrcOpts{ghcOptObjSuffix = toFlag "p_o"} + + -- For foreign libraries, we determine with which options to build the + -- objects (vanilla vs shared vs profiled) + CFLib flib + | withProfExe lbi -> -- It doesn't sound right to query "ProfExe" for a foreign library... + compileIfNeeded profSrcOpts + | withDynFLib flib && wantDyn -> + compileIfNeeded sharedSrcOpts + | otherwise -> + compileIfNeeded vanillaSrcOpts + -- For the remaining component types (Exec, Test, Bench), we also + -- determine with which options to build the objects (vanilla vs shared vs + -- profiled), but predicate is the same for the three kinds. + _exeLike + | withProfExe lbi -> + compileIfNeeded profSrcOpts + | withDynExe lbi && wantDyn -> + compileIfNeeded sharedSrcOpts + | otherwise -> + compileIfNeeded vanillaSrcOpts + in + -- build any sources + if (null sources || componentIsIndefinite clbi) + then return mempty + else do + info verbosity ("Building " ++ description ++ "...") + traverse_ buildAction sources + return (toNubListR 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..ab80a152268 --- /dev/null +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -0,0 +1,662 @@ +{-# 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.Inputs +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. + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO () +linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) (wantedWays, buildOpts) pbci = do + let + verbosity = buildVerbosity pbci + target = targetInfo pbci + component = buildComponent pbci + what = buildingWhat pbci + lbi = localBuildInfo pbci + bi = buildBI pbci + clbi = buildCLBI pbci + + -- ensure extra lib dirs exist before passing to ghc + cleanedExtraLibDirs <- liftIO $ filterM doesDirectoryExist (extraLibDirs bi) + cleanedExtraLibDirsStatic <- liftIO $ filterM doesDirectoryExist (extraLibDirsStatic bi) + + let + extraSourcesObjs = map (`replaceExtension` objExtension) extraSources + + -- TODO: Shouldn't we use withStaticLib for libraries and something else + -- for foreign libs in the three cases where we use `withFullyStaticExe` below? + linkerOpts rpaths = + mempty + { ghcOptLinkOptions = + PD.ldOptions bi + ++ [ "-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 bi + else extraLibs bi + , ghcOptLinkLibPath = + toNubListR $ + 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. + -- However, it maybe should, for uniformity. + 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. + -- + -- 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 pbci 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 + ] + ] + + -- 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...). The downside to doing this is that GHC would have to + -- reconstruct the module graph again. + -- 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 + { -- 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 + , -- TODO: Shouldn't this use cleanedExtraLibDirsStatic instead? + ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + } + + 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) $ + 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 + :: PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (NubListR FilePath) +getRPaths pbci = do + let + lbi = localBuildInfo pbci + bi = buildBI pbci + clbi = buildCLBI pbci + + (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 new file mode 100644 index 00000000000..0a6c408ee4b --- /dev/null +++ b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} + +module Distribution.Simple.GHC.Build.Modules (buildHaskellModules, BuildWay (..), buildWayPrefix) where + +import Control.Monad.IO.Class +import Distribution.Compat.Prelude + +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.Inputs +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.LocalBuildInfo +import Distribution.Simple.Program.GHC +import Distribution.Simple.Program.Types +import Distribution.Simple.Setup.Common +import Distribution.Simple.Utils +import Distribution.Types.Benchmark +import Distribution.Types.BenchmarkInterface +import Distribution.Types.BuildInfo +import Distribution.Types.Executable +import Distribution.Types.ForeignLib +import Distribution.Types.PackageName.Magic +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 (-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. + +In practice, however, we may /need/ to build modules in additional ways beyonds the ones that were requested. +This can happen because of Template Haskell. + +When we're using Template Haskell, we /need/ to additionally build modules with +the used GHC's default/vanilla ABI. This is because the code that TH needs to +run at compile time needs to be the vanilla ABI so it can be loaded up and run +by the compiler. With dynamic-by-default GHC the TH object files loaded at +compile-time need to be .dyn_o instead of .o. + + * If the GHC is dynamic by default, that means we may need to also build + the dynamic way in addition the wanted way. + + * If the GHC is static by default, we may need to build statically additionally. + +Of course, if the /wanted/ way is the way additionally /needed/ for TH, we don't need to do extra work. + +If it turns out that in the end we need to build both statically and +dynamically, we want to make use of GHC's -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 +the order in which modules are built. Specifically, we must first build the +modules for TH with the vanilla ABI, and only afterwards the desired +(non-default) ways. + +A few examples: + +To build an executable with profiling, with a dynamic by default GHC, and TH is used: + * Build dynamic (needed) objects + * Build profiled objects + +To build a library with profiling and dynamically, with a static by default GHC, and TH is used: + * Build dynamic (wanted) and static (needed) objects together with --dynamic-too + * Build profiled objects + +To build an executable statically, with a static by default GHC, regardless of whether TH is used: + * Simply build static objects + +-} + +-- | Compile the Haskell modules of the component being built. +buildHaskellModules + :: Flag ParStrat + -- ^ The parallelism strategy (e.g. num of jobs) + -> ConfiguredProgram + -- ^ The GHC configured program + -> PD.PackageDescription + -- ^ The package description + -> FilePath + -- ^ The path to the build directory for this target, which + -- has already been created. + -> Set.Set BuildWay + -- ^ The set of wanted build ways according to user options + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (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 pbci = do + -- See Note [Building Haskell Modules accounting for TH] + + let + verbosity = buildVerbosity pbci + isLib = buildIsLib pbci + clbi = buildCLBI pbci + lbi = localBuildInfo pbci + bi = buildBI pbci + what = buildingWhat pbci + comp = buildCompiler pbci + + -- 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? + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = Flag $ Hpc.mixDir (buildTargetDir extraCompilationArtifacts) way + | otherwise = mempty + + (inputFiles, inputModules) <- componentInputs buildTargetDir pkg_descr pbci + + let + runGhcProg = runGHC verbosity ghcProg comp platform + platform = hostPlatform lbi + + -- See Note [Building Haskell Modules accounting for TH] + doingTH = usesTemplateHaskellOrQQ bi + + -- 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 + , -- Previously we didn't pass -no-link when building libs, + -- but I 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 (TODO). + ghcOptNoLink = if isLib then NoFlag else toFlag True + , ghcOptNumJobs = numJobs + , ghcOptInputModules = toNubListR inputModules + , ghcOptInputFiles = + toNubListR $ + if PD.package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles + , ghcOptInputScripts = + toNubListR $ + if PD.package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [] + , ghcOptExtra = 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) + + -- 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 = + (baseOpts DynWay) + { ghcOptDynLinkMode = toFlag GhcDynamicOnly -- use -dynamic + , -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True -- use -fPIC + } + profOpts = + (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 = + (baseOpts StaticWay) + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too + , ghcOptDynHiSuffix = toFlag (buildWayPrefix DynWay ++ "hi") + , ghcOptDynObjSuffix = toFlag (buildWayPrefix DynWay ++ "o") + , ghcOptHPCDir = hpcdir Hpc.Dyn + -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation? + -- (Note that `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 $ do + -- See Note [Building Haskell Modules accounting for TH] + let + neededWays = + wantedWays + <> Set.fromList + -- TODO: You also don't need to build the GHC way when doing TH 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 = + 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 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 + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Flag dynDir, Flag vanillaDir) -> + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir + _ -> return () + in + -- 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 -> CompilerFlavor -> BuildInfo -> [String] +buildWayExtraHcOptions = \case + StaticWay -> hcStaticOptions + ProfWay -> hcProfOptions + DynWay -> 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 + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO ([FilePath], [ModuleName]) + -- ^ The Haskell input files, and the Haskell modules +componentInputs buildTargetDir pkg_descr pbci = do + let + verbosity = buildVerbosity pbci + component = buildComponent pbci + clbi = buildCLBI pbci + + case component of + CLib lib -> + pure ([], allLibModules lib clbi) + CFLib flib -> + pure ([], foreignLibModules flib) + CExe Executable{buildInfo = bi', modulePath} -> + exeLikeInputs verbosity bi' modulePath + CTest TestSuite{testBuildInfo = bi', testInterface = TestSuiteExeV10 _ mainFile} -> + exeLikeInputs verbosity bi' mainFile + CBench Benchmark{benchmarkBuildInfo = bi', benchmarkInterface = BenchmarkExeV10 _ mainFile} -> + exeLikeInputs verbosity bi' mainFile + CTest TestSuite{} -> error "testSuiteExeV10AsExe: wrong kind" + CBench Benchmark{} -> error "benchmarkExeV10asExe: wrong kind" + where + exeLikeInputs verbosity bnfo modulePath = liftIO $ do + main <- findExecutableMain verbosity buildTargetDir (bnfo, modulePath) + let mainModName = exeMainModuleName bnfo + otherModNames = otherModules bnfo + + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if isHaskell main || PD.package pkg_descr == fakePackageId + then + if PD.specVersion pkg_descr < CabalSpecV2_0 && (mainModName `elem` otherModNames) + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ + "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + return ([main], filter (/= mainModName) otherModNames) + else return ([main], otherModNames) + else return ([], otherModNames) diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Utils.hs b/Cabal/src/Distribution/Simple/GHC/Build/Utils.hs new file mode 100644 index 00000000000..e5161e343da --- /dev/null +++ b/Cabal/src/Distribution/Simple/GHC/Build/Utils.hs @@ -0,0 +1,217 @@ +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 + Platform _ os = hostPlatform lbi + + -- 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 + Platform _ os = hostPlatform lbi + + 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 330cc656d04..00000000000 --- a/Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs +++ /dev/null @@ -1,747 +0,0 @@ -module Distribution.Simple.GHC.BuildGeneric - ( GBuildMode (..) - , gbuild - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Control.Monad (msum) -import Data.Char (isLower) -import Distribution.CabalSpecVersion -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Package -import Distribution.PackageDescription as PD -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.Pretty -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.GHC.Build - ( checkNeedsRecompilation - , componentGhcOptions - , exeTargetName - , flibBuildName - , flibTargetName - , getRPaths - , isDynamic - , replNoLoad - , runReplOrWriteFlags - , supportsDynamicToo - ) -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 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.Utils.Path -import Distribution.Verbosity -import Distribution.Version -import System.Directory - ( doesDirectoryExist - , doesFileExist - , removeFile - , renameFile - ) -import System.FilePath - ( replaceExtension - , takeExtension - , () - ) - --- | 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 ReplOptions Executable - | GBuildFLib ForeignLib - | GReplFLib ReplOptions 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 -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib - where - withDynFLib flib = - case foreignLibType flib of - ForeignLibNativeShared -> - ForeignLibStandalone `notElem` foreignLibOptions flib - ForeignLibNativeStatic -> - False - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - --- | 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 = modPath} = do - main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath - let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe - 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 - } - - isCxx :: FilePath -> Bool - isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] - --- | 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 - --- | FilePath has a Haskell extension: .hs or .lhs -isHaskell :: FilePath -> Bool -isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - --- | "Main" module name when overridden by @ghc-options: -main-is ...@ --- or 'Nothing' if no @-main-is@ flag could be found. --- --- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. -exeMainModuleName :: Executable -> Maybe ModuleName -exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts - where - ghcopts = hcOptions GHC bnfo - - findIsMainArgs [] = [] - findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest - findIsMainArgs (_ : rest) = findIsMainArgs rest - --- | Decode argument to '-main-is' --- --- Returns 'Nothing' if argument set only the function name. --- --- This code has been stolen/refactored from GHC's DynFlags.setMainIs --- function. The logic here is deliberately imperfect as it is --- intended to be bug-compatible with GHC's parser. See discussion in --- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. -decodeMainIsArg :: String -> Maybe ModuleName -decodeMainIsArg arg - | headOf main_fn isLower = - -- The arg looked like "Foo.Bar.baz" - Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = - Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = - Nothing - where - headOf :: String -> (Char -> Bool) -> Bool - headOf str pred' = any pred' (safeHead str) - - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - - splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) - splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - where - -- 'safeTail' drops the char satisfying 'pred' - (r_suf, r_pre) = break pred' (reverse str) - --- | Generic build function. See comment for 'GBuildMode'. -gbuild - :: Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> GBuildMode - -> ComponentLocalBuildInfo - -> IO () -gbuild verbosity numJobs pkg_descr lbi bm clbi = do - (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 - implInfo = getImplInfo comp - runGhcProg = runGHC verbosity ghcProg comp platform - - 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 <- getRPaths lbi clbi - 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 - isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - cLikeObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - jsObjs = if hasJsSupport then map (`replaceExtension` objExtension) jsSrcs else [] - 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 = - (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 - } - dynTooOpts = - staticOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic - , ghcOptDynHiSuffix = toFlag "dyn_hi" - , ghcOptDynObjSuffix = toFlag "dyn_o" - , 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 replFlags - , ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules baseOpts) - , ghcOptInputFiles = replNoLoad 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 - compileOpts - | useDynToo = dynTooOpts - | otherwise = commonOpts - withStaticExe = not needProfiling && not needDynamic - - -- For building exe's that use TH with -prof or -dynamic we actually have - -- to build twice, once without -prof/-dynamic and then again with - -- -prof/-dynamic. This is because the code that TH needs to run at - -- compile time needs to be the vanilla ABI so it can be loaded up and run - -- by the compiler. - -- With dynamic-by-default GHC the TH object files loaded at compile-time - -- need to be .dyn_o instead of .o. - doingTH = usesTemplateHaskellOrQQ bnfo - -- Should we use -dynamic-too instead of compiling twice? - useDynToo = - dynamicTooSupported - && isGhcDynamic - && doingTH - && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts - | isGhcDynamic = dynOpts - | otherwise = staticOpts - compileForTH - | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ - runGhcProg - compileTHOpts - { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs - } - - -- Do not try to build anything if there are no input files. - -- This can happen if the cabal file ends up with only cSrcs - -- but no Haskell modules. - unless - ( (null inputFiles && null inputModules) - || gbuildIsRepl bm - ) - $ runGhcProg - compileOpts - { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs - } - - let - buildExtraSources mkSrcOpts wantDyn = traverse_ $ buildExtraSource mkSrcOpts wantDyn - buildExtraSource mkSrcOpts wantDyn filename = do - let baseSrcOpts = - mkSrcOpts - verbosity - implInfo - lbi - bnfo - clbi - tmpDir - filename - vanillaSrcOpts = - if isGhcDynamic && wantDyn - then -- Dynamic GHC requires C/C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - baseSrcOpts{ghcOptFPic = toFlag True} - else baseSrcOpts - profSrcOpts = - vanillaSrcOpts - `mappend` mempty - { ghcOptProfilingMode = toFlag True - } - sharedSrcOpts = - vanillaSrcOpts - `mappend` mempty - { ghcOptFPic = toFlag True - , ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts - | needProfiling = profSrcOpts - | needDynamic && wantDyn = sharedSrcOpts - | otherwise = vanillaSrcOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - - -- build any C++ sources - unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - buildExtraSources Internal.componentCxxGhcOptions True cxxSrcs - - -- build any C sources - unless (null cSrcs) $ do - info verbosity "Building C Sources..." - buildExtraSources Internal.componentCcGhcOptions True cSrcs - - -- build any JS sources - unless (not hasJsSupport || null jsSrcs) $ do - info verbosity "Building JS Sources..." - buildExtraSources Internal.componentJsGhcOptions False jsSrcs - - -- build any ASM sources - unless (null asmSrcs) $ do - info verbosity "Building Assembler Sources..." - buildExtraSources Internal.componentAsmGhcOptions True asmSrcs - - -- build any Cmm sources - unless (null cmmSrcs) $ do - info verbosity "Building C-- Sources..." - buildExtraSources Internal.componentCmmGhcOptions True cmmSrcs - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - case bm of - GReplExe _ _ -> runReplOrWriteFlags verbosity ghcProg comp platform replFlags replOpts bnfo clbi (pkgName (PD.package pkg_descr)) - GReplFLib _ _ -> runReplOrWriteFlags verbosity ghcProg comp platform replFlags replOpts bnfo clbi (pkgName (PD.package pkg_descr)) - 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 64a8f0a6c40..00000000000 --- a/Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs +++ /dev/null @@ -1,541 +0,0 @@ -module Distribution.Simple.GHC.BuildOrRepl (buildOrReplLib) where - -import Distribution.Compat.Prelude -import Prelude () - -import Control.Monad (forM_) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Package -import Distribution.PackageDescription as PD -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.GHC.Build - ( checkNeedsRecompilation - , componentGhcOptions - , getRPaths - , isDynamic - , replNoLoad - , runReplOrWriteFlags - , supportsDynamicToo - ) -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.Utils.NubList -import Distribution.Verbosity -import Distribution.Version -import System.Directory - ( doesDirectoryExist - , makeRelativeToCurrentDirectory - ) -import System.FilePath - ( replaceExtension - , () - ) - -buildOrReplLib - :: Maybe ReplOptions - -> Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO () -buildOrReplLib mReplFlags verbosity 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 = maybe False (const True) mReplFlags - whenReplLib = forM_ mReplFlags - replFlags = fromMaybe mempty mReplFlags - comp = compiler lbi - ghcVersion = compilerVersion comp - implInfo = getImplInfo comp - platform@(Platform hostArch hostOS) = hostPlatform lbi - hasJsSupport = hostArch == JavaScript - has_code = not (componentIsIndefinite clbi) - - 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) - - let isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = usesTemplateHaskellOrQQ libBi - forceVanillaLib = doingTH && not isGhcDynamic - forceSharedLib = doingTH && isGhcDynamic - -- TH always needs default libs, even when building for profiling - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - 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 = componentGhcOptions verbosity lbi libBi clbi libTargetDir - vanillaOpts = - baseOpts - `mappend` mempty - { ghcOptMode = toFlag GhcModeMake - , ghcOptNumJobs = numJobs - , ghcOptInputModules = toNubListR $ allLibModules lib clbi - , ghcOptHPCDir = hpcdir Hpc.Vanilla - } - - profOpts = - vanillaOpts - `mappend` mempty - { ghcOptProfilingMode = toFlag True - , ghcOptProfilingAuto = - Internal.profDetailLevelFlag - True - (withProfLibDetail lbi) - , ghcOptHiSuffix = toFlag "p_hi" - , ghcOptObjSuffix = toFlag "p_o" - , ghcOptExtra = hcProfOptions GHC libBi - , ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = - vanillaOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcDynamicOnly - , ghcOptFPic = toFlag True - , ghcOptHiSuffix = toFlag "dyn_hi" - , ghcOptObjSuffix = toFlag "dyn_o" - , ghcOptExtra = hcSharedOptions GHC libBi - , ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = - mempty - { ghcOptLinkOptions = - 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 - - vanillaSharedOpts = - vanillaOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic - , ghcOptDynHiSuffix = toFlag "dyn_hi" - , ghcOptDynObjSuffix = toFlag "dyn_o" - , ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi)) $ - do - let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) - useDynToo = - dynamicTooSupported - && (forceVanillaLib || withVanillaLib lbi) - && (forceSharedLib || withSharedLib lbi) - && null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Flag dynDir, Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir - _ -> return () - else - if isGhcDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcProg profOpts) - - let - buildExtraSources mkSrcOpts wantDyn = traverse_ $ buildExtraSource mkSrcOpts wantDyn - buildExtraSource mkSrcOpts wantDyn filename = do - let baseSrcOpts = - mkSrcOpts - verbosity - implInfo - lbi - libBi - clbi - relLibTargetDir - filename - vanillaSrcOpts - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - | isGhcDynamic && wantDyn = baseSrcOpts{ghcOptFPic = toFlag True} - | otherwise = baseSrcOpts - runGhcProgIfNeeded opts = do - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ runGhcProg opts - profSrcOpts = - vanillaSrcOpts - `mappend` mempty - { ghcOptProfilingMode = toFlag True - , ghcOptObjSuffix = toFlag "p_o" - } - sharedSrcOpts = - vanillaSrcOpts - `mappend` mempty - { ghcOptFPic = toFlag True - , ghcOptDynLinkMode = toFlag GhcDynamicOnly - , ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaSrcOpts) - - createDirectoryIfMissingVerbose verbosity True odir - runGhcProgIfNeeded vanillaSrcOpts - unless (forRepl || not wantDyn) $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedSrcOpts) - unless forRepl $ - whenProfLib (runGhcProgIfNeeded profSrcOpts) - - -- Build any C++ sources separately. - unless (not has_code || null (cxxSources libBi)) $ do - info verbosity "Building C++ Sources..." - buildExtraSources Internal.componentCxxGhcOptions True (cxxSources libBi) - - -- build any C sources - unless (not has_code || null (cSources libBi)) $ do - info verbosity "Building C Sources..." - buildExtraSources Internal.componentCcGhcOptions True (cSources libBi) - - -- build any JS sources - unless (not has_code || not hasJsSupport || null (jsSources libBi)) $ do - info verbosity "Building JS Sources..." - buildExtraSources Internal.componentJsGhcOptions False (jsSources libBi) - - -- build any ASM sources - unless (not has_code || null (asmSources libBi)) $ do - info verbosity "Building Assembler Sources..." - buildExtraSources Internal.componentAsmGhcOptions True (asmSources libBi) - - -- build any Cmm sources - unless (not has_code || null (cmmSources libBi)) $ do - info verbosity "Building C-- Sources..." - buildExtraSources Internal.componentCmmGhcOptions True (cmmSources libBi) - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - whenReplLib $ \rflags -> do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts libBi clbi (pkgName (PD.package pkg_descr)) - - -- 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 <- getRPaths lbi clbi - - 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 322a227adfd..3ab3c85be35 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -333,14 +333,13 @@ getExtensions verbosity implInfo ghcProg = do componentCcGhcOptions :: Verbosity - -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions -componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename = +componentCcGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! @@ -383,14 +382,13 @@ componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename = componentCxxGhcOptions :: Verbosity - -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions -componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename = +componentCxxGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! @@ -433,14 +431,13 @@ componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename = componentAsmGhcOptions :: Verbosity - -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions -componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = +componentAsmGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! @@ -478,14 +475,13 @@ componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = componentJsGhcOptions :: Verbosity - -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions -componentJsGhcOptions verbosity _implInfo lbi bi clbi odir filename = +componentJsGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! @@ -511,87 +507,87 @@ componentJsGhcOptions verbosity _implInfo lbi bi clbi odir filename = componentGhcOptions :: Verbosity - -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions -componentGhcOptions verbosity implInfo lbi bi clbi odir = - 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) - } +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) + } where exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt) @@ -607,14 +603,13 @@ toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation componentCmmGhcOptions :: Verbosity - -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions -componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename = +componentCmmGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs index 12860ca104f..98daaabf981 100644 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ b/Cabal/src/Distribution/Simple/GHCJS.hs @@ -23,7 +23,7 @@ module Distribution.Simple.GHCJS , hcPkgInfo , registerPackage , componentGhcOptions - , componentCcGhcOptions + , Internal.componentCcGhcOptions , getLibDir , isDynamic , getGlobalPackageDB @@ -1214,7 +1214,6 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do GBuildFLib{} -> mempty comp = compiler lbi platform = hostPlatform lbi - implInfo = getImplInfo comp runGhcProg = runGHC verbosity ghcjsProg comp platform let (bnfo, threaded) = case bm of @@ -1418,7 +1417,6 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity - implInfo lbi bnfo clbi @@ -1465,7 +1463,6 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do let baseCcOpts = Internal.componentCcGhcOptions verbosity - implInfo lbi bnfo clbi @@ -1780,27 +1777,11 @@ componentGhcOptions -> FilePath -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = - let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir - comp = compiler lbi - implInfo = getImplInfo comp + let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi } -componentCcGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - -- ----------------------------------------------------------------------------- -- Installing diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs index b4d55d604ba..cd8f10aff3c 100644 --- a/Cabal/src/Distribution/Simple/Setup.hs +++ b/Cabal/src/Distribution/Simple/Setup.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -131,9 +132,13 @@ module Distribution.Simple.Setup , trueArg , falseArg , optionVerbosity + , BuildingWhat (..) + , buildingWhatVerbosity + , buildingWhatDistPref ) where -import Prelude () +import GHC.Generics (Generic) +import Prelude (FilePath, Show, ($)) import Distribution.Simple.Flag import Distribution.Simple.InstallDirs @@ -154,6 +159,37 @@ import Distribution.Simple.Setup.Repl import Distribution.Simple.Setup.SDist import Distribution.Simple.Setup.Test +import Distribution.Verbosity (Verbosity) + +-- | What kind of build are we doing? +-- +-- Is this a normal build, or is it perhaps for running an interactive +-- session or Haddock? +data BuildingWhat + = -- | A normal build. + BuildNormal BuildFlags + | -- | Build steps for an interactive session. + BuildRepl ReplFlags + | -- | Build steps for generating documentation. + BuildHaddock HaddockFlags + | -- | Build steps for Hscolour. + BuildHscolour HscolourFlags + deriving (Generic, Show) + +buildingWhatVerbosity :: BuildingWhat -> Verbosity +buildingWhatVerbosity = \case + BuildNormal flags -> fromFlag $ buildVerbosity flags + BuildRepl flags -> fromFlag $ replVerbosity flags + BuildHaddock flags -> fromFlag $ haddockVerbosity flags + BuildHscolour flags -> fromFlag $ hscolourVerbosity flags + +buildingWhatDistPref :: BuildingWhat -> FilePath +buildingWhatDistPref = \case + BuildNormal flags -> fromFlag $ buildDistPref flags + BuildRepl flags -> fromFlag $ replDistPref flags + BuildHaddock flags -> fromFlag $ haddockDistPref flags + BuildHscolour flags -> fromFlag $ hscolourDistPref flags + -- The test cases kinda have to be rewritten from the ground up... :/ -- hunitTests :: [Test] -- hunitTests = diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index f05957bc271..64b22c5abee 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -1198,7 +1198,7 @@ findFileCwd verbosity cwd searchPath fileName = findFirstFile (cwd ) [ path fileName - | path <- nub searchPath + | path <- ordNub searchPath ] >>= maybe (dieWithException verbosity $ FindFileCwd fileName) return @@ -1214,7 +1214,7 @@ findFileEx verbosity searchPath fileName = findFirstFile id [ path fileName - | path <- nub searchPath + | path <- ordNub searchPath ] >>= maybe (dieWithException verbosity $ FindFileEx fileName) return @@ -1230,8 +1230,8 @@ findFileWithExtension extensions searchPath baseName = findFirstFile id [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions + | path <- ordNub searchPath + , ext <- ordNub extensions ] -- | @since 3.4.0.0 @@ -1245,8 +1245,8 @@ findFileCwdWithExtension cwd extensions searchPath baseName = findFirstFile (cwd ) [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions + | path <- ordNub searchPath + , ext <- ordNub extensions ] -- | @since 3.4.0.0 @@ -1264,8 +1264,8 @@ findAllFilesCwdWithExtension cwd extensions searchPath basename = findAllFiles (cwd ) [ path basename <.> ext - | path <- nub searchPath - , ext <- nub extensions + | path <- ordNub searchPath + , ext <- ordNub extensions ] findAllFilesWithExtension @@ -1277,8 +1277,8 @@ findAllFilesWithExtension extensions searchPath basename = findAllFiles id [ path basename <.> ext - | path <- nub searchPath - , ext <- nub extensions + | path <- ordNub searchPath + , ext <- ordNub extensions ] -- | Like 'findFileWithExtension' but returns which element of the search path @@ -1292,8 +1292,8 @@ findFileWithExtension' extensions searchPath baseName = findFirstFile (uncurry ()) [ (path, baseName <.> ext) - | path <- nub searchPath - , ext <- nub extensions + | path <- ordNub searchPath + , ext <- ordNub extensions ] findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) @@ -1535,7 +1535,7 @@ copyFilesWith -> IO () copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + let dirs = map (targetDir ) . ordNub . map (takeDirectory . snd) $ srcFiles traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs -- Copy all the files