-- | Linking executables
module GHC.Linker.Executable
   ( linkExecutable
   , ExecutableLinkOpts (..)
   , initExecutableLinkOpts
   -- RTS Opts
   , RtsOptsEnabled (..)
   -- * Link info
   , LinkInfo (..)
   , initLinkInfo
   , checkLinkInfo
   , ghcLinkInfoSectionName
   , ghcLinkInfoNoteName
   , platformSupportsSavingLinkOpts
   )
where

import GHC.Prelude
import GHC.Platform
import GHC.Platform.Ways

import GHC.Unit
import GHC.Unit.Env

import GHC.Utils.Asm
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Logger
import GHC.Utils.TmpFs

import GHC.Driver.Session
import GHC.Driver.Config.Linker

import qualified GHC.Data.ShortText as ST

import GHC.SysTools
import GHC.SysTools.Elf
import GHC.Linker.Config
import GHC.Linker.Unit
import GHC.Linker.MacOS
import GHC.Linker.Windows
import GHC.Linker.Dynamic (libmLinkOpts)
import GHC.Linker.External (runLink)
import GHC.Linker.Static.Utils (exeFileName)

import Control.Monad
import Data.Maybe
import System.FilePath
import System.Directory

data ExecutableLinkOpts = ExecutableLinkOpts
  { ExecutableLinkOpts -> Maybe String
leOutputFile :: Maybe FilePath
  , ExecutableLinkOpts -> GhcNameVersion
leNameVersion :: GhcNameVersion
  , ExecutableLinkOpts -> Ways
leWays :: Ways
  , ExecutableLinkOpts -> DynLibLoader
leDynLibLoader :: DynLibLoader
  , ExecutableLinkOpts -> Bool
leRelativeDynlibPaths :: !Bool
  , ExecutableLinkOpts -> Bool
leUseXLinkerRPath :: !Bool
  , ExecutableLinkOpts -> Bool
leSingleLibFolder :: !Bool
  , ExecutableLinkOpts -> Bool
leWholeArchiveHsLibs :: !Bool
  , ExecutableLinkOpts -> Bool
leGenManifest :: !Bool
  , ExecutableLinkOpts -> Bool
leRPath :: !Bool
  , ExecutableLinkOpts -> Bool
leCompactUnwind :: !Bool
  , ExecutableLinkOpts -> [String]
leLibraryPaths :: [String]
  , ExecutableLinkOpts -> FrameworkOpts
leFrameworkOpts :: FrameworkOpts
  , ExecutableLinkOpts -> ManifestOpts
leManifestOpts :: ManifestOpts
  , ExecutableLinkOpts -> LinkerConfig
leLinkerConfig :: LinkerConfig
  , ExecutableLinkOpts -> OtoolConfig
leOtoolConfig :: OtoolConfig
  , ExecutableLinkOpts -> CcConfig
leCcConfig :: CcConfig
  , ExecutableLinkOpts -> InstallNameConfig
leInstallNameConfig :: InstallNameConfig
  , ExecutableLinkOpts -> [Option]
leInputs :: [Option]
  , ExecutableLinkOpts -> [String]
lePieOpts :: [String]
  , ExecutableLinkOpts -> TempDir
leTempDir :: TempDir
  , ExecutableLinkOpts -> [String]
leVerbFlags :: [String]
  , ExecutableLinkOpts -> Bool
leNoHsMain :: !Bool
  , ExecutableLinkOpts -> String
leMainSymbol :: String
  , ExecutableLinkOpts -> RtsOptsEnabled
leRtsOptsEnabled :: !RtsOptsEnabled
  , ExecutableLinkOpts -> Bool
leRtsOptsSuggestions :: !Bool
  , ExecutableLinkOpts -> Bool
leKeepCafs :: !Bool
  , ExecutableLinkOpts -> Maybe String
leRtsOpts :: Maybe String
  }

