1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
|
-----------------------------------------------------------------------------
--
-- 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 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")
(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) $ do
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
|
