    -----------------------------------------------------------------------------
    --
    -- GHC Extra object linking code
    --
    -- (c) The GHC Team 2017
    --
    -----------------------------------------------------------------------------

    module GHC.Linker.ExtraObj
       ( mkExtraObj
       , mkExtraObjToLinkIntoBinary
       , mkNoteObjsToLinkIntoBinary
       , checkLinkInfo
       , getLinkInfo
       , getCompilerInfo
       , ghcLinkInfoSectionName
       , ghcLinkInfoNoteName
       , platformSupportsSavingLinkOpts
       , haveRtsOptsFlags
       )
    where

    import GHC.Prelude
    import GHC.Platform

    import GHC.Unit
    import GHC.Unit.Env
    import GHC.Unit.State

    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.Ppr

    import qualified GHC.Data.ShortText as ST

    import GHC.SysTools.Elf
    import GHC.SysTools.Tasks
    import GHC.SysTools.Info
    import GHC.Linker.Unit

    import Control.Monad.IO.Class
    import Control.Monad
    import Data.Maybe

    mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath
    mkExtraObj :: Logger
    -> TmpFs -> DynFlags -> UnitState -> String -> String -> IO String
    mkExtraObj Logger
    logger TmpFs
    tmpfs DynFlags
    dflags UnitState
    unit_state String
    extn String
    xs
     = do String
    cFile <- Logger
    -> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
    newTempName Logger
    logger TmpFs
    tmpfs DynFlags
    dflags TempFileLifetime
    TFL_CurrentModule String
    extn
          String
    oFile <- Logger
    -> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
    newTempName Logger
    logger TmpFs
    tmpfs DynFlags
    dflags TempFileLifetime
    TFL_GhcSession String
    "o"
          String -> String -> IO ()
    writeFile String
    cFile String
    xs
          CompilerInfo
    ccInfo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO forall a b. (a -> b) -> a -> b
    $ Logger -> DynFlags -> IO CompilerInfo
    getCompilerInfo Logger
    logger DynFlags
    dflags
          Maybe ForeignSrcLang
    -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
    runCc forall a. Maybe a
    Nothing Logger
    logger TmpFs
    tmpfs DynFlags
    dflags
                ([String -> Option
    Option        String
    "-c",
                  String -> String -> Option
    FileOption String
    "" String
    cFile,
                  String -> Option
    Option        String
    "-o",
                  String -> String -> Option
    FileOption String
    "" String
    oFile]
                  forall a. [a] -> [a] -> [a]
    ++ if String
    extn forall a. Eq a => a -> a -> Bool
    /= String
    "s"
                        then [Option]
    cOpts
                        else CompilerInfo -> [Option]
    asmOpts CompilerInfo
    ccInfo)
          forall (m :: * -> *) a. Monad m => a -> m a
    return String
    oFile
        where
          -- 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.
          cOpts :: [Option]
    cOpts = forall a b. (a -> b) -> [a] -> [b]
    map String -> Option
    Option (DynFlags -> [String]
    picCCOpts DynFlags
    dflags)
                        forall a. [a] -> [a] -> [a]
    ++ forall a b. (a -> b) -> [a] -> [b]
    map (String -> String -> Option
    FileOption String
    "-I" forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ShortText -> String
    ST.unpack)
                                (forall compid srcpkgid srcpkgname uid modulename mod.
    GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
    -> [ShortText]
    unitIncludeDirs forall a b. (a -> b) -> a -> b
    $ HasDebugCallStack => UnitState -> Unit -> UnitInfo
    unsafeLookupUnit UnitState
    unit_state Unit
    rtsUnit)

          -- When compiling assembler code, we drop the usual C options, and if the
          -- compiler is Clang, we add an extra argument to tell Clang to ignore
          -- unused command line options. See trac #11684.
          asmOpts :: CompilerInfo -> [Option]
    asmOpts CompilerInfo
    ccInfo =
                if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (CompilerInfo
    ccInfo forall a. Eq a => a -> a -> Bool
    ==) [CompilerInfo
    Clang, CompilerInfo
    AppleClang, CompilerInfo
    AppleClang51]
                    then [String -> Option
    Option String
    "-Qunused-arguments"]
                    else []

    -- 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)
    --
    -- On Windows, when making a shared library we also may need a DllMain.
    --
    mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath)
    mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe String)
    mkExtraObjToLinkIntoBinary Logger
    logger TmpFs
    tmpfs DynFlags
    dflags UnitState
    unit_state = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_NoHsMain DynFlags
    dflags Bool -> Bool -> Bool
    && DynFlags -> Bool
    haveRtsOptsFlags DynFlags
    dflags) forall a b. (a -> b) -> a -> b
    $
         Logger -> DynFlags -> SDoc -> IO ()
    logInfo Logger
    logger DynFlags
    dflags forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultUserStyle
             (String -> SDoc
    text String
    "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." SDoc -> SDoc -> SDoc
    $$
              String -> SDoc
    text String
    "    Call hs_init_ghc() from your main() function to set these options.")

      case DynFlags -> GhcLink
    ghcLink DynFlags
    dflags of
        -- 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.
        GhcLink
    _ | GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_NoHsMain DynFlags
    dflags
          -> forall (m :: * -> *) a. Monad m => a -> m a
    return forall a. Maybe a
    Nothing

        GhcLink
    LinkDynLib
          | OS
    OSMinGW32 <- Platform -> OS
    platformOS (DynFlags -> Platform
    targetPlatform DynFlags
    dflags)
          -> SDoc -> IO (Maybe String)
    mk_extra_obj SDoc
    dllMain

          | Bool
    otherwise
          -> forall (m :: * -> *) a. Monad m => a -> m a
    return forall a. Maybe a
    Nothing

        GhcLink
    _ -> SDoc -> IO (Maybe String)
    mk_extra_obj SDoc
    exeMain

      where
        mk_extra_obj :: SDoc -> IO (Maybe String)
    mk_extra_obj = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap forall a. a -> Maybe a
    Just forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Logger
    -> TmpFs -> DynFlags -> UnitState -> String -> String -> IO String
    mkExtraObj Logger
    logger TmpFs
    tmpfs DynFlags
    dflags UnitState
    unit_state String
    "c" forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DynFlags -> SDoc -> String
    showSDoc DynFlags
    dflags

        exeMain :: SDoc
    exeMain = [SDoc] -> SDoc
    vcat [
            String -> SDoc
    text String
    "#include <Rts.h>",
            String -> SDoc
    text String
    "extern StgClosure ZCMain_main_closure;",
            String -> SDoc
    text String
    "int main(int argc, char *argv[])",
            Char -> SDoc
    char Char
    '{',
            String -> SDoc
    text String
    " RtsConfig __conf = defaultRtsConfig;",
            String -> SDoc
    text String
    " __conf.rts_opts_enabled = "
                SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (forall a. Show a => a -> String
    show (DynFlags -> RtsOptsEnabled
    rtsOptsEnabled DynFlags
    dflags)) SDoc -> SDoc -> SDoc
    <> SDoc
    semi,
            String -> SDoc
    text String
    " __conf.rts_opts_suggestions = "
                SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (if DynFlags -> Bool
    rtsOptsSuggestions DynFlags
    dflags
                            then String
    "true"
                            else String
    "false") SDoc -> SDoc -> SDoc
    <> SDoc
    semi,
            String -> SDoc
    text String
    "__conf.keep_cafs = "
                SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (if GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_KeepCAFs DynFlags
    dflags
                           then String
    "true"
                           else String
    "false") SDoc -> SDoc -> SDoc
    <> SDoc
    semi,
            case DynFlags -> Maybe String
    rtsOpts DynFlags
    dflags of
                Maybe String
    Nothing   -> SDoc
    Outputable.empty
                Just String
    opts -> String -> SDoc
    text String
    "    __conf.rts_opts= " SDoc -> SDoc -> SDoc
    <>
                              String -> SDoc
    text (forall a. Show a => a -> String
    show String
    opts) SDoc -> SDoc -> SDoc
    <> SDoc
    semi,
            String -> SDoc
    text String
    " __conf.rts_hs_main = true;",
            String -> SDoc
    text String
    " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
            Char -> SDoc
    char Char
    '}',
            Char -> SDoc
    char Char
    '\n' -- final newline, to keep gcc happy
            ]

        dllMain :: SDoc
    dllMain = [SDoc] -> SDoc
    vcat [
            String -> SDoc
    text String
    "#include <Rts.h>",
            String -> SDoc
    text String
    "#include <windows.h>",
            String -> SDoc
    text String
    "#include <stdbool.h>",
            Char -> SDoc
    char Char
    '\n',
            String -> SDoc
    text String
    "bool",
            String -> SDoc
    text String
    "WINAPI",
            String -> SDoc
    text String
    "DllMain ( HINSTANCE hInstance STG_UNUSED",
            String -> SDoc
    text String
    "        , DWORD reason STG_UNUSED",
            String -> SDoc
    text String
    "        , LPVOID reserved STG_UNUSED",
            String -> SDoc
    text String
    "        )",
            String -> SDoc
    text String
    "{",
            String -> SDoc
    text String
    "  return true;",
            String -> SDoc
    text String
    "}",
            Char -> SDoc
    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 -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath]
    mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [String]
    mkNoteObjsToLinkIntoBinary Logger
    logger TmpFs
    tmpfs DynFlags
    dflags UnitEnv
    unit_env [UnitId]
    dep_packages = do
       String
    link_info <- DynFlags -> UnitEnv -> [UnitId] -> IO String
    getLinkInfo DynFlags
    dflags UnitEnv
    unit_env [UnitId]
    dep_packages

       if (OS -> Bool
    platformSupportsSavingLinkOpts (Platform -> OS
    platformOS Platform
    platform ))
         then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (forall a. a -> [a] -> [a]
    :[]) forall a b. (a -> b) -> a -> b
    $ Logger
    -> TmpFs -> DynFlags -> UnitState -> String -> String -> IO String
    mkExtraObj Logger
    logger TmpFs
    tmpfs DynFlags
    dflags UnitState
    unit_state String
    "s" (DynFlags -> SDoc -> String
    showSDoc DynFlags
    dflags (String -> SDoc
    link_opts String
    link_info))
         else forall (m :: * -> *) a. Monad m => a -> m a
    return []

      where
        unit_state :: UnitState
    unit_state = UnitEnv -> UnitState
    ue_units UnitEnv
    unit_env
        platform :: Platform
    platform   = UnitEnv -> Platform
    ue_platform UnitEnv
    unit_env
        link_opts :: String -> SDoc
    link_opts String
    info = [SDoc] -> SDoc
    hcat
            [ -- "link info" section (see Note [LinkInfo section])
              Platform -> String -> String -> Word32 -> String -> SDoc
    makeElfNote Platform
    platform String
    ghcLinkInfoSectionName String
    ghcLinkInfoNoteName Word32
    0 String
    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
    text String
    ".section .note.GNU-stack,\"\","
                     SDoc -> SDoc -> SDoc
    <> Platform -> String -> SDoc
    sectionType Platform
    platform String
    "progbits" SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char Char
    '\n'
                else SDoc
    Outputable.empty
            ]

    -- | Return the "link info" string
    --
    -- See Note [LinkInfo section]
    getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String
    getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String
    getLinkInfo DynFlags
    dflags UnitEnv
    unit_env [UnitId]
    dep_packages = do
        ([String], [String], [String])
    package_link_opts <- DynFlags
    -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])
    getUnitLinkOpts DynFlags
    dflags UnitEnv
    unit_env [UnitId]
    dep_packages
        [String]
    pkg_frameworks <- if Bool -> Bool
    not (Platform -> Bool
    platformUsesFrameworks (UnitEnv -> Platform
    ue_platform UnitEnv
    unit_env))
          then forall (m :: * -> *) a. Monad m => a -> m a
    return []
          else do
             [UnitInfo]
    ps <- forall a. MaybeErr UnitErr a -> IO a
    mayThrowUnitErr (UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
    preloadUnitsInfo' UnitEnv
    unit_env [UnitId]
    dep_packages)
             forall (m :: * -> *) a. Monad m => a -> m a
    return ([UnitInfo] -> [String]
    collectFrameworks [UnitInfo]
    ps)
        let link_info :: (([String], [String], [String]), [String], Maybe String,
     RtsOptsEnabled, Bool, [String], [String])
    link_info =
                 ( ([String], [String], [String])
    package_link_opts
                 , [String]
    pkg_frameworks
                 , DynFlags -> Maybe String
    rtsOpts DynFlags
    dflags
                 , DynFlags -> RtsOptsEnabled
    rtsOptsEnabled DynFlags
    dflags
                 , GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_NoHsMain DynFlags
    dflags
                 , forall a b. (a -> b) -> [a] -> [b]
    map Option -> String
    showOpt (DynFlags -> [Option]
    ldInputs DynFlags
    dflags)
                 , forall a. DynFlags -> (DynFlags -> [a]) -> [a]
    getOpts DynFlags
    dflags DynFlags -> [String]
    opt_l
                 )
        forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. Show a => a -> String
    show (([String], [String], [String]), [String], Maybe String,
     RtsOptsEnabled, Bool, [String], [String])
    link_info)

    platformSupportsSavingLinkOpts :: OS -> Bool
    platformSupportsSavingLinkOpts :: OS -> Bool
    platformSupportsSavingLinkOpts OS
    os
     | OS
    os 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 -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool
    checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> String -> IO Bool
    checkLinkInfo Logger
    logger DynFlags
    dflags 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.
     = 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
       String
    link_info <- DynFlags -> UnitEnv -> [UnitId] -> IO String
    getLinkInfo DynFlags
    dflags UnitEnv
    unit_env [UnitId]
    pkg_deps
       Logger -> DynFlags -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger DynFlags
    dflags Int
    3 forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    text (String
    "Link info: " forall a. [a] -> [a] -> [a]
    ++ String
    link_info)
       Maybe String
    m_exe_link_info <- Logger
    -> DynFlags -> String -> String -> String -> IO (Maybe String)
    readElfNoteAsString Logger
    logger DynFlags
    dflags String
    exe_file
                              String
    ghcLinkInfoSectionName String
    ghcLinkInfoNoteName
       let sameLinkInfo :: Bool
    sameLinkInfo = (forall a. a -> Maybe a
    Just String
    link_info forall a. Eq a => a -> a -> Bool
    == Maybe String
    m_exe_link_info)
       Logger -> DynFlags -> Int -> SDoc -> IO ()
    debugTraceMsg Logger
    logger DynFlags
    dflags Int
    3 forall a b. (a -> b) -> a -> b
    $ case Maybe String
    m_exe_link_info of
         Maybe String
    Nothing -> String -> SDoc
    text String
    "Exe link info: Not found"
         Just String
    s
           | Bool
    sameLinkInfo -> String -> SDoc
    text (String
    "Exe link info is the same")
           | Bool
    otherwise    -> String -> SDoc
    text (String
    "Exe link info is different: " forall a. [a] -> [a] -> [a]
    ++ String
    s)
       forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> Bool
    not Bool
    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).

    -}

    haveRtsOptsFlags :: DynFlags -> Bool
    haveRtsOptsFlags :: DynFlags -> Bool
    haveRtsOptsFlags DynFlags
    dflags =
            forall a. Maybe a -> Bool
    isJust (DynFlags -> Maybe String
    rtsOpts DynFlags
    dflags) Bool -> Bool -> Bool
    || case DynFlags -> RtsOptsEnabled
    rtsOptsEnabled DynFlags
    dflags of
                                           RtsOptsEnabled
    RtsOptsSafeOnly -> Bool
    False
                                           RtsOptsEnabled
    _ -> Bool
    True