Linker: reorganize linker related code

Move linker related code into GHC.Linker. Previously it was scattered
into GHC.Unit.State, GHC.Driver.Pipeline, GHC.Runtime.Linker, etc.

Add documentation in GHC.Linker

2 files changed, 0 insertions, 288 deletions

diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs
deleted file mode 100644
index 1b728fb067..0000000000
--- a/compiler/GHC/SysTools/ExtraObj.hs
+++ /dev/null
@@ -1,251 +0,0 @@
------------------------------------------------------------------------------
---
--- 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.Driver.Ppr
-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 qualified GHC.Data.ShortText as ST
-
-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
-      pkgs = unitState dflags
-
-      -- 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" . ST.unpack)
-                            (unitIncludeDirs $ unsafeLookupUnit pkgs 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 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) $
-     putLogMsg dflags NoReason SevInfo noSrcSpan
-         $ withPprStyle defaultUserStyle
-         (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 -> [UnitId] -> 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
-      -- "GHC.CmmToAsm" 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 -> [UnitId] -> IO String
-getLinkInfo dflags dep_packages = do
-   package_link_opts <- getUnitLinkOpts dflags dep_packages
-   let unit_state = unitState dflags
-       home_unit  = mkHomeUnitFromFlags dflags
-       ctx        = initSDocContext dflags defaultUserStyle
-   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
-                     then getUnitFrameworks ctx unit_state home_unit 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 -> [UnitId] -> 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
diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs
index 8b6bd70bbd..50e25e025a 100644
--- a/compiler/GHC/SysTools/Tasks.hs
+++ b/compiler/GHC/SysTools/Tasks.hs
@@ -26,11 +26,8 @@ import GHC.Utils.Outputable
 import GHC.Utils.Misc
 
 import Data.List
-import Control.Monad (join, forM, filterM)
 import System.IO
 import System.Process
-import System.Directory (doesFileExist)
-import System.FilePath ((</>))
 
 {-
 ************************************************************************
@@ -240,40 +237,6 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do
                 return Nothing)
 
 
--- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused
--- libraries from the dynamic library.  We do this to reduce the number of load
--- commands that end up in the dylib, and has been limited to 32K (32768) since
--- macOS Sierra (10.14).
---
--- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing
--- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not
--- being included in the load commands, however the @-rpath@ entries are all
--- forced to be included.  This can lead to 100s of @-rpath@ entries being
--- included when only a handful of libraries end up being truely linked.
---
--- Thus after building the library, we run a fixup phase where we inject the
--- @-rpath@ for each found library (in the given library search paths) into the
--- dynamic library through @-add_rpath@.
---
--- See Note [Dynamic linking on macOS]
-runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()
-runInjectRPaths dflags lib_paths dylib = do
-  info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib]
-  -- filter the output for only the libraries. And then drop the @rpath prefix.
-  let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info
-  -- find any pre-existing LC_PATH items
-  info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib]
-  let paths = concatMap f info
-        where f ("path":p:_) = [p]
-              f _            = []
-      lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]
-  -- only find those rpaths, that aren't already in the library.
-  rpaths <- nub.sort.join <$> forM libs (\f -> filterM (\l -> doesFileExist (l </> f)) lib_paths')
-  -- inject the rpaths
-  case rpaths of
-    [] -> return ()
-    _  -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
-
 
 runLink :: DynFlags -> [Option] -> IO ()
 runLink dflags args = traceToolCommand dflags "linker" $ do