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

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

import GHC.Utils.Asm
import GHC.Utils.Error
import GHC.Driver.Session
import GHC.Unit.State
import GHC.Platform
import GHC.Utils.Outputable as Outputable
import GHC.Types.SrcLoc ( noSrcSpan )
import GHC.Unit
import GHC.SysTools.Elf
import GHC.Utils.Misc
import GHC.Prelude

import Control.Monad
import Data.Maybe

import Control.Monad.IO.Class

import GHC.SysTools.FileCleanup
import GHC.SysTools.Tasks
import GHC.SysTools.Info

mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
mkExtraObj :: DynFlags -> String -> String -> IO String
mkExtraObj DynFlags
dflags String
extn String
xs
 = do String
cFile <- DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule String
extn
      String
oFile <- DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
TFL_GhcSession String
"o"
      String -> String -> IO ()
writeFile String
cFile String
xs
      CompilerInfo
ccInfo <- IO CompilerInfo -> IO CompilerInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
External instance of the constraint type MonadIO IO
liftIO (IO CompilerInfo -> IO CompilerInfo)
-> IO CompilerInfo -> IO CompilerInfo
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO CompilerInfo
getCompilerInfo DynFlags
dflags
      Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()
runCc Maybe ForeignSrcLang
forall a. Maybe a
Nothing 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]
              [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ if String
extn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Char
/= String
"s"
                    then [Option]
cOpts
                    else CompilerInfo -> [Option]
asmOpts CompilerInfo
ccInfo)
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
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 = (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]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Option
FileOption String
"-I")
                            (GenericUnitInfo
  (Indefinite UnitId)
  PackageId
  PackageName
  UnitId
  ModuleName
  (GenModule (GenUnit UnitId))
-> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitIncludeDirs (GenericUnitInfo
   (Indefinite UnitId)
   PackageId
   PackageName
   UnitId
   ModuleName
   (GenModule (GenUnit UnitId))
 -> [String])
-> GenericUnitInfo
     (Indefinite UnitId)
     PackageId
     PackageName
     UnitId
     ModuleName
     (GenModule (GenUnit UnitId))
-> [String]
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack =>
DynFlags
-> GenUnit UnitId
-> GenericUnitInfo
     (Indefinite UnitId)
     PackageId
     PackageName
     UnitId
     ModuleName
     (GenModule (GenUnit UnitId))
DynFlags
-> GenUnit UnitId
-> GenericUnitInfo
     (Indefinite UnitId)
     PackageId
     PackageName
     UnitId
     ModuleName
     (GenModule (GenUnit UnitId))
External instance of the constraint type HasDebugCallStack
unsafeGetUnitInfo DynFlags
dflags GenUnit UnitId
rtsUnitId)

      -- 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 (CompilerInfo -> Bool) -> [CompilerInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
External instance of the constraint type Foldable []
any (CompilerInfo
ccInfo CompilerInfo -> CompilerInfo -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq CompilerInfo
==) [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 :: DynFlags -> IO FilePath
mkExtraObjToLinkIntoBinary :: DynFlags -> IO String
mkExtraObjToLinkIntoBinary DynFlags
dflags = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
External instance of the constraint type Applicative IO
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
$ do
     DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevInfo SrcSpan
noSrcSpan
         (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> MsgDoc -> MsgDoc
withPprStyle PprStyle
defaultUserStyle
         (String -> MsgDoc
text String
"Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." MsgDoc -> MsgDoc -> MsgDoc
$$
          String -> MsgDoc
text String
"    Call hs_init_ghc() from your main() function to set these options.")

  DynFlags -> String -> String -> IO String
mkExtraObj DynFlags
dflags String
"c" (DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags MsgDoc
main)
  where
    main :: MsgDoc
main
      | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags = MsgDoc
Outputable.empty
      | Bool
otherwise
          = case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
                  GhcLink
LinkDynLib -> if Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq OS
== OS
OSMinGW32
                                    then MsgDoc
dllMain
                                    else MsgDoc
Outputable.empty
                  GhcLink
_                      -> MsgDoc
exeMain

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

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

   if (OS -> Bool
platformSupportsSavingLinkOpts (Platform -> OS
platformOS Platform
platform ))
     then (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor IO
fmap (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (IO String -> IO [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> String -> String -> IO String
mkExtraObj DynFlags
dflags String
"s" (DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (String -> MsgDoc
link_opts String
link_info))
     else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return []

  where
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    link_opts :: String -> MsgDoc
link_opts String
info = [MsgDoc] -> MsgDoc
hcat [
      -- "link info" section (see Note [LinkInfo section])
      Platform -> String -> String -> Word32 -> String -> MsgDoc
makeElfNote Platform
platform String
ghcLinkInfoSectionName String
ghcLinkInfoNoteName Word32
0 String
info,

      -- ALL generated assembly must have this section to disable
      -- executable stacks.  See also
      -- compiler/nativeGen/AsmCodeGen.hs for another instance
      -- where we need to do this.
      if Platform -> Bool
platformHasGnuNonexecStack Platform
platform
        then String -> MsgDoc
text String
".section .note.GNU-stack,\"\","
             MsgDoc -> MsgDoc -> MsgDoc
<> Platform -> String -> MsgDoc
sectionType Platform
platform String
"progbits" MsgDoc -> MsgDoc -> MsgDoc
<> Char -> MsgDoc
char Char
'\n'
        else MsgDoc
Outputable.empty
      ]

-- | Return the "link info" string
--
-- See Note [LinkInfo section]
getLinkInfo :: DynFlags -> [UnitId] -> IO String
getLinkInfo :: DynFlags -> [UnitId] -> IO String
getLinkInfo DynFlags
dflags [UnitId]
dep_packages = do
   ([String], [String], [String])
package_link_opts <- DynFlags -> [UnitId] -> IO ([String], [String], [String])
getPackageLinkOpts DynFlags
dflags [UnitId]
dep_packages
   [String]
pkg_frameworks <- if Platform -> Bool
platformUsesFrameworks (DynFlags -> Platform
targetPlatform DynFlags
dflags)
                     then DynFlags -> [UnitId] -> IO [String]
getPackageFrameworks DynFlags
dflags [UnitId]
dep_packages
                     else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return []
   let extra_ld_inputs :: [Option]
extra_ld_inputs = DynFlags -> [Option]
ldInputs DynFlags
dflags
   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,
                   (Option -> String) -> [Option] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Option -> String
showOpt [Option]
extra_ld_inputs,
                   DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_l)
   --
   String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return ((([String], [String], [String]), [String], Maybe String,
 RtsOptsEnabled, Bool, [String], [String])
-> String
forall a. Show a => a -> String
External instance of the constraint type forall a b c d e f g.
(Show a, Show b, Show c, Show d, Show e, Show f, Show g) =>
Show (a, b, c, d, e, f, g)
External instance of the constraint type forall a b c. (Show a, Show b, Show c) => Show (a, b, c)
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type Show Char
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type Show Char
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type Show Char
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type Show Char
External instance of the constraint type forall a. Show a => Show (Maybe a)
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type Show Char
External instance of the constraint type Show RtsOptsEnabled
External instance of the constraint type Show Bool
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type Show Char
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type Show Char
show (([String], [String], [String]), [String], Maybe String,
 RtsOptsEnabled, Bool, [String], [String])
link_info)

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