Skip to content
Snippets Groups Projects
Commit 2decb0e7 authored by Rodrigo Mesquita's avatar Rodrigo Mesquita :seedling:
Browse files

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.
parent b4c99ac2
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 1900 additions and 1755 deletions
Cabal/Cabal.cabal
+ 5
− 2
View file @ 2decb0e7
......@@ -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
......
Cabal/src/Distribution/Simple/Build.hs
+ 53
− 50
View file @ 2decb0e7
......@@ -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.
......
Cabal/src/Distribution/Simple/Build/Inputs.hs 0 → 100644
+ 74
− 0
View file @ 2decb0e7
{-# 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
Cabal/src/Distribution/Simple/GHC.hs
+ 32
− 42
View file @ 2decb0e7
......@@ -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
......
Cabal/src/Distribution/Simple/GHC/Build.hs
+ 130
− 252
View file @ 2decb0e7
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/<name-of-target-dir>-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 == <buildDir>/cabal-benchmarks
buildTargetDir == <buildDir>/cabal-benchmarks/cabal-benchmarks-tmp
Or, for a library `Cabal`:
targetDir == <buildDir>/.
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/<name-of-target-dir>-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
Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs 0 → 100644
+ 242
− 0
View file @ 2decb0e7
{-# 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)
Cabal/src/Distribution/Simple/GHC/Build/Link.hs 0 → 100644
+ 662
− 0
View file @ 2decb0e7
{-# 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<version>@. 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
Cabal/src/Distribution/Simple/GHC/Build/Modules.hs 0 → 100644
+ 352
− 0
View file @ 2decb0e7
{-# 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)
Cabal/src/Distribution/Simple/GHC/Build/Utils.hs 0 → 100644
+ 217
− 0
View file @ 2decb0e7
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)
Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs deleted 100644 → 0
+ 0
− 747
View file @ b4c99ac2
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<version>@. 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)
Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs deleted 100644 → 0
+ 0
− 541
View file @ b4c99ac2
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
Cabal/src/Distribution/Simple/GHC/Internal.hs
+ 81
− 86
View file @ 2decb0e7
......@@ -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!
......
Cabal/src/Distribution/Simple/GHCJS.hs
+ 2
− 21
View file @ 2decb0e7
......@@ -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
......
Cabal/src/Distribution/Simple/Setup.hs
+ 37
− 1
View file @ 2decb0e7
......@@ -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 =
......
Cabal/src/Distribution/Simple/Utils.hs
+ 13
− 13
View file @ 2decb0e7
......@@ -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
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment