{-# LANGUAGE CPP #-}

-- | Dynamic linker
module GHC.Linker.Dynamic
   ( linkDynLib
   -- * Platform-specifics
   , libmLinkOpts
   )
where

import GHC.Prelude
import GHC.Platform
import GHC.Platform.Ways
import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule))

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

import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.State
import GHC.Linker.MacOS
import GHC.Linker.Unit
import GHC.Linker.External
import GHC.Utils.Logger
import GHC.Utils.TmpFs

import Control.Monad (when)
import System.FilePath

linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkDynLib :: Logger
-> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkDynLib Logger
logger TmpFs
tmpfs DynFlags
dflags0 UnitEnv
unit_env [String]
o_files [UnitId]
dep_packages
 = do
    let platform :: Platform
platform   = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
        arch :: Arch
arch       = Platform -> Arch
platformArch Platform
platform
        os :: OS
os         = Platform -> OS
platformOS Platform
platform

        -- This is a rather ugly hack to fix dynamically linked
        -- GHC on Windows. If GHC is linked with -threaded, then
        -- it links against libHSrts_thr. But if base is linked
        -- against libHSrts, then both end up getting loaded,
        -- and things go wrong. We therefore link the libraries
        -- with the same RTS flags that we link GHC with.
        dflags :: DynFlags
dflags | OS
OSMinGW32 <- OS
os
               , Ways
hostWays Ways -> Way -> Bool
`hasWay` Way
WayDyn
               = DynFlags
dflags0 { targetWays_ = hostWays }
               | Bool
otherwise
               = DynFlags
dflags0

        verbFlags :: [String]
verbFlags = DynFlags -> [String]
getVerbFlags DynFlags
dflags
        o_file :: Maybe String
o_file = DynFlags -> Maybe String
outputFile_ DynFlags
dflags

    pkgs_with_rts <- MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo]
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo' UnitEnv
unit_env [UnitId]
dep_packages)

    let pkg_lib_paths = Ways -> [UnitInfo] -> [String]
collectLibraryDirs (DynFlags -> Ways
ways DynFlags
dflags) [UnitInfo]
pkgs_with_rts
    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 OS
os Bool -> Bool -> Bool
|| OS -> Bool
osMachOTarget OS
os
         , DynFlags -> DynLibLoader
