module GHC.Linker.Static
   ( linkBinary
   , linkStaticLib
   )
where

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

import GHC.SysTools
import GHC.SysTools.Ar

import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.Info
import GHC.Unit.State

import GHC.Utils.Logger
import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Utils.TmpFs

import GHC.Linker.MacOS
import GHC.Linker.Unit
import GHC.Linker.Dynamic
import GHC.Linker.ExtraObj
import GHC.Linker.External
import GHC.Linker.Windows
import GHC.Linker.Static.Utils

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

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

-----------------------------------------------------------------------------
-- Static linking, of .o files

-- The list of packages passed to link is the list of packages on
-- which this program depends, as discovered by the compilation
-- manager.  It is combined with the list of packages that the user
-- specifies on the command line with -package flags.
--
-- In one-shot linking mode, we can't discover the package
-- dependencies (because we haven't actually done any compilation or
-- read any interface files), so the user must explicitly specify all
-- the packages.

{-
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.
-}

linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkBinary :: Logger
-> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkBinary = Bool
-> Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
linkBinary' Bool
False

linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkBinary' :: Bool
-> Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
linkBinary' Bool
staticLink Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [FilePath]
o_files [UnitId]
dep_units = do
    let platform :: Platform
platform   = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
        unit_state :: UnitState
unit_state = HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env
        toolSettings' :: ToolSettings
toolSettings' = DynFlags -> ToolSettings
toolSettings DynFlags
dflags
        verbFlags :: [FilePath]
verbFlags = DynFlags -> [FilePath]
getVerbFlags DynFlags
dflags
        arch_os :: ArchOS
arch_os   = Platform -> ArchOS
platformArchOS Platform
platform
        output_fn :: FilePath
output_fn = ArchOS -> Bool -> Maybe FilePath -> FilePath
exeFileName ArchOS
arch_os Bool
staticLink (DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags)
        namever :: GhcNameVersion
namever   = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags
        ways_ :: Ways
ways_     = DynFlags -> Ways
ways DynFlags
dflags

    full_output_fn <- if FilePath -> Bool
isAbsolute FilePath
output_fn
                      then FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
output_fn
                      else do d <- IO FilePath
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] -> [FilePath]
collectLibraryDirs Ways
ways_ [UnitInfo]
pkgs
    let pkg_lib_path_opts = (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePath -> [FilePath]
get_pkg_lib_path_opts [FilePath]
pkg_lib_paths
        get_pkg_lib_path_opts FilePath
l
         | OS -> Bool
osElfTarget (Platform -> OS
platformOS Platform
platform) Bool -> Bool -> Bool
&&
           DynFlags -> DynLibLoader
dynLibLoader DynFlags
dflags 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 :: FilePath
libpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RelativeDynlibPaths DynFlags
dflags
                            then FilePath
"$ORIGIN" FilePath -> FilePath -> FilePath
</>
                                 (FilePath
l FilePath -> FilePath -> FilePath
`makeRelativeTo` FilePath
full_output_fn)
                            else FilePath
l
                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]
                  rpath :: [FilePath]
