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

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

    import GHC.Prelude
    import GHC.Platform

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

    import qualified GHC.Data.ShortText as ST

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

    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 cFile <- Logger
    -> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
    newTempName Logger
    logger TmpFs
    tmpfs (DynFlags -> TempDir
    tmpDir DynFlags
    dflags) TempFileLifetime
    TFL_CurrentModule String
    extn
          oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o"
          writeFile cFile xs
          runCc Nothing logger tmpfs dflags
                ([Option        "-c",
                  FileOption "" cFile,
                  Option        "-o",
                  FileOption "" oFile]
                  ++ if extn /= "s"
                        then cOpts
                        else [])
          return 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 = (String -> Option) -> [String] -> [Option]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> Option
    Option (DynFlags -> [String]
    picCCOpts DynFlags
    dflags)
                        [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)
                                (GenericUnitInfo
      PackageId
      PackageName
      UnitId
      ModuleName
      (GenModule (GenUnit UnitId))
    -> [ShortText]
    forall srcpkgid srcpkgname uid modulename mod.
    GenericUnitInfo srcpkgid srcpkgname uid modulename mod
    -> [ShortText]
    unitIncludeDirs (GenericUnitInfo
       PackageId
       PackageName
       UnitId
       ModuleName
       (GenModule (GenUnit UnitId))
     -> [ShortText])
    -> GenericUnitInfo
         PackageId
         PackageName
         UnitId
         ModuleName
         (GenModule (GenUnit UnitId))
    -> [ShortText]
    forall a b. (a -> b) -> a -> b
    $ HasDebugCallStack =>
    UnitState
    -> GenUnit UnitId
    -> GenericUnitInfo
         PackageId
         PackageName
         UnitId
         ModuleName
         (GenModule (GenUnit UnitId))
    UnitState
    -> GenUnit UnitId
    -> GenericUnitInfo
         PackageId
         PackageName
         UnitId
         ModuleName
         (GenModule (GenUnit UnitId))
    unsafeLookupUnit UnitState
    unit_state GenUnit UnitId
    rtsUnit)

    -- 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
      Bool -> IO () -> IO ()
    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) (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.")

      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
          -> Maybe String -> IO (Maybe String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe String
    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
          -> Maybe String -> IO (Maybe String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe String
    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 = (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
    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 -> DynFlags -> UnitState -> String -> String -> IO String
    mkExtraObj Logger
    logger TmpFs
    tmpfs DynFlags
    dflags UnitState
    unit_state String
    "c" (String -> IO String) -> (SDoc -> String) -> SDoc -> IO String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DynFlags -> SDoc -> String
    showSDoc DynFlags
    dflags

        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 ZCMain_main_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 (DynFlags -> RtsOptsEnabled
    rtsOptsEnabled DynFlags
    dflags)) 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 DynFlags -> Bool
    rtsOptsSuggestions DynFlags
    dflags
                    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 GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_KeepCAFs DynFlags
    dflags
                    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 DynFlags -> Maybe String
    rtsOpts DynFlags
    dflags of
                Maybe String
    Nothing   -> SDoc
    forall doc. IsOutput doc => doc
    Outputable.empty
                Just String
    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
    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,&ZCMain_main_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
            ]

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

       if (platformSupportsSavingLinkOpts (platformOS platform ))
         then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info))
         else return []

      where
        unit_state :: UnitState
    unit_state = HasDebugCallStack => UnitEnv -> UnitState
    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
    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 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
    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
            ]

    -- | 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
        package_link_opts <- GhcNameVersion
    -> Ways -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])
    getUnitLinkOpts (DynFlags -> GhcNameVersion
    ghcNameVersion DynFlags
    dflags) (DynFlags -> Ways
    ways DynFlags
    dflags) 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)
        let 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
                 , (Option -> String) -> [Option] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Option -> String
    showOpt (DynFlags -> [Option]
    ldInputs DynFlags
    dflags)
                 , DynFlags -> (DynFlags -> [String]) -> [String]
    forall a. DynFlags -> (DynFlags -> [a]) -> [a]
    getOpts DynFlags
    dflags DynFlags -> [String]
    opt_l
                 )
        return (show link_info)

    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 -> 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.
     = 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 <- DynFlags -> UnitEnv -> [UnitId] -> IO String
    getLinkInfo DynFlags
    dflags UnitEnv
    unit_env [UnitId]
    pkg_deps
       debugTraceMsg logger 3 $ text ("Link info: " ++ link_info)
       m_exe_link_info <- readElfNoteAsString logger exe_file
                              ghcLinkInfoSectionName ghcLinkInfoNoteName
       let sameLinkInfo = (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    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).

    -}

    haveRtsOptsFlags :: DynFlags -> Bool
    haveRtsOptsFlags :: DynFlags -> Bool
    haveRtsOptsFlags DynFlags
    dflags =
            Maybe String -> Bool
    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