-----------------------------------------------------------------------------
--
-- 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 UnitLinkOpts
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 =
             ( UnitLinkOpts
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