initExecutableLinkOpts :: DynFlags -> ExecutableLinkOpts
initExecutableLinkOpts :: DynFlags -> ExecutableLinkOpts
initExecutableLinkOpts DynFlags
dflags =
  let
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    os :: OS
os = Platform -> OS
platformOS Platform
platform
  in ExecutableLinkOpts
    { leOutputFile :: Maybe String
leOutputFile = DynFlags -> Maybe String
outputFile_ DynFlags
dflags
    , leNameVersion :: GhcNameVersion
leNameVersion = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags
    , leWays :: Ways
leWays = DynFlags -> Ways
ways DynFlags
dflags
    , leDynLibLoader :: DynLibLoader
leDynLibLoader = DynFlags -> DynLibLoader
dynLibLoader DynFlags
dflags
    , leRelativeDynlibPaths :: Bool
leRelativeDynlibPaths = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RelativeDynlibPaths DynFlags
dflags
    , leUseXLinkerRPath :: Bool
leUseXLinkerRPath = DynFlags -> OS -> Bool
useXLinkerRPath DynFlags
dflags OS
os
    , leSingleLibFolder :: Bool
leSingleLibFolder = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SingleLibFolder DynFlags
dflags
    , leWholeArchiveHsLibs :: Bool
leWholeArchiveHsLibs = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WholeArchiveHsLibs DynFlags
dflags
    , leGenManifest :: Bool
leGenManifest = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GenManifest DynFlags
dflags
    , leRPath :: Bool
leRPath = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RPath DynFlags
dflags
    , leCompactUnwind :: Bool
leCompactUnwind = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CompactUnwind DynFlags
dflags
    , leLibraryPaths :: [String]
leLibraryPaths = DynFlags -> [String]
libraryPaths DynFlags
dflags
    , leFrameworkOpts :: FrameworkOpts
leFrameworkOpts = DynFlags -> FrameworkOpts
initFrameworkOpts DynFlags
dflags
    , leManifestOpts :: ManifestOpts
leManifestOpts = DynFlags -> ManifestOpts
initManifestOpts DynFlags
dflags
    , leLinkerConfig :: LinkerConfig
leLinkerConfig = DynFlags -> LinkerConfig
initLinkerConfig DynFlags
dflags
    , leCcConfig :: CcConfig
leCcConfig = DynFlags -> CcConfig
configureCc DynFlags
dflags
    , leOtoolConfig :: OtoolConfig
leOtoolConfig = DynFlags -> OtoolConfig
configureOtool DynFlags
dflags
    , leInstallNameConfig :: InstallNameConfig
leInstallNameConfig = DynFlags -> InstallNameConfig
configureInstallName DynFlags
dflags
    , leInputs :: [Option]
leInputs = DynFlags -> [Option]
ldInputs DynFlags
dflags
    , lePieOpts :: [String]
lePieOpts = DynFlags -> [String]
pieCCLDOpts DynFlags
dflags
    , leTempDir :: TempDir
leTempDir = DynFlags -> TempDir
tmpDir DynFlags
dflags
    , leVerbFlags :: [String]
leVerbFlags = DynFlags -> [String]
getVerbFlags DynFlags
dflags
    , leNoHsMain :: Bool
leNoHsMain = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
    , leMainSymbol :: String
leMainSymbol = String
"ZCMain_main"
    , leRtsOptsEnabled :: RtsOptsEnabled
leRtsOptsEnabled = DynFlags -> RtsOptsEnabled
rtsOptsEnabled DynFlags
dflags
    , leRtsOptsSuggestions :: Bool
leRtsOptsSuggestions = DynFlags -> Bool
rtsOptsSuggestions DynFlags
dflags
    , leKeepCafs :: Bool
leKeepCafs = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepCAFs DynFlags
dflags
    , leRtsOpts :: Maybe String
leRtsOpts = DynFlags -> Maybe String
rtsOpts DynFlags
dflags
    }

leHaveRtsOptsFlags :: ExecutableLinkOpts -> Bool
leHaveRtsOptsFlags :: ExecutableLinkOpts -> Bool
leHaveRtsOptsFlags ExecutableLinkOpts
opts =
  Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (ExecutableLinkOpts -> Maybe String
leRtsOpts ExecutableLinkOpts
opts)
  Bool -> Bool -> Bool
|| case ExecutableLinkOpts -> RtsOptsEnabled
leRtsOptsEnabled ExecutableLinkOpts
opts of
      RtsOptsEnabled
RtsOptsSafeOnly -> Bool
False
      RtsOptsEnabled
_ -> Bool
True

linkExecutable :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkExecutable :: Logger
-> TmpFs
-> ExecutableLinkOpts
-> UnitEnv
-> [String]
-> [UnitId]
-> IO ()
linkExecutable Logger
logger TmpFs
tmpfs ExecutableLinkOpts
opts UnitEnv
unit_env [String]
o_files [UnitId]
dep_units = do
    let static_link :: Bool