rpath = if DynFlags -> OS -> Bool
useXLinkerRPath DynFlags
dflags (Platform -> OS
platformOS Platform
platform)
                          then [FilePath
"-Xlinker", FilePath
"-rpath", FilePath
"-Xlinker", FilePath
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 :: [FilePath]
rpathlink = if (Platform -> OS
platformOS Platform
platform) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSSolaris2
                              then []
                              else [FilePath
"-Xlinker", FilePath
"-rpath-link", FilePath
"-Xlinker", FilePath
l]
              in [FilePath
"-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
rpathlink [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
rpath
         | OS -> Bool
osMachOTarget (Platform -> OS
platformOS Platform
platform) Bool -> Bool -> Bool
&&
           DynFlags -> DynLibLoader
dynLibLoader DynFlags
dflags 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
&&
           DynFlags -> OS -> Bool
useXLinkerRPath DynFlags
dflags (Platform -> OS
platformOS Platform
platform)
            = let libpath :: FilePath
libpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RelativeDynlibPaths DynFlags
dflags
                            then FilePath
"@loader_path" FilePath -> FilePath -> FilePath
</>
                                 (FilePath
l FilePath -> FilePath -> FilePath
`makeRelativeTo` FilePath
full_output_fn)
                            else FilePath
l
              in [FilePath
"-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"-Xlinker", FilePath
"-rpath", FilePath
"-Xlinker", FilePath
libpath]
         | Bool
otherwise = [FilePath
"-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l]

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

    let
      dead_strip
        | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WholeArchiveHsLibs DynFlags
dflags = []
        | Bool
otherwise = if OS -> Bool
osSubsectionsViaSymbols (Platform -> OS
platformOS Platform
platform)
                        then [FilePath
"-Wl,-dead_strip"]
                        else []
    let lib_paths = DynFlags -> [FilePath]
libraryPaths DynFlags
dflags
    let lib_path_opts = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-L"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [FilePath]
lib_paths

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

    let
      (pre_hs_libs, post_hs_libs)
        | gopt Opt_WholeArchiveHsLibs dflags
        = 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
        (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts namever ways_ unit_env dep_units
        return $ other_flags ++ dead_strip
                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
                  ++ extra_libs
                 -- -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 -> [FilePath]
getFrameworkOpts (DynFlags -> FrameworkOpts
initFrameworkOpts DynFlags
dflags) Platform
platform

        -- probably _stub.o files
    let extra_ld_inputs = DynFlags -> [Option]
ldInputs DynFlags
dflags

    rc_objs <- case platformOS platform of
      OS
OSMinGW32 | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GenManifest DynFlags
dflags -> Logger -> TmpFs -> DynFlags -> FilePath -> IO [FilePath]
maybeCreateManifest Logger
logger TmpFs
tmpfs DynFlags
dflags FilePath
output_fn
      OS
_                                       -> [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

    let linker_config = DynFlags -> LinkerConfig
initLinkerConfig DynFlags
dflags
    let link DynFlags
dflags [Option]
args = do
          Logger -> TmpFs -> LinkerConfig -> [Option] -> IO ()
runLink Logger
logger TmpFs
tmpfs LinkerConfig
linker_config [Option]
args
          -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RPath DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Logger -> ToolSettings -> [FilePath] -> FilePath -> IO ()
GHC.Linker.MacOS.runInjectRPaths Logger
logger (DynFlags -> ToolSettings
toolSettings DynFlags
dflags) [FilePath]
pkg_lib_paths FilePath
output_fn

    link dflags (
                       map GHC.SysTools.Option verbFlags
                      ++ [ GHC.SysTools.Option "-o"
                         , GHC.SysTools.FileOption "" output_fn
                         ]
                      ++ libmLinkOpts platform
                      ++ map GHC.SysTools.Option (
                         []

                      -- See Note [No PIE when linking]
                      ++ pieCCLDOpts dflags

                      -- Permit the linker to auto link _symbol to _imp_symbol.
                      -- This lets us link against DLLs without needing an "import library".
                      ++ (if platformOS platform == OSMinGW32
                          then ["-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.
                      ++ (if not (gopt Opt_CompactUnwind dflags) &&
                             toolSettings_ldSupportsCompactUnwind toolSettings' &&
                             (platformOS platform == OSDarwin) &&
                             case platformArch platform of
                               Arch
ArchX86     -> Bool
True
                               Arch
ArchX86_64  -> Bool
True
                               ArchARM {}  -> Bool
True
                               Arch
ArchAArch64 -> Bool
True
                               Arch
_ -> Bool
False
                          then ["-Wl,-no_compact_unwind"]
                          else [])

                      -- '-Wl,-read_only_relocs,suppress'
                      -- ld gives loads of warnings like:
                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
                      -- when linking any program. We're not sure
                      -- whether this is something we ought to fix, but
                      -- for now this flags silences them.
                      ++ (if platformOS   platform == OSDarwin &&
                             platformArch platform == ArchX86
                          then ["-Wl,-read_only_relocs,suppress"]
                          else [])

                          -- We should rather be asking does it support --gc-sections?
                      ++ (if toolSettings_ldIsGnuLd toolSettings' &&
                             not (gopt Opt_WholeArchiveHsLibs dflags)
                          then ["-Wl,--gc-sections"]
                          else [])

                      ++ o_files
                      ++ lib_path_opts)
                      ++ extra_ld_inputs
                      ++ map GHC.SysTools.Option (
                         rc_objs
                      ++ framework_opts
                      ++ pkg_lib_path_opts
                      ++ extraLinkObj
                      ++ noteLinkObjs
                      ++ pkg_link_opts
                      ++ pkg_framework_opts
                      ++ (if platformOS platform == 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 [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ]
                          else [])
                    ))

-- | Linking a static lib will not really link anything. It will merely produce
-- a static archive of all dependent static libraries. The resulting library
-- will still need to be linked with any remaining link flags.
linkStaticLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkStaticLib :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkStaticLib Logger
logger DynFlags
dflags UnitEnv
unit_env [FilePath]
o_files [UnitId]
dep_units = do
  let platform :: Platform
platform  = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
      extra_ld_inputs :: [FilePath]
extra_ld_inputs = [ FilePath
f | FileOption FilePath
_ FilePath
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
      modules :: [FilePath]
modules = [FilePath]
o_files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extra_ld_inputs
      arch_os :: ArchOS
arch_os = Platform -> ArchOS
platformArchOS Platform
platform
      output_fn :: FilePath
output_fn = ArchOS -> Bool -> Maybe FilePath -> FilePath
exeFileName ArchOS
arch_os Bool
True (DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags)
      namever :: GhcNameVersion
namever = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags
      ways_ :: Ways
ways_   = DynFlags -> Ways
ways DynFlags
dflags

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

  pkg_cfgs_init <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)

  let pkg_cfgs
        | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LinkRts DynFlags
dflags
        = [UnitInfo]
pkg_cfgs_init
        | Bool
otherwise
        = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
rtsUnitId) (UnitId -> Bool) -> (UnitInfo -> UnitId) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId) [UnitInfo]
pkg_cfgs_init

  archives <- concatMapM (collectArchives namever ways_) pkg_cfgs

  ar <- foldl mappend
        <$> (Archive <$> mapM loadObj modules)
        <*> mapM loadAr archives

  if toolSettings_ldIsGnuLd (toolSettings dflags)
    then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
    else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar

  -- run ranlib over the archive. write*Ar does *not* create the symbol index.
  runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn]