never executed always true always false
1 -----------------------------------------------------------------------------
2 --
3 -- GHC Extra object linking code
4 --
5 -- (c) The GHC Team 2017
6 --
7 -----------------------------------------------------------------------------
8
9 module GHC.Linker.ExtraObj
10 ( mkExtraObj
11 , mkExtraObjToLinkIntoBinary
12 , mkNoteObjsToLinkIntoBinary
13 , checkLinkInfo
14 , getLinkInfo
15 , getCompilerInfo
16 , ghcLinkInfoSectionName
17 , ghcLinkInfoNoteName
18 , platformSupportsSavingLinkOpts
19 , haveRtsOptsFlags
20 )
21 where
22
23 import GHC.Prelude
24 import GHC.Platform
25
26 import GHC.Unit
27 import GHC.Unit.Env
28
29 import GHC.Utils.Asm
30 import GHC.Utils.Error
31 import GHC.Utils.Misc
32 import GHC.Utils.Outputable as Outputable
33 import GHC.Utils.Logger
34 import GHC.Utils.TmpFs
35
36 import GHC.Driver.Session
37 import GHC.Driver.Ppr
38
39 import qualified GHC.Data.ShortText as ST
40
41 import GHC.SysTools.Elf
42 import GHC.SysTools.Tasks
43 import GHC.SysTools.Info
44 import GHC.Linker.Unit
45
46 import Control.Monad.IO.Class
47 import Control.Monad
48 import Data.Maybe
49
50 mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath
51 mkExtraObj logger tmpfs dflags unit_state extn xs
52 = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn
53 oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o"
54 writeFile cFile xs
55 ccInfo <- liftIO $ getCompilerInfo logger dflags
56 runCc Nothing logger tmpfs dflags
57 ([Option "-c",
58 FileOption "" cFile,
59 Option "-o",
60 FileOption "" oFile]
61 ++ if extn /= "s"
62 then cOpts
63 else asmOpts ccInfo)
64 return oFile
65 where
66 -- Pass a different set of options to the C compiler depending one whether
67 -- we're compiling C or assembler. When compiling C, we pass the usual
68 -- set of include directories and PIC flags.
69 cOpts = map Option (picCCOpts dflags)
70 ++ map (FileOption "-I" . ST.unpack)
71 (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit)
72
73 -- When compiling assembler code, we drop the usual C options, and if the
74 -- compiler is Clang, we add an extra argument to tell Clang to ignore
75 -- unused command line options. See trac #11684.
76 asmOpts ccInfo =
77 if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
78 then [Option "-Qunused-arguments"]
79 else []
80
81 -- When linking a binary, we need to create a C main() function that
82 -- starts everything off. This used to be compiled statically as part
83 -- of the RTS, but that made it hard to change the -rtsopts setting,
84 -- so now we generate and compile a main() stub as part of every
85 -- binary and pass the -rtsopts setting directly to the RTS (#5373)
86 --
87 -- On Windows, when making a shared library we also may need a DllMain.
88 --
89 mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath)
90 mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do
91 when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $
92 logInfo logger $ withPprStyle defaultUserStyle
93 (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
94 text " Call hs_init_ghc() from your main() function to set these options.")
95
96 case ghcLink dflags of
97 -- Don't try to build the extra object if it is not needed. Compiling the
98 -- extra object assumes the presence of the RTS in the unit database
99 -- (because the extra object imports Rts.h) but GHC's build system may try
100 -- to build some helper programs before building and registering the RTS!
101 -- See #18938 for an example where hp2ps failed to build because of a failed
102 -- (unsafe) lookup for the RTS in the unit db.
103 _ | gopt Opt_NoHsMain dflags
104 -> return Nothing
105
106 LinkDynLib
107 | OSMinGW32 <- platformOS (targetPlatform dflags)
108 -> mk_extra_obj dllMain
109
110 | otherwise
111 -> return Nothing
112
113 _ -> mk_extra_obj exeMain
114
115 where
116 mk_extra_obj = fmap Just . mkExtraObj logger tmpfs dflags unit_state "c" . showSDoc dflags
117
118 exeMain = vcat [
119 text "#include <Rts.h>",
120 text "extern StgClosure ZCMain_main_closure;",
121 text "int main(int argc, char *argv[])",
122 char '{',
123 text " RtsConfig __conf = defaultRtsConfig;",
124 text " __conf.rts_opts_enabled = "
125 <> text (show (rtsOptsEnabled dflags)) <> semi,
126 text " __conf.rts_opts_suggestions = "
127 <> text (if rtsOptsSuggestions dflags
128 then "true"
129 else "false") <> semi,
130 text "__conf.keep_cafs = "
131 <> text (if gopt Opt_KeepCAFs dflags
132 then "true"
133 else "false") <> semi,
134 case rtsOpts dflags of
135 Nothing -> Outputable.empty
136 Just opts -> text " __conf.rts_opts= " <>
137 text (show opts) <> semi,
138 text " __conf.rts_hs_main = true;",
139 text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
140 char '}',
141 char '\n' -- final newline, to keep gcc happy
142 ]
143
144 dllMain = vcat [
145 text "#include <Rts.h>",
146 text "#include <windows.h>",
147 text "#include <stdbool.h>",
148 char '\n',
149 text "bool",
150 text "WINAPI",
151 text "DllMain ( HINSTANCE hInstance STG_UNUSED",
152 text " , DWORD reason STG_UNUSED",
153 text " , LPVOID reserved STG_UNUSED",
154 text " )",
155 text "{",
156 text " return true;",
157 text "}",
158 char '\n' -- final newline, to keep gcc happy
159 ]
160
161 -- Write out the link info section into a new assembly file. Previously
162 -- this was included as inline assembly in the main.c file but this
163 -- is pretty fragile. gas gets upset trying to calculate relative offsets
164 -- that span the .note section (notably .text) when debug info is present
165 mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath]
166 mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_packages = do
167 link_info <- getLinkInfo dflags unit_env dep_packages
168
169 if (platformSupportsSavingLinkOpts (platformOS platform ))
170 then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info))
171 else return []
172
173 where
174 unit_state = ue_units unit_env
175 platform = ue_platform unit_env
176 link_opts info = hcat
177 [ -- "link info" section (see Note [LinkInfo section])
178 makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info
179
180 -- ALL generated assembly must have this section to disable
181 -- executable stacks. See also
182 -- "GHC.CmmToAsm" for another instance
183 -- where we need to do this.
184 , if platformHasGnuNonexecStack platform
185 then text ".section .note.GNU-stack,\"\","
186 <> sectionType platform "progbits" <> char '\n'
187 else Outputable.empty
188 ]
189
190 -- | Return the "link info" string
191 --
192 -- See Note [LinkInfo section]
193 getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String
194 getLinkInfo dflags unit_env dep_packages = do
195 package_link_opts <- getUnitLinkOpts dflags unit_env dep_packages
196 pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env))
197 then return []
198 else do
199 ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
200 return (collectFrameworks ps)
201 let link_info =
202 ( package_link_opts
203 , pkg_frameworks
204 , rtsOpts dflags
205 , rtsOptsEnabled dflags
206 , gopt Opt_NoHsMain dflags
207 , map showOpt (ldInputs dflags)
208 , getOpts dflags opt_l
209 )
210 return (show link_info)
211
212 platformSupportsSavingLinkOpts :: OS -> Bool
213 platformSupportsSavingLinkOpts os
214 | os == OSSolaris2 = False -- see #5382
215 | otherwise = osElfTarget os
216
217 -- See Note [LinkInfo section]
218 ghcLinkInfoSectionName :: String
219 ghcLinkInfoSectionName = ".debug-ghc-link-info"
220 -- if we use the ".debug" prefix, then strip will strip it by default
221
222 -- Identifier for the note (see Note [LinkInfo section])
223 ghcLinkInfoNoteName :: String
224 ghcLinkInfoNoteName = "GHC link info"
225
226 -- Returns 'False' if it was, and we can avoid linking, because the
227 -- previous binary was linked with "the same options".
228 checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool
229 checkLinkInfo logger dflags unit_env pkg_deps exe_file
230 | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env)))
231 -- ToDo: Windows and OS X do not use the ELF binary format, so
232 -- readelf does not work there. We need to find another way to do
233 -- this.
234 = return False -- conservatively we should return True, but not
235 -- linking in this case was the behaviour for a long
236 -- time so we leave it as-is.
237 | otherwise
238 = do
239 link_info <- getLinkInfo dflags unit_env pkg_deps
240 debugTraceMsg logger 3 $ text ("Link info: " ++ link_info)
241 m_exe_link_info <- readElfNoteAsString logger exe_file
242 ghcLinkInfoSectionName ghcLinkInfoNoteName
243 let sameLinkInfo = (Just link_info == m_exe_link_info)
244 debugTraceMsg logger 3 $ case m_exe_link_info of
245 Nothing -> text "Exe link info: Not found"
246 Just s
247 | sameLinkInfo -> text ("Exe link info is the same")
248 | otherwise -> text ("Exe link info is different: " ++ s)
249 return (not sameLinkInfo)
250
251 {- Note [LinkInfo section]
252 ~~~~~~~~~~~~~~~~~~~~~~~
253
254 The "link info" is a string representing the parameters of the link. We save
255 this information in the binary, and the next time we link, if nothing else has
256 changed, we use the link info stored in the existing binary to decide whether
257 to re-link or not.
258
259 The "link info" string is stored in a ELF section called ".debug-ghc-link-info"
260 (see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to
261 not follow the specified record-based format (see #11022).
262
263 -}
264
265 haveRtsOptsFlags :: DynFlags -> Bool
266 haveRtsOptsFlags dflags =
267 isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
268 RtsOptsSafeOnly -> False
269 _ -> True