static_link = Bool
False
    let platform :: Platform
platform   = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
        unit_state :: UnitState
unit_state = HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_homeUnitState UnitEnv
unit_env
        verbFlags :: [String]
verbFlags = ExecutableLinkOpts -> [String]
leVerbFlags ExecutableLinkOpts
opts
        arch_os :: ArchOS
arch_os   = Platform -> ArchOS
platformArchOS Platform
platform
        output_fn :: String
output_fn = ArchOS -> Bool -> Maybe String -> String
exeFileName ArchOS
arch_os Bool
static_link (ExecutableLinkOpts -> Maybe String
leOutputFile ExecutableLinkOpts
opts)
        namever :: GhcNameVersion
namever   = ExecutableLinkOpts -> GhcNameVersion
leNameVersion ExecutableLinkOpts
opts
        -- For the wasm target, when ghc is invoked with -dynamic,
        -- when linking the final .wasm binary we must still ensure
        -- the static archives are selected. Otherwise wasm-ld would
        -- fail to find and link the .so library dependencies. wasm-ld
        -- can link PIC objects into static .wasm binaries fine, so we
        -- only adjust the ways in the final linking step, and only
        -- when linking .wasm binary (which is supposed to be fully
        -- static), not when linking .so shared libraries.
        ways_ :: Ways
ways_
          | Arch
ArchWasm32 <- Platform -> Arch
platformArch Platform
platform = Way -> Ways -> Ways
removeWay Way
WayDyn (Ways -> Ways) -> Ways -> Ways
forall a b. (a -> b) -> a -> b
$ ExecutableLinkOpts -> Ways
leWays ExecutableLinkOpts
opts
          | Bool
otherwise = ExecutableLinkOpts -> Ways
leWays ExecutableLinkOpts
opts

    full_output_fn <- if String -> Bool
isAbsolute String
output_fn
                      then String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
output_fn
                      else do d <- IO String
getCurrentDirectory
                              return $ normalise (d </> output_fn)

    -- get the full list of packages to link with, by combining the
    -- explicit packages with the auto packages and all of their
    -- dependencies, and eliminating duplicates.
    pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)
    let pkg_lib_paths     = Ways -> [UnitInfo] -> [String]
collectLibraryDirs Ways
ways_ [UnitInfo]
pkgs
    let pkg_lib_path_opts = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
get_pkg_lib_path_opts [String]
pkg_lib_paths
        get_pkg_lib_path_opts String
l
         | OS -> Bool
osElfTarget (Platform -> OS
platformOS Platform
platform) Bool -> Bool -> Bool
&&
           ExecutableLinkOpts -> DynLibLoader
leDynLibLoader ExecutableLinkOpts
opts DynLibLoader -> DynLibLoader -> Bool
forall a. Eq a => a -> a -> Bool
== DynLibLoader
SystemDependent Bool -> Bool -> Bool
&&
           Ways
ways_ Ways -> Way -> Bool
`hasWay` Way
WayDyn
            = let libpath :: String
libpath = if ExecutableLinkOpts -> Bool
leRelativeDynlibPaths ExecutableLinkOpts
opts
                            then String
"$ORIGIN" String -> String -> String
</>
                                 (String
l String -> String -> String
`makeRelativeTo` String
full_output_fn)
                            else String
l
                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]
                  rpath :: [String]
rpath = if ExecutableLinkOpts -> Bool
leUseXLinkerRPath ExecutableLinkOpts
opts
                          then [String
"-Xlinker", String
"-rpath", String
"-Xlinker", String
libpath]
                          else []
                  -- Solaris 11's linker does not support -rpath-link option. It silently
                  -- ignores it and then complains about next option which is -l<some
                  -- dir> as being a directory and not expected object file, E.g
                  -- ld: elf error: file
                  -- /tmp/ghc-src/libraries/base/dist-install/build:
                  -- elf_begin: I/O error: region read: Is a directory
                  rpathlink :: [String]
rpathlink = if (Platform -> OS
platformOS Platform
platform) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSSolaris2
                              then []
                              else [String
"-Xlinker", String
"-rpath-link", String
"-Xlinker", String
l]
              in [String
"-L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
rpathlink [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
rpath
         | OS -> Bool
osMachOTarget (Platform -> OS
platformOS Platform
platform) Bool -> Bool -> Bool
&&
           ExecutableLinkOpts -> DynLibLoader
leDynLibLoader ExecutableLinkOpts
opts DynLibLoader -> DynLibLoader -> Bool
forall a. Eq a => a -> a -> Bool
== DynLibLoader
SystemDependent Bool -> Bool -> Bool
&&
           Ways
ways_ Ways -> Way -> Bool
`hasWay` Way
WayDyn Bool -> Bool -> Bool
&&
           ExecutableLinkOpts -> Bool
leUseXLinkerRPath ExecutableLinkOpts
opts
            = let libpath :: String
libpath = if ExecutableLinkOpts -> Bool
leRelativeDynlibPaths ExecutableLinkOpts
opts
                            then String
"@loader_path" String -> String -> String
</>
                                 (String
l String -> String -> String
`makeRelativeTo` String
full_output_fn)
                            else String
l
              in [String
"-L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-Xlinker", String
"-rpath", String
"-Xlinker", String
libpath]
         | Bool
otherwise = [String
"-L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l]

    pkg_lib_path_opts <-
      if leSingleLibFolder opts
      then do
        libs <- getLibs namever ways_ unit_env dep_units
        tmpDir <- newTempSubDir logger tmpfs (leTempDir opts)
        sequence_ [ copyFile lib (tmpDir </> basename)
                  | (lib, basename) <- libs]
        return [ "-L" ++ tmpDir ]
      else pure pkg_lib_path_opts

    let
      dead_strip
        | ExecutableLinkOpts -> Bool
leWholeArchiveHsLibs ExecutableLinkOpts
opts = []
        | Bool
otherwise = if OS -> Bool
osSubsectionsViaSymbols (Platform -> OS
platformOS Platform
platform)
                        then [String
"-Wl,-dead_strip"]
                        else []
    let lib_paths = ExecutableLinkOpts -> [String]
leLibraryPaths ExecutableLinkOpts
opts
    let lib_path_opts = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-L"String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
lib_paths

    extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs opts unit_state
    noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs opts unit_env dep_units

    let
      (pre_hs_libs, post_hs_libs)
        | leWholeArchiveHsLibs opts
        = if platformOS platform == OSDarwin
            then (["-Wl,-all_load"], [])
              -- OS X does not have a flag to turn off -all_load
            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
        | otherwise
        = ([],[])

    pkg_link_opts <- do
        unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units
        return $ otherFlags unit_link_opts ++ dead_strip
                  ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs
                  ++ extraLibs unit_link_opts
                 -- -Wl,-u,<sym> contained in other_flags
                 -- needs to be put before -l<package>,
                 -- otherwise Solaris linker fails linking
                 -- a binary with unresolved symbols in RTS
                 -- which are defined in base package
                 -- the reason for this is a note in ld(1) about
                 -- '-u' option: "The placement of this option
                 -- on the command line is significant.
                 -- This option must be placed before the library
                 -- that defines the symbol."

    -- frameworks
    pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units
    let framework_opts = FrameworkOpts -> Platform -> [String]
getFrameworkOpts (ExecutableLinkOpts -> FrameworkOpts
leFrameworkOpts ExecutableLinkOpts
opts) Platform
platform

        -- probably _stub.o files
    let extra_ld_inputs = ExecutableLinkOpts -> [Option]
leInputs ExecutableLinkOpts
opts

    rc_objs <- case platformOS platform of
      OS
OSMinGW32 | ExecutableLinkOpts -> Bool
leGenManifest ExecutableLinkOpts
opts -> Logger -> TmpFs -> ManifestOpts -> String -> IO [String]
maybeCreateManifest Logger
logger TmpFs
tmpfs (ExecutableLinkOpts -> ManifestOpts
leManifestOpts ExecutableLinkOpts
opts) String
output_fn
      OS
_                              -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

    let linker_config = ExecutableLinkOpts -> LinkerConfig
leLinkerConfig ExecutableLinkOpts
opts
    let args = ( (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
String -> Option
GHC.SysTools.Option [String]
verbFlags
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
GHC.SysTools.Option String
"-o"
                    , String -> String -> Option
GHC.SysTools.FileOption String
"" String
output_fn
                    ]
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ Platform -> [Option]
libmLinkOpts Platform
platform
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
String -> Option
GHC.SysTools.Option (
                    []

                 -- See Note [No PIE when linking]
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ExecutableLinkOpts -> [String]
lePieOpts ExecutableLinkOpts
opts

                 -- Permit the linker to auto link _symbol to _imp_symbol.
                 -- This lets us link against DLLs without needing an "import library".
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
                     then [String
"-Wl,--enable-auto-import"]
                     else [])

                 -- '-no_compact_unwind'
                 -- C++/Objective-C exceptions cannot use optimised
                 -- stack unwinding code. The optimised form is the
                 -- default in Xcode 4 on at least x86_64, and
                 -- without this flag we're also seeing warnings
                 -- like
                 --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
                 -- on x86.
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if Bool -> Bool
not (ExecutableLinkOpts -> Bool
leCompactUnwind ExecutableLinkOpts
opts) Bool -> Bool -> Bool
&&
                        LinkerConfig -> Bool
linkerSupportsCompactUnwind (ExecutableLinkOpts -> LinkerConfig
leLinkerConfig ExecutableLinkOpts
opts) Bool -> Bool -> Bool
&&
                        (Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin) Bool -> Bool -> Bool
&&
                        case Platform -> Arch
platformArch Platform
platform of
                          Arch
ArchX86_64  -> Bool
True
                          Arch
ArchAArch64 -> Bool
True
                          Arch
_ -> Bool
False
                     then [String
"-Wl,-no_compact_unwind"]
                     else [])

                     -- We should rather be asking does it support --gc-sections?
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if LinkerConfig -> Bool
linkerIsGnuLd (ExecutableLinkOpts -> LinkerConfig
leLinkerConfig ExecutableLinkOpts
opts) Bool -> Bool -> Bool
&&
                        Bool -> Bool
not (ExecutableLinkOpts -> Bool
leWholeArchiveHsLibs ExecutableLinkOpts
opts)
                     then [String
"-Wl,--gc-sections"]
                     else [])

                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
o_files
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
lib_path_opts)
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
extra_ld_inputs
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
String -> Option
GHC.SysTools.Option (
                    [String]
rc_objs
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
framework_opts
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_lib_path_opts
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extraLinkObj
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
noteLinkObjs
                 -- See Note [RTS/ghc-internal interface]
                 -- (-u<sym> must come before -lghc-internal...!)
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if UnitId
ghcInternalUnitId UnitId -> [UnitId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
pkgs
                     then [[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"-Wl,-u,"
                                  , [Char
'_' | Platform -> Bool
platformLeadingUnderscore Platform
platform]
                                  , String
"init_ghc_hs_iface" ]]
                     else [])
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_link_opts
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_framework_opts
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
                     --  dead_strip_dylibs, will remove unused dylibs, and thus save
                     --  space in the load commands. The -headerpad is necessary so
                     --  that we can inject more @rpath's later for the left over
                     --  libraries during runInjectRpaths phase.
                     --
                     --  See Note [Dynamic linking on macOS].
                     then [ String
"-Wl,-dead_strip_dylibs", String
"-Wl,-headerpad,8000" ]
                     else [])
               ))

    runLink logger tmpfs linker_config args

    -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004
    when (platformOS platform == OSDarwin && leRPath opts) $
      GHC.Linker.MacOS.runInjectRPaths logger (leOtoolConfig opts) (leInstallNameConfig opts) pkg_lib_paths output_fn

