summaryrefslogtreecommitdiff
path: root/compiler/GHC/SysTools/ExtraObj.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/SysTools/ExtraObj.hs')
-rw-r--r--compiler/GHC/SysTools/ExtraObj.hs244
1 files changed, 244 insertions, 0 deletions
diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs
new file mode 100644
index 0000000000..f20f815107
--- /dev/null
+++ b/compiler/GHC/SysTools/ExtraObj.hs
@@ -0,0 +1,244 @@
+-----------------------------------------------------------------------------
+--
+-- 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 AsmUtils
+import ErrUtils
+import GHC.Driver.Session
+import GHC.Driver.Packages
+import GHC.Platform
+import Outputable
+import GHC.Types.SrcLoc ( noSrcSpan )
+import GHC.Types.Module
+import GHC.SysTools.Elf
+import Util
+import GhcPrelude
+
+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 dflags extn xs
+ = do cFile <- newTempName dflags TFL_CurrentModule extn
+ oFile <- newTempName dflags TFL_GhcSession "o"
+ writeFile cFile xs
+ ccInfo <- liftIO $ getCompilerInfo dflags
+ runCc Nothing dflags
+ ([Option "-c",
+ FileOption "" cFile,
+ Option "-o",
+ FileOption "" oFile]
+ ++ if extn /= "s"
+ then cOpts
+ else asmOpts ccInfo)
+ 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 = map Option (picCCOpts dflags)
+ ++ map (FileOption "-I")
+ (includeDirs $ getPackageDetails dflags 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 ccInfo =
+ if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
+ then [Option "-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 dflags = do
+ when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
+ putLogMsg dflags NoReason SevInfo noSrcSpan
+ (defaultUserStyle dflags)
+ (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
+ text " Call hs_init_ghc() from your main() function to set these options.")
+
+ mkExtraObj dflags "c" (showSDoc dflags main)
+ where
+ main
+ | gopt Opt_NoHsMain dflags = Outputable.empty
+ | otherwise
+ = case ghcLink dflags of
+ LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32
+ then dllMain
+ else Outputable.empty
+ _ -> exeMain
+
+ exeMain = vcat [
+ text "#include <Rts.h>",
+ text "extern StgClosure ZCMain_main_closure;",
+ text "int main(int argc, char *argv[])",
+ char '{',
+ text " RtsConfig __conf = defaultRtsConfig;",
+ text " __conf.rts_opts_enabled = "
+ <> text (show (rtsOptsEnabled dflags)) <> semi,
+ text " __conf.rts_opts_suggestions = "
+ <> text (if rtsOptsSuggestions dflags
+ then "true"
+ else "false") <> semi,
+ text "__conf.keep_cafs = "
+ <> text (if gopt Opt_KeepCAFs dflags
+ then "true"
+ else "false") <> semi,
+ case rtsOpts dflags of
+ Nothing -> Outputable.empty
+ Just opts -> text " __conf.rts_opts= " <>
+ text (show opts) <> semi,
+ text " __conf.rts_hs_main = true;",
+ text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
+ char '}',
+ char '\n' -- final newline, to keep gcc happy
+ ]
+
+ dllMain = vcat [
+ text "#include <Rts.h>",
+ text "#include <windows.h>",
+ text "#include <stdbool.h>",
+ char '\n',
+ text "bool",
+ text "WINAPI",
+ text "DllMain ( HINSTANCE hInstance STG_UNUSED",
+ text " , DWORD reason STG_UNUSED",
+ text " , LPVOID reserved STG_UNUSED",
+ text " )",
+ text "{",
+ text " return true;",
+ text "}",
+ 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 -> [InstalledUnitId] -> IO [FilePath]
+mkNoteObjsToLinkIntoBinary dflags dep_packages = do
+ link_info <- getLinkInfo dflags dep_packages
+
+ if (platformSupportsSavingLinkOpts (platformOS platform ))
+ then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
+ else return []
+
+ where
+ platform = targetPlatform dflags
+ link_opts info = hcat [
+ -- "link info" section (see Note [LinkInfo section])
+ makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 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 platformHasGnuNonexecStack platform
+ then text ".section .note.GNU-stack,\"\","
+ <> sectionType platform "progbits" <> char '\n'
+ else Outputable.empty
+ ]
+
+-- | Return the "link info" string
+--
+-- See Note [LinkInfo section]
+getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String
+getLinkInfo dflags dep_packages = do
+ package_link_opts <- getPackageLinkOpts dflags dep_packages
+ pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
+ then getPackageFrameworks dflags dep_packages
+ else return []
+ let extra_ld_inputs = ldInputs dflags
+ let
+ link_info = (package_link_opts,
+ pkg_frameworks,
+ rtsOpts dflags,
+ rtsOptsEnabled dflags,
+ gopt Opt_NoHsMain dflags,
+ map showOpt extra_ld_inputs,
+ getOpts dflags opt_l)
+ --
+ return (show link_info)
+
+platformSupportsSavingLinkOpts :: OS -> Bool
+platformSupportsSavingLinkOpts os
+ | os == OSSolaris2 = False -- see #5382
+ | otherwise = osElfTarget os
+
+-- See Note [LinkInfo section]
+ghcLinkInfoSectionName :: String
+ghcLinkInfoSectionName = ".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 = "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 -> [InstalledUnitId] -> FilePath -> IO Bool
+checkLinkInfo dflags pkg_deps exe_file
+ | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform 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.
+ = return 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.
+ | otherwise
+ = do
+ link_info <- getLinkInfo dflags pkg_deps
+ debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)
+ m_exe_link_info <- readElfNoteAsString dflags exe_file
+ ghcLinkInfoSectionName ghcLinkInfoNoteName
+ let sameLinkInfo = (Just link_info == m_exe_link_info)
+ debugTraceMsg dflags 3 $ case m_exe_link_info of
+ Nothing -> text "Exe link info: Not found"
+ Just s
+ | sameLinkInfo -> text ("Exe link info is the same")
+ | otherwise -> text ("Exe link info is different: " ++ 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 dflags =
+ isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
+ RtsOptsSafeOnly -> False
+ _ -> True