ExtraObj.hs 10.1 KB
Newer Older
Tamar Christina's avatar
Tamar Christina committed
1 2 3 4 5 6 7 8
-----------------------------------------------------------------------------
--
-- GHC Extra object linking code
--
-- (c) The GHC Team 2017
--
-----------------------------------------------------------------------------

9 10 11 12 13 14 15 16 17 18 19 20 21
module GHC.Linker.ExtraObj
   ( mkExtraObj
   , mkExtraObjToLinkIntoBinary
   , mkNoteObjsToLinkIntoBinary
   , checkLinkInfo
   , getLinkInfo
   , getCompilerInfo
   , ghcLinkInfoSectionName
   , ghcLinkInfoNoteName
   , platformSupportsSavingLinkOpts
   , haveRtsOptsFlags
   )
where
Tamar Christina's avatar
Tamar Christina committed
22

23 24 25 26 27 28 29
import GHC.Prelude
import GHC.Platform

import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.State

30 31
import GHC.Utils.Asm
import GHC.Utils.Error
32 33
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
Sylvain Henry's avatar
Sylvain Henry committed
34
import GHC.Utils.Logger
35

Sylvain Henry's avatar
Sylvain Henry committed
36
import GHC.Driver.Session
37
import GHC.Driver.Ppr
38

39
import qualified GHC.Data.ShortText as ST
Tamar Christina's avatar
Tamar Christina committed
40

41
import GHC.SysTools.Elf
Sylvain Henry's avatar
Sylvain Henry committed
42 43 44
import GHC.SysTools.FileCleanup
import GHC.SysTools.Tasks
import GHC.SysTools.Info
45
import GHC.Linker.Unit
Tamar Christina's avatar
Tamar Christina committed
46

47 48 49 50
import Control.Monad.IO.Class
import Control.Monad
import Data.Maybe

Sylvain Henry's avatar
Sylvain Henry committed
51 52 53 54
mkExtraObj :: Logger -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath
mkExtraObj logger dflags unit_state extn xs
 = do cFile <- newTempName logger dflags TFL_CurrentModule extn
      oFile <- newTempName logger dflags TFL_GhcSession "o"
Tamar Christina's avatar
Tamar Christina committed
55
      writeFile cFile xs
Sylvain Henry's avatar
Sylvain Henry committed
56 57
      ccInfo <- liftIO $ getCompilerInfo logger dflags
      runCc Nothing logger dflags
Tamar Christina's avatar
Tamar Christina committed
58 59 60 61 62 63 64 65 66 67 68 69 70
            ([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)
71
                    ++ map (FileOption "-I" . ST.unpack)
72
                            (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit)
Tamar Christina's avatar
Tamar Christina committed
73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89

      -- 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.
--
90
mkExtraObjToLinkIntoBinary :: Logger -> DynFlags -> UnitState -> IO (Maybe FilePath)
Sylvain Henry's avatar
Sylvain Henry committed
91
mkExtraObjToLinkIntoBinary logger dflags unit_state = do
92
  when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $
Sylvain Henry's avatar
Sylvain Henry committed
93
     logInfo logger dflags $ withPprStyle defaultUserStyle
Tamar Christina's avatar
Tamar Christina committed
94 95 96
         (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.")

97 98 99 100 101 102 103 104 105 106 107 108 109 110
  case ghcLink 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.
    _ | gopt Opt_NoHsMain dflags
      -> return Nothing

    LinkDynLib
      | OSMinGW32 <- platformOS (targetPlatform dflags)
      -> mk_extra_obj dllMain

Tamar Christina's avatar
Tamar Christina committed
111
      | otherwise
112 113 114 115 116 117
      -> return Nothing

    _ -> mk_extra_obj exeMain

  where
    mk_extra_obj = fmap Just . mkExtraObj logger dflags unit_state "c" . showSDoc dflags
Tamar Christina's avatar
Tamar Christina committed
118 119

    exeMain = vcat [
120
        text "#include <Rts.h>",
Tamar Christina's avatar
Tamar Christina committed
121 122 123 124 125 126 127 128 129 130
        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,
Simon Marlow's avatar
Simon Marlow committed
131 132 133 134
        text "__conf.keep_cafs = "
            <> text (if gopt Opt_KeepCAFs dflags
                       then "true"
                       else "false") <> semi,
Tamar Christina's avatar
Tamar Christina committed
135 136 137 138 139 140 141 142 143 144 145
        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 [
146
        text "#include <Rts.h>",
Tamar Christina's avatar
Tamar Christina committed
147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
        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
Sylvain Henry's avatar
Sylvain Henry committed
166 167
mkNoteObjsToLinkIntoBinary :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary logger dflags unit_env dep_packages = do
168
   link_info <- getLinkInfo dflags unit_env dep_packages
Tamar Christina's avatar
Tamar Christina committed
169

170
   if (platformSupportsSavingLinkOpts (platformOS platform ))
Sylvain Henry's avatar
Sylvain Henry committed
171
     then fmap (:[]) $ mkExtraObj logger dflags unit_state "s" (showSDoc dflags (link_opts link_info))
Tamar Christina's avatar
Tamar Christina committed
172 173 174
     else return []

  where
175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
    unit_state = ue_units unit_env
    platform   = ue_platform unit_env
    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
        ]
Tamar Christina's avatar
Tamar Christina committed
190 191 192 193

-- | Return the "link info" string
--
-- See Note [LinkInfo section]
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211
getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String
getLinkInfo dflags unit_env dep_packages = do
    package_link_opts <- getUnitLinkOpts dflags unit_env 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 =
             ( package_link_opts
             , pkg_frameworks
             , rtsOpts dflags
             , rtsOptsEnabled dflags
             , gopt Opt_NoHsMain dflags
             , map showOpt (ldInputs dflags)
             , getOpts dflags opt_l
             )
    return (show link_info)
Tamar Christina's avatar
Tamar Christina committed
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228

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".
Sylvain Henry's avatar
Sylvain Henry committed
229 230
checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool
checkLinkInfo logger dflags unit_env pkg_deps exe_file
231
 | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env)))
Tamar Christina's avatar
Tamar Christina committed
232 233 234 235 236 237 238 239
 -- 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
240
   link_info <- getLinkInfo dflags unit_env pkg_deps
Sylvain Henry's avatar
Sylvain Henry committed
241 242
   debugTraceMsg logger dflags 3 $ text ("Link info: " ++ link_info)
   m_exe_link_info <- readElfNoteAsString logger dflags exe_file
Tamar Christina's avatar
Tamar Christina committed
243 244
                          ghcLinkInfoSectionName ghcLinkInfoNoteName
   let sameLinkInfo = (Just link_info == m_exe_link_info)
Sylvain Henry's avatar
Sylvain Henry committed
245
   debugTraceMsg logger dflags 3 $ case m_exe_link_info of
Tamar Christina's avatar
Tamar Christina committed
246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270
     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