mkExtraObj :: Logger -> TmpFs -> TempDir -> CcConfig -> UnitState -> Suffix -> String -> IO FilePath
mkExtraObj :: Logger
-> TmpFs
-> TempDir
-> CcConfig
-> UnitState
-> String
-> String
-> IO String
mkExtraObj Logger
logger TmpFs
tmpfs TempDir
tmpdir CcConfig
cc_config UnitState
unit_state String
extn String
xs
 = do
      -- Pass a different set of options to the C compiler depending one whether
      -- we're compiling C or assembler. When compiling C, we pass the usual
      -- set of include directories and PIC flags.
      let cOpts :: [Option]
cOpts = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
String -> Option
Option (CcConfig -> [String]
ccPicOpts CcConfig
cc_config)
                  [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (ShortText -> Option) -> [ShortText] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Option
FileOption String
"-I" (String -> Option) -> (ShortText -> String) -> ShortText -> Option
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> String
ST.unpack)
                         (UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitIncludeDirs (UnitInfo -> [ShortText]) -> UnitInfo -> [ShortText]
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitState -> Unit -> UnitInfo
UnitState -> Unit -> UnitInfo
unsafeLookupUnit UnitState
unit_state Unit
rtsUnit)
      cFile <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs TempDir
tmpdir TempFileLifetime
TFL_CurrentModule String
extn
      oFile <- newTempName logger tmpfs tmpdir TFL_GhcSession "o"
      writeFile cFile xs
      runCc Nothing logger tmpfs tmpdir cc_config
            ([Option        "-c",
              FileOption "" cFile,
              Option        "-o",
              FileOption "" oFile]
              ++ if extn /= "s"
                    then cOpts
                    else [])
      return oFile