dynLibLoader DynFlags
dflags DynLibLoader -> DynLibLoader -> Bool
forall a. Eq a => a -> a -> Bool
== DynLibLoader
SystemDependent
         , -- Only if we want dynamic libraries
           DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasWay` Way
WayDyn
           -- Only use RPath if we explicitly asked for it
         , DynFlags -> OS -> Bool
useXLinkerRPath DynFlags
dflags OS
os
            = [String
"-L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l, String
"-Xlinker", String
"-rpath", String
"-Xlinker", String
l]
              -- See Note [-Xlinker -rpath vs -Wl,-rpath]
         | Bool
otherwise = [String
"-L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l]

    let lib_paths = DynFlags -> [String]
libraryPaths DynFlags
dflags
    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

    -- In general we don't want to link our dynamic libs against the RTS
    -- package, because the RTS lib comes in several flavours and we want to be
    -- able to pick the flavour when a binary is linked.
    --
    -- But:
    --   * on Windows we need to link the RTS import lib as Windows does not
    --   allow undefined symbols.
    --
    --   * the RTS library path is still added to the library search path above
    --   in case the RTS is being explicitly linked in (see #3807).
    --
    --   * if -flink-rts is used, we link with the rts.
    --
    --   * on wasm we need to ensure libHSrts*.so is listed in
    --   WASM_DYLINK_NEEDED, otherwise dyld can't load it.
    --
    --
    let pkgs_without_rts = (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]
pkgs_with_rts
        pkgs
         | Arch
ArchWasm32 <- Arch
arch      = [UnitInfo]
pkgs_with_rts
         | OS
OSMinGW32 <- OS
os         = [UnitInfo]
pkgs_with_rts
         | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LinkRts DynFlags
dflags = [UnitInfo]
pkgs_with_rts
         | Bool
otherwise               = [UnitInfo]
pkgs_without_rts
        pkg_link_opts = UnitLinkOpts -> [String]
hsLibs UnitLinkOpts
unit_link_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ UnitLinkOpts -> [String]
extraLibs UnitLinkOpts
unit_link_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ UnitLinkOpts -> [String]
otherFlags UnitLinkOpts
unit_link_opts
          where
            namever :: GhcNameVersion
namever = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags
            ways_ :: Ways
ways_   = DynFlags -> Ways
ways DynFlags
dflags
            unit_link_opts :: UnitLinkOpts
unit_link_opts = GhcNameVersion -> Ways -> [UnitInfo] -> UnitLinkOpts
collectLinkOpts GhcNameVersion
namever Ways
ways_ [UnitInfo]
pkgs

        -- probably _stub.o files
        -- and last temporary shared object file
    let extra_ld_inputs = DynFlags -> [Option]
ldInputs DynFlags
dflags

    -- frameworks
    pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs)
    let framework_opts = FrameworkOpts -> Platform -> [String]
getFrameworkOpts (DynFlags -> FrameworkOpts
initFrameworkOpts DynFlags
dflags) Platform
platform

    let linker_config = DynFlags -> LinkerConfig
initLinkerConfig DynFlags
dflags

    case os of
        OS
OSMinGW32 -> do
            -------------------------------------------------------------
            -- Making a DLL
            -------------------------------------------------------------
            let output_fn :: String
output_fn = case Maybe String
o_file of
                            Just String
s -> String
s
                            Maybe String
Nothing -> String
"HSdll.dll"

            Logger -> TmpFs -> LinkerConfig -> [Option] -> IO ()
runLink Logger
logger TmpFs
tmpfs LinkerConfig
linker_config (
                    (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
verbFlags
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
Option String
"-o"
                    , String -> String -> Option
FileOption String
"" String
output_fn
                    , String -> Option
Option String
"-shared"
                    ] [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++
                    [ String -> String -> Option
FileOption String
"-Wl,--out-implib=" (String
output_fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".a")
                    | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SharedImplib DynFlags
dflags
                    ]
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Option
FileOption String
"") [String]
o_files

                 -- Permit the linker to auto link _symbol to _imp_symbol
                 -- This lets us link against DLLs without needing an "import library"
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [String -> Option
Option String
"-Wl,--enable-auto-import"]

                 [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
Option (
                    [String]
lib_path_opts
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_lib_path_opts
                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_link_opts
                ))
        OS
_ | OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin -> do
            -------------------------------------------------------------------
            -- Making a darwin dylib
            -------------------------------------------------------------------
            -- About the options used for Darwin:
            -- -dynamiclib
            --   Apple's way of saying -shared
            -- -undefined dynamic_lookup:
            --   Without these options, we'd have to specify the correct
            --   dependencies for each of the dylibs. Note that we could
            --   (and should) do without this for all libraries except
            --   the RTS; all we need to do is to pass the correct
            --   HSfoo_dyn.dylib files to the link command.
            --   This feature requires Mac OS X 10.3 or later; there is
            --   a similar feature, -flat_namespace -undefined suppress,
            --   which works on earlier versions, but it has other
            --   disadvantages.
            -- -single_module
            --   Build the dynamic library as a single "module", i.e. no
            --   dynamic binding nonsense when referring to symbols from
            --   within the library. The NCG assumes that this option is
            --   specified (on i386, at least).
            --   In XCode 15, -single_module is the default and passing the
            --   flag is now obsolete and raises a warning (#24168). We encode
            --   this information into the toolchain field ...SupportsSingleModule.
            -- -install_name
            --   Mac OS/X stores the path where a dynamic library is (to
            --   be) installed in the library itself.  It's called the
            --   "install name" of the library. Then any library or
            --   executable that links against it before it's installed
            --   will search for it in its ultimate install location.
            --   By default we set the install name to the absolute path
            --   at build time, but it can be overridden by the
            --   -dylib-install-name option passed to ghc. Cabal does
            --   this.
            -------------------------------------------------------------------

            let output_fn :: String
output_fn = case Maybe String
o_file of { Just String
s -> String
s; Maybe String
Nothing -> String
"a.out"; }

            instName <- case DynFlags -> Maybe String
dylibInstallName DynFlags
dflags of
                Just String
n -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
n
                Maybe String
Nothing -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"@rpath" String -> String -> String
`combine` (String -> String
takeFileName String
output_fn)
            runLink logger tmpfs linker_config (
                    map Option verbFlags
                 ++ [ Option "-dynamiclib"
                    , Option "-o"
                    , FileOption "" output_fn
                    ]
                 ++ map Option o_files
                 ++ [ Option "-undefined",
                      Option "dynamic_lookup"
                    ]
                 ++ (if toolSettings_ldSupportsSingleModule (toolSettings dflags)
                        then [ Option "-single_module" ]
                        else [ ])
                 ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ]
                     then [ ]
                     else [ Option "-Wl,-read_only_relocs,suppress" ])
                 ++ [ Option "-install_name", Option instName ]
                 ++ map Option lib_path_opts
                 ++ extra_ld_inputs
                 ++ map Option framework_opts
                 ++ map Option pkg_lib_path_opts
                 ++ map Option pkg_link_opts
                 ++ map Option pkg_framework_opts
                 -- 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 leftover
                 -- libraries in the runInjectRpaths phase below.
                 --
                 -- See Note [Dynamic linking on macOS]
                 ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ]
              )
            -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004
            when (gopt Opt_RPath dflags) $
              runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn
        OS
_ -> do
            -------------------------------------------------------------------
            -- Making a DSO
            -------------------------------------------------------------------

            let output_fn :: String
output_fn = case Maybe String
o_file of { Just String
s -> String
s; Maybe String
Nothing -> String
"a.out"; }
                platform :: Platform
platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags
                unregisterised :: Bool
unregisterised = Platform -> Bool
platformUnregisterised Platform
platform
            let bsymbolicFlag :: [String]
bsymbolicFlag = -- we need symbolic linking to resolve
                                -- non-PIC intra-package-relocations for
                                -- performance (where symbolic linking works)
                                -- See Note [-Bsymbolic assumptions by GHC]
                                -- wasm-ld accepts --Bsymbolic instead
                                [String
"-Wl,-Bsymbolic" | Bool -> Bool
not Bool
unregisterised Bool -> Bool -> Bool
&& Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
/= Arch
ArchWasm32 ]

            Logger -> TmpFs -> LinkerConfig -> [Option] -> IO ()
runLink Logger
logger TmpFs
tmpfs LinkerConfig
linker_config (
                    (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
verbFlags
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ Platform -> [Option]
libmLinkOpts Platform
platform
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
Option String
"-o"
                    , String -> String -> Option
FileOption String
"" String
output_fn
                    ]
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
o_files
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
Option String
"-shared" ]
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
bsymbolicFlag
                    -- Set the library soname. We use -h rather than -soname as
                    -- Solaris 10 doesn't support the latter:
                    -- wasm-ld only accepts -soname and it's of little use anyway
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
Option (String
"-Wl,-h," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
takeFileName String
output_fn) | Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
/= Arch
ArchWasm32 ]
                    -- 1. On wasm, --Bsymbolic is an optimization, not
                    --    a requirement. We build the wasi-sdk sysroot
                    --    shared libs as well as all Haskell shared
                    --    libs with --Bsymbolic, but dyld can handle
                    --    shared libs without --Bsymbolic at
                    --    link-time. Though there will be more
                    --    imports/exports to slow things down.
                    -- 2. --experimental-pic silences wasm-ld warnings
                    --    that PIC is experimental.
                    -- 3. --unresolved-symbols=import-dynamic turns
                    --    unresolved symbols to GOT.mem/GOT.func/env
                    --    imports, which can be gracefully handled by
                    --    dyld as lazy bindings. Ideally we'd only
                    --    enable this for rts since it forward
                    --    references ghc-prim/ghc-internal, but too
                    --    many Haskell packages would be rejected at
                    --    link-time even if their code refers to
                    --    something that will not be called at
                    --    run-time in wasm, so enabling it in the
                    --    driver is a more pragmatic solution.
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
Option String
"-Wl,--Bsymbolic,--experimental-pic,--unresolved-symbols=import-dynamic" | Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchWasm32 ]
                 [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
Option [String]
lib_path_opts
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
pkg_lib_path_opts
                 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
pkg_link_opts
              )

-- | Some platforms require that we explicitly link against @libm@ if any
-- math-y things are used (which we assume to include all programs). See #14022.
libmLinkOpts :: Platform -> [Option]
libmLinkOpts :: Platform -> [Option]
libmLinkOpts Platform
platform
  | Platform -> Bool
platformHasLibm Platform
platform = [String -> Option
Option String
"-lm"]
  | Bool
otherwise                = []

{-
Note [-Bsymbolic assumptions by GHC]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

GHC has a few assumptions about interaction of relocations in NCG and linker:

1. -Bsymbolic resolves internal references when the shared library is linked,
   which is important for performance.
2. When there is a reference to data in a shared library from the main program,
   the runtime linker relocates the data object into the main program using an
   R_*_COPY relocation.
3. If we used -Bsymbolic, then this results in multiple copies of the data
   object, because some references have already been resolved to point to the
   original instance. This is bad!

We work around [3.] for native compiled code by avoiding the generation of
R_*_COPY relocations.

Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable
-Bsymbolic linking there.

See related tickets: #4210, #15338
-}