-- | Create object containing main() entry point
--
-- When linking a binary, we need to create a C main() function that
-- starts everything off.  This used to be compiled statically as part
-- of the RTS, but that made it hard to change the -rtsopts setting,
-- so now we generate and compile a main() stub as part of every
-- binary and pass the -rtsopts setting directly to the RTS (#5373)
mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitState -> IO (Maybe FilePath)
mkExtraObjToLinkIntoBinary :: Logger
-> TmpFs -> ExecutableLinkOpts -> UnitState -> IO (Maybe String)
mkExtraObjToLinkIntoBinary Logger
logger TmpFs
tmpfs ExecutableLinkOpts
opts UnitState
unit_state = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExecutableLinkOpts -> Bool
leNoHsMain ExecutableLinkOpts
opts Bool -> Bool -> Bool
&& ExecutableLinkOpts -> Bool
leHaveRtsOptsFlags ExecutableLinkOpts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
     Logger -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle
         (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"    Call hs_init_ghc() from your main() function to set these options.")

  if ExecutableLinkOpts -> Bool
leNoHsMain ExecutableLinkOpts
opts
    -- Don't try to build the extra object if it is not needed.  Compiling the
    -- extra object assumes the presence of the RTS in the unit database
    -- (because the extra object imports Rts.h) but GHC's build system may try
    -- to build some helper programs before building and registering the RTS!
    -- See #18938 for an example where hp2ps failed to build because of a failed
    -- (unsafe) lookup for the RTS in the unit db.
    then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    else SDoc -> IO (Maybe String)
mk_extra_obj SDoc
exeMain

  where
    tmpdir :: TempDir
tmpdir = ExecutableLinkOpts -> TempDir
leTempDir ExecutableLinkOpts
opts
    cc_config :: CcConfig
cc_config = ExecutableLinkOpts -> CcConfig
leCcConfig ExecutableLinkOpts
opts
    mk_extra_obj :: SDoc -> IO (Maybe String)
mk_extra_obj = (String -> Maybe String) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
String -> Maybe String
forall a. a -> Maybe a
Just (IO String -> IO (Maybe String))
-> (SDoc -> IO String) -> SDoc -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger
-> TmpFs
-> TempDir
-> CcConfig
-> UnitState
-> String
-> String
-> IO String
mkExtraObj Logger
logger TmpFs
tmpfs TempDir
tmpdir CcConfig
cc_config UnitState
unit_state String
"c" (String -> IO String) -> (SDoc -> String) -> SDoc -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext

    exeMain :: SDoc
exeMain = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#include <Rts.h>",
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"extern StgClosure " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (ExecutableLinkOpts -> String
leMainSymbol ExecutableLinkOpts
opts) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"_closure;",
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"int main(int argc, char *argv[])",
        Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'{',
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" RtsConfig __conf = defaultRtsConfig;",
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_opts_enabled = "
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (RtsOptsEnabled -> String
forall a. Show a => a -> String
show (ExecutableLinkOpts -> RtsOptsEnabled
leRtsOptsEnabled ExecutableLinkOpts
opts)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_opts_suggestions = "
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (if ExecutableLinkOpts -> Bool
leRtsOptsSuggestions ExecutableLinkOpts
opts
                then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"true"
                else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"false") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__conf.keep_cafs = "
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (if ExecutableLinkOpts -> Bool
leKeepCafs ExecutableLinkOpts
opts
                then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"true"
                else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"false") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
        case ExecutableLinkOpts -> Maybe String
leRtsOpts ExecutableLinkOpts
opts of
            Maybe String
Nothing   -> SDoc
forall doc. IsOutput doc => doc
Outputable.empty
            Just String
rts_opts -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"    __conf.rts_opts= " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> String
forall a. Show a => a -> String
show String
rts_opts) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_hs_main = true;",
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" return hs_main(argc,argv,&" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (ExecutableLinkOpts -> String
leMainSymbol ExecutableLinkOpts
opts) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"_closure,__conf);",
        Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'}',
        Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'\n' -- final newline, to keep gcc happy
        ]

-- Write out the link info section into a new assembly file. Previously
-- this was included as inline assembly in the main.c file but this
-- is pretty fragile. gas gets upset trying to calculate relative offsets
-- that span the .note section (notably .text) when debug info is present
mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary :: Logger
-> TmpFs
-> ExecutableLinkOpts
-> UnitEnv
-> [UnitId]
-> IO [String]
mkNoteObjsToLinkIntoBinary Logger
logger TmpFs
tmpfs ExecutableLinkOpts
opts UnitEnv
unit_env [UnitId]
dep_packages = do
   link_info <- ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO LinkInfo
initLinkInfo ExecutableLinkOpts
opts UnitEnv
unit_env [UnitId]
dep_packages

   if (platformSupportsSavingLinkOpts (platformOS platform ))
     then fmap (:[]) $ mkExtraObj logger tmpfs tmpdir cc_config unit_state "s" (renderWithContext defaultSDocContext (link_opts link_info))
     else return []

  where
    unit_state :: UnitState
unit_state = HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_homeUnitState UnitEnv
unit_env
    platform :: Platform
platform   = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
    tmpdir :: TempDir
tmpdir = ExecutableLinkOpts -> TempDir
leTempDir ExecutableLinkOpts
opts
    cc_config :: CcConfig
cc_config = ExecutableLinkOpts -> CcConfig
leCcConfig ExecutableLinkOpts
opts
    link_opts :: LinkInfo -> SDoc
link_opts LinkInfo
info = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat
        [ -- "link info" section (see Note [LinkInfo section])
          Platform -> String -> String -> Word32 -> String -> SDoc
makeElfNote Platform
platform String
ghcLinkInfoSectionName String
ghcLinkInfoNoteName Word32
0 (LinkInfo -> String
forall a. Show a => a -> String
show LinkInfo
info)

        -- ALL generated assembly must have this section to disable
        -- executable stacks.  See also
        -- "GHC.CmmToAsm" for another instance
        -- where we need to do this.
        , if Platform -> Bool
platformHasGnuNonexecStack Platform
platform
            then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
".section .note.GNU-stack,\"\","
                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> String -> SDoc
forall doc. IsLine doc => Platform -> String -> doc
sectionType Platform
platform String
"progbits" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'\n'
            else SDoc
forall doc. IsOutput doc => doc
Outputable.empty
        ]

data LinkInfo = LinkInfo
  { LinkInfo -> UnitLinkOpts
liPkgLinkOpts :: UnitLinkOpts
  , LinkInfo -> [String]
liPkgFrameworks :: [String]
  , LinkInfo -> Maybe String
liRtsOpts :: Maybe String
  , LinkInfo -> RtsOptsEnabled
liRtsOptsEnabled :: !RtsOptsEnabled
  , LinkInfo -> Bool
liNoHsMain :: !Bool
  , LinkInfo -> [String]
liLdInputs :: [String]
  , LinkInfo -> [String]
liLdOpts :: [String]
  }
  deriving (Int -> LinkInfo -> String -> String
[LinkInfo] -> String -> String
LinkInfo -> String
(Int -> LinkInfo -> String -> String)
-> (LinkInfo -> String)
-> ([LinkInfo] -> String -> String)
-> Show LinkInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LinkInfo -> String -> String
showsPrec :: Int -> LinkInfo -> String -> String
$cshow :: LinkInfo -> String
show :: LinkInfo -> String
$cshowList :: [LinkInfo] -> String -> String
showList :: [LinkInfo] -> String -> String
Show)


-- | Return the "link info"
--
-- See Note [LinkInfo section]
initLinkInfo :: ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO LinkInfo
initLinkInfo :: ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO LinkInfo
initLinkInfo ExecutableLinkOpts
opts UnitEnv
unit_env [UnitId]
dep_packages = do
    package_link_opts <- GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO UnitLinkOpts
getUnitLinkOpts (ExecutableLinkOpts -> GhcNameVersion
leNameVersion ExecutableLinkOpts
opts) (ExecutableLinkOpts -> Ways
leWays ExecutableLinkOpts
opts) UnitEnv
unit_env [UnitId]
dep_packages
    pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env))
      then return []
      else do
         ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
         return (collectFrameworks ps)
    pure $ LinkInfo
      { liPkgLinkOpts = package_link_opts
      , liPkgFrameworks = pkg_frameworks
      , liRtsOpts = leRtsOpts opts
      , liRtsOptsEnabled = leRtsOptsEnabled opts
      , liNoHsMain = leNoHsMain opts
      , liLdInputs = map showOpt (leInputs opts)
      , liLdOpts = map showOpt (linkerOptionsPost (leLinkerConfig opts))
      }

platformSupportsSavingLinkOpts :: OS -> Bool
platformSupportsSavingLinkOpts :: OS -> Bool
platformSupportsSavingLinkOpts OS
os
 | OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSSolaris2 = Bool
False -- see #5382
 | Bool
otherwise        = OS -> Bool
osElfTarget OS
os

-- See Note [LinkInfo section]
ghcLinkInfoSectionName :: String
ghcLinkInfoSectionName :: String
ghcLinkInfoSectionName = String
".debug-ghc-link-info"
  -- if we use the ".debug" prefix, then strip will strip it by default

-- Identifier for the note (see Note [LinkInfo section])
ghcLinkInfoNoteName :: String
ghcLinkInfoNoteName :: String
ghcLinkInfoNoteName = String
"GHC link info"

-- Returns 'False' if it was, and we can avoid linking, because the
-- previous binary was linked with "the same options".
checkLinkInfo :: Logger -> ExecutableLinkOpts -> UnitEnv -> [UnitId] -> FilePath -> IO Bool
checkLinkInfo :: Logger
-> ExecutableLinkOpts -> UnitEnv -> [UnitId] -> String -> IO Bool
checkLinkInfo Logger
logger ExecutableLinkOpts
opts UnitEnv
unit_env [UnitId]
pkg_deps String
exe_file
 | Bool -> Bool
not (OS -> Bool
platformSupportsSavingLinkOpts (Platform -> OS
platformOS (UnitEnv -> Platform
ue_platform UnitEnv
unit_env)))
 -- ToDo: Windows and OS X do not use the ELF binary format, so
 -- readelf does not work there.  We need to find another way to do
 -- this.
 = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- conservatively we should return True, but not
                -- linking in this case was the behaviour for a long
                -- time so we leave it as-is.
 | Bool
otherwise
 = do
   link_info <- ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO LinkInfo
initLinkInfo ExecutableLinkOpts
opts UnitEnv
unit_env [UnitId]
pkg_deps
   debugTraceMsg logger 3 $ text ("Link info: " ++ show link_info)
   m_exe_link_info <- readElfNoteAsString logger exe_file
                          ghcLinkInfoSectionName ghcLinkInfoNoteName
   let sameLinkInfo = (String -> Maybe String
forall a. a -> Maybe a
Just (LinkInfo -> String
forall a. Show a => a -> String
show LinkInfo
link_info) Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
m_exe_link_info)
   debugTraceMsg logger 3 $ case m_exe_link_info of
     Maybe String
Nothing -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Exe link info: Not found"
     Just String
s
       | Bool
sameLinkInfo -> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Exe link info is the same")
       | Bool
otherwise    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Exe link info is different: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
   return (not sameLinkInfo)

{- Note [LinkInfo section]
   ~~~~~~~~~~~~~~~~~~~~~~~

The "link info" is a string representing the parameters of the link. We save
this information in the binary, and the next time we link, if nothing else has
changed, we use the link info stored in the existing binary to decide whether
to re-link or not.

The "link info" string is stored in a ELF section called ".debug-ghc-link-info"
(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to
not follow the specified record-based format (see #11022).

-}

{-
Note [-Xlinker -rpath vs -Wl,-rpath]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

-Wl takes a comma-separated list of options which in the case of
-Wl,-rpath -Wl,some,path,with,commas parses the path with commas
as separate options.
Buck, the build system, produces paths with commas in them.

-Xlinker doesn't have this disadvantage and as far as I can tell
it is supported by both gcc and clang. Anecdotally nvcc supports
-Xlinker, but not -Wl.
-}