add a missing STACK case
[ghc.git] / rts / Linker.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 2000-2004
4 *
5 * RTS Object Linker
6 *
7 * ---------------------------------------------------------------------------*/
8
9 #if 0
10 #include "PosixSource.h"
11 #endif
12
13 /* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h> and
14 MREMAP_MAYMOVE from <sys/mman.h>.
15 */
16 #ifdef __linux__
17 #define _GNU_SOURCE
18 #endif
19
20 #include "Rts.h"
21 #include "HsFFI.h"
22
23 #include "sm/Storage.h"
24 #include "Stats.h"
25 #include "Hash.h"
26 #include "LinkerInternals.h"
27 #include "RtsUtils.h"
28 #include "Trace.h"
29 #include "StgPrimFloat.h" // for __int_encodeFloat etc.
30 #include "Stable.h"
31
32 #if !defined(mingw32_HOST_OS)
33 #include "posix/Signals.h"
34 #endif
35
36 // get protos for is*()
37 #include <ctype.h>
38
39 #ifdef HAVE_SYS_TYPES_H
40 #include <sys/types.h>
41 #endif
42
43 #include <stdlib.h>
44 #include <string.h>
45 #include <stdio.h>
46 #include <assert.h>
47
48 #ifdef HAVE_SYS_STAT_H
49 #include <sys/stat.h>
50 #endif
51
52 #if defined(HAVE_DLFCN_H)
53 #include <dlfcn.h>
54 #endif
55
56 #if defined(cygwin32_HOST_OS)
57 #ifdef HAVE_DIRENT_H
58 #include <dirent.h>
59 #endif
60
61 #ifdef HAVE_SYS_TIME_H
62 #include <sys/time.h>
63 #endif
64 #include <regex.h>
65 #include <sys/fcntl.h>
66 #include <sys/termios.h>
67 #include <sys/utime.h>
68 #include <sys/utsname.h>
69 #include <sys/wait.h>
70 #endif
71
72 #if defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \
73 defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \
74 defined(openbsd_HOST_OS ) || \
75 ( defined(darwin_HOST_OS ) && !defined(powerpc_HOST_ARCH) )
76 /* Don't use mmap on powerpc-apple-darwin as mmap doesn't support
77 * reallocating but we need to allocate jump islands just after each
78 * object images. Otherwise relative branches to jump islands can fail
79 * due to 24-bits displacement overflow.
80 */
81 #define USE_MMAP
82 #include <fcntl.h>
83 #include <sys/mman.h>
84
85 #ifdef HAVE_UNISTD_H
86 #include <unistd.h>
87 #endif
88
89 #endif
90
91 #if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS)
92 # define OBJFORMAT_ELF
93 # include <regex.h> // regex is already used by dlopen() so this is OK
94 // to use here without requiring an additional lib
95 #elif defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
96 # define OBJFORMAT_PEi386
97 # include <windows.h>
98 # include <math.h>
99 #elif defined(darwin_HOST_OS)
100 # define OBJFORMAT_MACHO
101 # include <regex.h>
102 # include <mach-o/loader.h>
103 # include <mach-o/nlist.h>
104 # include <mach-o/reloc.h>
105 #if !defined(HAVE_DLFCN_H)
106 # include <mach-o/dyld.h>
107 #endif
108 #if defined(powerpc_HOST_ARCH)
109 # include <mach-o/ppc/reloc.h>
110 #endif
111 #if defined(x86_64_HOST_ARCH)
112 # include <mach-o/x86_64/reloc.h>
113 #endif
114 #endif
115
116 #if defined(x86_64_HOST_ARCH) && defined(darwin_HOST_OS)
117 #define ALWAYS_PIC
118 #endif
119
120 /* Hash table mapping symbol names to Symbol */
121 static /*Str*/HashTable *symhash;
122
123 /* Hash table mapping symbol names to StgStablePtr */
124 static /*Str*/HashTable *stablehash;
125
126 /* List of currently loaded objects */
127 ObjectCode *objects = NULL; /* initially empty */
128
129 static HsInt loadOc( ObjectCode* oc );
130 static ObjectCode* mkOc( char *path, char *image, int imageSize,
131 char *archiveMemberName
132 #ifndef USE_MMAP
133 #ifdef darwin_HOST_OS
134 , int misalignment
135 #endif
136 #endif
137 );
138
139 #if defined(OBJFORMAT_ELF)
140 static int ocVerifyImage_ELF ( ObjectCode* oc );
141 static int ocGetNames_ELF ( ObjectCode* oc );
142 static int ocResolve_ELF ( ObjectCode* oc );
143 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
144 static int ocAllocateSymbolExtras_ELF ( ObjectCode* oc );
145 #endif
146 #elif defined(OBJFORMAT_PEi386)
147 static int ocVerifyImage_PEi386 ( ObjectCode* oc );
148 static int ocGetNames_PEi386 ( ObjectCode* oc );
149 static int ocResolve_PEi386 ( ObjectCode* oc );
150 static void *lookupSymbolInDLLs ( unsigned char *lbl );
151 static void zapTrailingAtSign ( unsigned char *sym );
152 #elif defined(OBJFORMAT_MACHO)
153 static int ocVerifyImage_MachO ( ObjectCode* oc );
154 static int ocGetNames_MachO ( ObjectCode* oc );
155 static int ocResolve_MachO ( ObjectCode* oc );
156
157 #ifndef USE_MMAP
158 static int machoGetMisalignment( FILE * );
159 #endif
160 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
161 static int ocAllocateSymbolExtras_MachO ( ObjectCode* oc );
162 #endif
163 #ifdef powerpc_HOST_ARCH
164 static void machoInitSymbolsWithoutUnderscore( void );
165 #endif
166 #endif
167
168 /* on x86_64 we have a problem with relocating symbol references in
169 * code that was compiled without -fPIC. By default, the small memory
170 * model is used, which assumes that symbol references can fit in a
171 * 32-bit slot. The system dynamic linker makes this work for
172 * references to shared libraries by either (a) allocating a jump
173 * table slot for code references, or (b) moving the symbol at load
174 * time (and copying its contents, if necessary) for data references.
175 *
176 * We unfortunately can't tell whether symbol references are to code
177 * or data. So for now we assume they are code (the vast majority
178 * are), and allocate jump-table slots. Unfortunately this will
179 * SILENTLY generate crashing code for data references. This hack is
180 * enabled by X86_64_ELF_NONPIC_HACK.
181 *
182 * One workaround is to use shared Haskell libraries. This is
183 * coming. Another workaround is to keep the static libraries but
184 * compile them with -fPIC, because that will generate PIC references
185 * to data which can be relocated. The PIC code is still too green to
186 * do this systematically, though.
187 *
188 * See bug #781
189 * See thread http://www.haskell.org/pipermail/cvs-ghc/2007-September/038458.html
190 *
191 * Naming Scheme for Symbol Macros
192 *
193 * SymI_*: symbol is internal to the RTS. It resides in an object
194 * file/library that is statically.
195 * SymE_*: symbol is external to the RTS library. It might be linked
196 * dynamically.
197 *
198 * Sym*_HasProto : the symbol prototype is imported in an include file
199 * or defined explicitly
200 * Sym*_NeedsProto: the symbol is undefined and we add a dummy
201 * default proto extern void sym(void);
202 */
203 #define X86_64_ELF_NONPIC_HACK 1
204
205 /* Link objects into the lower 2Gb on x86_64. GHC assumes the
206 * small memory model on this architecture (see gcc docs,
207 * -mcmodel=small).
208 *
209 * MAP_32BIT not available on OpenBSD/amd64
210 */
211 #if defined(x86_64_HOST_ARCH) && defined(MAP_32BIT)
212 #define TRY_MAP_32BIT MAP_32BIT
213 #else
214 #define TRY_MAP_32BIT 0
215 #endif
216
217 /*
218 * Due to the small memory model (see above), on x86_64 we have to map
219 * all our non-PIC object files into the low 2Gb of the address space
220 * (why 2Gb and not 4Gb? Because all addresses must be reachable
221 * using a 32-bit signed PC-relative offset). On Linux we can do this
222 * using the MAP_32BIT flag to mmap(), however on other OSs
223 * (e.g. *BSD, see #2063, and also on Linux inside Xen, see #2512), we
224 * can't do this. So on these systems, we have to pick a base address
225 * in the low 2Gb of the address space and try to allocate memory from
226 * there.
227 *
228 * We pick a default address based on the OS, but also make this
229 * configurable via an RTS flag (+RTS -xm)
230 */
231 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
232
233 #if defined(MAP_32BIT)
234 // Try to use MAP_32BIT
235 #define MMAP_32BIT_BASE_DEFAULT 0
236 #else
237 // A guess: 1Gb.
238 #define MMAP_32BIT_BASE_DEFAULT 0x40000000
239 #endif
240
241 static void *mmap_32bit_base = (void *)MMAP_32BIT_BASE_DEFAULT;
242 #endif
243
244 /* MAP_ANONYMOUS is MAP_ANON on some systems, e.g. OpenBSD */
245 #if !defined(MAP_ANONYMOUS) && defined(MAP_ANON)
246 #define MAP_ANONYMOUS MAP_ANON
247 #endif
248
249 /* -----------------------------------------------------------------------------
250 * Built-in symbols from the RTS
251 */
252
253 typedef struct _RtsSymbolVal {
254 char *lbl;
255 void *addr;
256 } RtsSymbolVal;
257
258 #define Maybe_Stable_Names SymI_HasProto(stg_mkWeakzh) \
259 SymI_HasProto(stg_mkWeakForeignEnvzh) \
260 SymI_HasProto(stg_makeStableNamezh) \
261 SymI_HasProto(stg_finalizzeWeakzh)
262
263 #if !defined (mingw32_HOST_OS)
264 #define RTS_POSIX_ONLY_SYMBOLS \
265 SymI_HasProto(__hscore_get_saved_termios) \
266 SymI_HasProto(__hscore_set_saved_termios) \
267 SymI_HasProto(shutdownHaskellAndSignal) \
268 SymI_HasProto(lockFile) \
269 SymI_HasProto(unlockFile) \
270 SymI_HasProto(signal_handlers) \
271 SymI_HasProto(stg_sig_install) \
272 SymI_HasProto(rtsTimerSignal) \
273 SymI_NeedsProto(nocldstop)
274 #endif
275
276 #if defined (cygwin32_HOST_OS)
277 #define RTS_MINGW_ONLY_SYMBOLS /**/
278 /* Don't have the ability to read import libs / archives, so
279 * we have to stupidly list a lot of what libcygwin.a
280 * exports; sigh.
281 */
282 #define RTS_CYGWIN_ONLY_SYMBOLS \
283 SymI_HasProto(regfree) \
284 SymI_HasProto(regexec) \
285 SymI_HasProto(regerror) \
286 SymI_HasProto(regcomp) \
287 SymI_HasProto(__errno) \
288 SymI_HasProto(access) \
289 SymI_HasProto(chmod) \
290 SymI_HasProto(chdir) \
291 SymI_HasProto(close) \
292 SymI_HasProto(creat) \
293 SymI_HasProto(dup) \
294 SymI_HasProto(dup2) \
295 SymI_HasProto(fstat) \
296 SymI_HasProto(fcntl) \
297 SymI_HasProto(getcwd) \
298 SymI_HasProto(getenv) \
299 SymI_HasProto(lseek) \
300 SymI_HasProto(open) \
301 SymI_HasProto(fpathconf) \
302 SymI_HasProto(pathconf) \
303 SymI_HasProto(stat) \
304 SymI_HasProto(pow) \
305 SymI_HasProto(tanh) \
306 SymI_HasProto(cosh) \
307 SymI_HasProto(sinh) \
308 SymI_HasProto(atan) \
309 SymI_HasProto(acos) \
310 SymI_HasProto(asin) \
311 SymI_HasProto(tan) \
312 SymI_HasProto(cos) \
313 SymI_HasProto(sin) \
314 SymI_HasProto(exp) \
315 SymI_HasProto(log) \
316 SymI_HasProto(sqrt) \
317 SymI_HasProto(localtime_r) \
318 SymI_HasProto(gmtime_r) \
319 SymI_HasProto(mktime) \
320 SymI_NeedsProto(_imp___tzname) \
321 SymI_HasProto(gettimeofday) \
322 SymI_HasProto(timezone) \
323 SymI_HasProto(tcgetattr) \
324 SymI_HasProto(tcsetattr) \
325 SymI_HasProto(memcpy) \
326 SymI_HasProto(memmove) \
327 SymI_HasProto(realloc) \
328 SymI_HasProto(malloc) \
329 SymI_HasProto(free) \
330 SymI_HasProto(fork) \
331 SymI_HasProto(lstat) \
332 SymI_HasProto(isatty) \
333 SymI_HasProto(mkdir) \
334 SymI_HasProto(opendir) \
335 SymI_HasProto(readdir) \
336 SymI_HasProto(rewinddir) \
337 SymI_HasProto(closedir) \
338 SymI_HasProto(link) \
339 SymI_HasProto(mkfifo) \
340 SymI_HasProto(pipe) \
341 SymI_HasProto(read) \
342 SymI_HasProto(rename) \
343 SymI_HasProto(rmdir) \
344 SymI_HasProto(select) \
345 SymI_HasProto(system) \
346 SymI_HasProto(write) \
347 SymI_HasProto(strcmp) \
348 SymI_HasProto(strcpy) \
349 SymI_HasProto(strncpy) \
350 SymI_HasProto(strerror) \
351 SymI_HasProto(sigaddset) \
352 SymI_HasProto(sigemptyset) \
353 SymI_HasProto(sigprocmask) \
354 SymI_HasProto(umask) \
355 SymI_HasProto(uname) \
356 SymI_HasProto(unlink) \
357 SymI_HasProto(utime) \
358 SymI_HasProto(waitpid)
359
360 #elif !defined(mingw32_HOST_OS)
361 #define RTS_MINGW_ONLY_SYMBOLS /**/
362 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
363 #else /* defined(mingw32_HOST_OS) */
364 #define RTS_POSIX_ONLY_SYMBOLS /**/
365 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
366
367 #if HAVE_GETTIMEOFDAY
368 #define RTS_MINGW_GETTIMEOFDAY_SYM SymI_NeedsProto(gettimeofday)
369 #else
370 #define RTS_MINGW_GETTIMEOFDAY_SYM /**/
371 #endif
372
373 #if HAVE___MINGW_VFPRINTF
374 #define RTS___MINGW_VFPRINTF_SYM SymI_HasProto(__mingw_vfprintf)
375 #else
376 #define RTS___MINGW_VFPRINTF_SYM /**/
377 #endif
378
379 /* These are statically linked from the mingw libraries into the ghc
380 executable, so we have to employ this hack. */
381 #define RTS_MINGW_ONLY_SYMBOLS \
382 SymI_HasProto(stg_asyncReadzh) \
383 SymI_HasProto(stg_asyncWritezh) \
384 SymI_HasProto(stg_asyncDoProczh) \
385 SymI_HasProto(memset) \
386 SymI_HasProto(inet_ntoa) \
387 SymI_HasProto(inet_addr) \
388 SymI_HasProto(htonl) \
389 SymI_HasProto(recvfrom) \
390 SymI_HasProto(listen) \
391 SymI_HasProto(bind) \
392 SymI_HasProto(shutdown) \
393 SymI_HasProto(connect) \
394 SymI_HasProto(htons) \
395 SymI_HasProto(ntohs) \
396 SymI_HasProto(getservbyname) \
397 SymI_HasProto(getservbyport) \
398 SymI_HasProto(getprotobynumber) \
399 SymI_HasProto(getprotobyname) \
400 SymI_HasProto(gethostbyname) \
401 SymI_HasProto(gethostbyaddr) \
402 SymI_HasProto(gethostname) \
403 SymI_HasProto(strcpy) \
404 SymI_HasProto(strncpy) \
405 SymI_HasProto(abort) \
406 SymI_NeedsProto(_alloca) \
407 SymI_HasProto(isxdigit) \
408 SymI_HasProto(isupper) \
409 SymI_HasProto(ispunct) \
410 SymI_HasProto(islower) \
411 SymI_HasProto(isspace) \
412 SymI_HasProto(isprint) \
413 SymI_HasProto(isdigit) \
414 SymI_HasProto(iscntrl) \
415 SymI_HasProto(isalpha) \
416 SymI_HasProto(isalnum) \
417 SymI_HasProto(isascii) \
418 RTS___MINGW_VFPRINTF_SYM \
419 SymI_HasProto(strcmp) \
420 SymI_HasProto(memmove) \
421 SymI_HasProto(realloc) \
422 SymI_HasProto(malloc) \
423 SymI_HasProto(pow) \
424 SymI_HasProto(tanh) \
425 SymI_HasProto(cosh) \
426 SymI_HasProto(sinh) \
427 SymI_HasProto(atan) \
428 SymI_HasProto(acos) \
429 SymI_HasProto(asin) \
430 SymI_HasProto(tan) \
431 SymI_HasProto(cos) \
432 SymI_HasProto(sin) \
433 SymI_HasProto(exp) \
434 SymI_HasProto(log) \
435 SymI_HasProto(sqrt) \
436 SymI_HasProto(powf) \
437 SymI_HasProto(tanhf) \
438 SymI_HasProto(coshf) \
439 SymI_HasProto(sinhf) \
440 SymI_HasProto(atanf) \
441 SymI_HasProto(acosf) \
442 SymI_HasProto(asinf) \
443 SymI_HasProto(tanf) \
444 SymI_HasProto(cosf) \
445 SymI_HasProto(sinf) \
446 SymI_HasProto(expf) \
447 SymI_HasProto(logf) \
448 SymI_HasProto(sqrtf) \
449 SymI_HasProto(erf) \
450 SymI_HasProto(erfc) \
451 SymI_HasProto(erff) \
452 SymI_HasProto(erfcf) \
453 SymI_HasProto(memcpy) \
454 SymI_HasProto(rts_InstallConsoleEvent) \
455 SymI_HasProto(rts_ConsoleHandlerDone) \
456 SymI_NeedsProto(mktime) \
457 SymI_NeedsProto(_imp___timezone) \
458 SymI_NeedsProto(_imp___tzname) \
459 SymI_NeedsProto(_imp__tzname) \
460 SymI_NeedsProto(_imp___iob) \
461 SymI_NeedsProto(_imp___osver) \
462 SymI_NeedsProto(localtime) \
463 SymI_NeedsProto(gmtime) \
464 SymI_NeedsProto(opendir) \
465 SymI_NeedsProto(readdir) \
466 SymI_NeedsProto(rewinddir) \
467 SymI_NeedsProto(_imp____mb_cur_max) \
468 SymI_NeedsProto(_imp___pctype) \
469 SymI_NeedsProto(__chkstk) \
470 RTS_MINGW_GETTIMEOFDAY_SYM \
471 SymI_NeedsProto(closedir)
472 #endif
473
474
475 #if defined(darwin_HOST_OS) && HAVE_PRINTF_LDBLSTUB
476 #define RTS_DARWIN_ONLY_SYMBOLS \
477 SymI_NeedsProto(asprintf$LDBLStub) \
478 SymI_NeedsProto(err$LDBLStub) \
479 SymI_NeedsProto(errc$LDBLStub) \
480 SymI_NeedsProto(errx$LDBLStub) \
481 SymI_NeedsProto(fprintf$LDBLStub) \
482 SymI_NeedsProto(fscanf$LDBLStub) \
483 SymI_NeedsProto(fwprintf$LDBLStub) \
484 SymI_NeedsProto(fwscanf$LDBLStub) \
485 SymI_NeedsProto(printf$LDBLStub) \
486 SymI_NeedsProto(scanf$LDBLStub) \
487 SymI_NeedsProto(snprintf$LDBLStub) \
488 SymI_NeedsProto(sprintf$LDBLStub) \
489 SymI_NeedsProto(sscanf$LDBLStub) \
490 SymI_NeedsProto(strtold$LDBLStub) \
491 SymI_NeedsProto(swprintf$LDBLStub) \
492 SymI_NeedsProto(swscanf$LDBLStub) \
493 SymI_NeedsProto(syslog$LDBLStub) \
494 SymI_NeedsProto(vasprintf$LDBLStub) \
495 SymI_NeedsProto(verr$LDBLStub) \
496 SymI_NeedsProto(verrc$LDBLStub) \
497 SymI_NeedsProto(verrx$LDBLStub) \
498 SymI_NeedsProto(vfprintf$LDBLStub) \
499 SymI_NeedsProto(vfscanf$LDBLStub) \
500 SymI_NeedsProto(vfwprintf$LDBLStub) \
501 SymI_NeedsProto(vfwscanf$LDBLStub) \
502 SymI_NeedsProto(vprintf$LDBLStub) \
503 SymI_NeedsProto(vscanf$LDBLStub) \
504 SymI_NeedsProto(vsnprintf$LDBLStub) \
505 SymI_NeedsProto(vsprintf$LDBLStub) \
506 SymI_NeedsProto(vsscanf$LDBLStub) \
507 SymI_NeedsProto(vswprintf$LDBLStub) \
508 SymI_NeedsProto(vswscanf$LDBLStub) \
509 SymI_NeedsProto(vsyslog$LDBLStub) \
510 SymI_NeedsProto(vwarn$LDBLStub) \
511 SymI_NeedsProto(vwarnc$LDBLStub) \
512 SymI_NeedsProto(vwarnx$LDBLStub) \
513 SymI_NeedsProto(vwprintf$LDBLStub) \
514 SymI_NeedsProto(vwscanf$LDBLStub) \
515 SymI_NeedsProto(warn$LDBLStub) \
516 SymI_NeedsProto(warnc$LDBLStub) \
517 SymI_NeedsProto(warnx$LDBLStub) \
518 SymI_NeedsProto(wcstold$LDBLStub) \
519 SymI_NeedsProto(wprintf$LDBLStub) \
520 SymI_NeedsProto(wscanf$LDBLStub)
521 #else
522 #define RTS_DARWIN_ONLY_SYMBOLS
523 #endif
524
525 #ifndef SMP
526 # define MAIN_CAP_SYM SymI_HasProto(MainCapability)
527 #else
528 # define MAIN_CAP_SYM
529 #endif
530
531 #if !defined(mingw32_HOST_OS)
532 #define RTS_USER_SIGNALS_SYMBOLS \
533 SymI_HasProto(setIOManagerControlFd) \
534 SymI_HasProto(setIOManagerWakeupFd) \
535 SymI_HasProto(ioManagerWakeup) \
536 SymI_HasProto(blockUserSignals) \
537 SymI_HasProto(unblockUserSignals)
538 #else
539 #define RTS_USER_SIGNALS_SYMBOLS \
540 SymI_HasProto(ioManagerWakeup) \
541 SymI_HasProto(sendIOManagerEvent) \
542 SymI_HasProto(readIOManagerEvent) \
543 SymI_HasProto(getIOManagerEvent) \
544 SymI_HasProto(console_handler)
545 #endif
546
547 #define RTS_LIBFFI_SYMBOLS \
548 SymE_NeedsProto(ffi_prep_cif) \
549 SymE_NeedsProto(ffi_call) \
550 SymE_NeedsProto(ffi_type_void) \
551 SymE_NeedsProto(ffi_type_float) \
552 SymE_NeedsProto(ffi_type_double) \
553 SymE_NeedsProto(ffi_type_sint64) \
554 SymE_NeedsProto(ffi_type_uint64) \
555 SymE_NeedsProto(ffi_type_sint32) \
556 SymE_NeedsProto(ffi_type_uint32) \
557 SymE_NeedsProto(ffi_type_sint16) \
558 SymE_NeedsProto(ffi_type_uint16) \
559 SymE_NeedsProto(ffi_type_sint8) \
560 SymE_NeedsProto(ffi_type_uint8) \
561 SymE_NeedsProto(ffi_type_pointer)
562
563 #ifdef TABLES_NEXT_TO_CODE
564 #define RTS_RET_SYMBOLS /* nothing */
565 #else
566 #define RTS_RET_SYMBOLS \
567 SymI_HasProto(stg_enter_ret) \
568 SymI_HasProto(stg_gc_fun_ret) \
569 SymI_HasProto(stg_ap_v_ret) \
570 SymI_HasProto(stg_ap_f_ret) \
571 SymI_HasProto(stg_ap_d_ret) \
572 SymI_HasProto(stg_ap_l_ret) \
573 SymI_HasProto(stg_ap_n_ret) \
574 SymI_HasProto(stg_ap_p_ret) \
575 SymI_HasProto(stg_ap_pv_ret) \
576 SymI_HasProto(stg_ap_pp_ret) \
577 SymI_HasProto(stg_ap_ppv_ret) \
578 SymI_HasProto(stg_ap_ppp_ret) \
579 SymI_HasProto(stg_ap_pppv_ret) \
580 SymI_HasProto(stg_ap_pppp_ret) \
581 SymI_HasProto(stg_ap_ppppp_ret) \
582 SymI_HasProto(stg_ap_pppppp_ret)
583 #endif
584
585 /* Modules compiled with -ticky may mention ticky counters */
586 /* This list should marry up with the one in $(TOP)/includes/stg/Ticky.h */
587 #define RTS_TICKY_SYMBOLS \
588 SymI_NeedsProto(ticky_entry_ctrs) \
589 SymI_NeedsProto(top_ct) \
590 \
591 SymI_HasProto(ENT_VIA_NODE_ctr) \
592 SymI_HasProto(ENT_STATIC_THK_ctr) \
593 SymI_HasProto(ENT_DYN_THK_ctr) \
594 SymI_HasProto(ENT_STATIC_FUN_DIRECT_ctr) \
595 SymI_HasProto(ENT_DYN_FUN_DIRECT_ctr) \
596 SymI_HasProto(ENT_STATIC_CON_ctr) \
597 SymI_HasProto(ENT_DYN_CON_ctr) \
598 SymI_HasProto(ENT_STATIC_IND_ctr) \
599 SymI_HasProto(ENT_DYN_IND_ctr) \
600 SymI_HasProto(ENT_PERM_IND_ctr) \
601 SymI_HasProto(ENT_PAP_ctr) \
602 SymI_HasProto(ENT_AP_ctr) \
603 SymI_HasProto(ENT_AP_STACK_ctr) \
604 SymI_HasProto(ENT_BH_ctr) \
605 SymI_HasProto(UNKNOWN_CALL_ctr) \
606 SymI_HasProto(SLOW_CALL_v_ctr) \
607 SymI_HasProto(SLOW_CALL_f_ctr) \
608 SymI_HasProto(SLOW_CALL_d_ctr) \
609 SymI_HasProto(SLOW_CALL_l_ctr) \
610 SymI_HasProto(SLOW_CALL_n_ctr) \
611 SymI_HasProto(SLOW_CALL_p_ctr) \
612 SymI_HasProto(SLOW_CALL_pv_ctr) \
613 SymI_HasProto(SLOW_CALL_pp_ctr) \
614 SymI_HasProto(SLOW_CALL_ppv_ctr) \
615 SymI_HasProto(SLOW_CALL_ppp_ctr) \
616 SymI_HasProto(SLOW_CALL_pppv_ctr) \
617 SymI_HasProto(SLOW_CALL_pppp_ctr) \
618 SymI_HasProto(SLOW_CALL_ppppp_ctr) \
619 SymI_HasProto(SLOW_CALL_pppppp_ctr) \
620 SymI_HasProto(SLOW_CALL_OTHER_ctr) \
621 SymI_HasProto(ticky_slow_call_unevald) \
622 SymI_HasProto(SLOW_CALL_ctr) \
623 SymI_HasProto(MULTI_CHUNK_SLOW_CALL_ctr) \
624 SymI_HasProto(MULTI_CHUNK_SLOW_CALL_CHUNKS_ctr) \
625 SymI_HasProto(KNOWN_CALL_ctr) \
626 SymI_HasProto(KNOWN_CALL_TOO_FEW_ARGS_ctr) \
627 SymI_HasProto(KNOWN_CALL_EXTRA_ARGS_ctr) \
628 SymI_HasProto(SLOW_CALL_FUN_TOO_FEW_ctr) \
629 SymI_HasProto(SLOW_CALL_FUN_CORRECT_ctr) \
630 SymI_HasProto(SLOW_CALL_FUN_TOO_MANY_ctr) \
631 SymI_HasProto(SLOW_CALL_PAP_TOO_FEW_ctr) \
632 SymI_HasProto(SLOW_CALL_PAP_CORRECT_ctr) \
633 SymI_HasProto(SLOW_CALL_PAP_TOO_MANY_ctr) \
634 SymI_HasProto(SLOW_CALL_UNEVALD_ctr) \
635 SymI_HasProto(UPDF_OMITTED_ctr) \
636 SymI_HasProto(UPDF_PUSHED_ctr) \
637 SymI_HasProto(CATCHF_PUSHED_ctr) \
638 SymI_HasProto(UPDF_RCC_PUSHED_ctr) \
639 SymI_HasProto(UPDF_RCC_OMITTED_ctr) \
640 SymI_HasProto(UPD_SQUEEZED_ctr) \
641 SymI_HasProto(UPD_CON_IN_NEW_ctr) \
642 SymI_HasProto(UPD_CON_IN_PLACE_ctr) \
643 SymI_HasProto(UPD_PAP_IN_NEW_ctr) \
644 SymI_HasProto(UPD_PAP_IN_PLACE_ctr) \
645 SymI_HasProto(ALLOC_HEAP_ctr) \
646 SymI_HasProto(ALLOC_HEAP_tot) \
647 SymI_HasProto(ALLOC_FUN_ctr) \
648 SymI_HasProto(ALLOC_FUN_adm) \
649 SymI_HasProto(ALLOC_FUN_gds) \
650 SymI_HasProto(ALLOC_FUN_slp) \
651 SymI_HasProto(UPD_NEW_IND_ctr) \
652 SymI_HasProto(UPD_NEW_PERM_IND_ctr) \
653 SymI_HasProto(UPD_OLD_IND_ctr) \
654 SymI_HasProto(UPD_OLD_PERM_IND_ctr) \
655 SymI_HasProto(UPD_BH_UPDATABLE_ctr) \
656 SymI_HasProto(UPD_BH_SINGLE_ENTRY_ctr) \
657 SymI_HasProto(UPD_CAF_BH_UPDATABLE_ctr) \
658 SymI_HasProto(UPD_CAF_BH_SINGLE_ENTRY_ctr) \
659 SymI_HasProto(GC_SEL_ABANDONED_ctr) \
660 SymI_HasProto(GC_SEL_MINOR_ctr) \
661 SymI_HasProto(GC_SEL_MAJOR_ctr) \
662 SymI_HasProto(GC_FAILED_PROMOTION_ctr) \
663 SymI_HasProto(ALLOC_UP_THK_ctr) \
664 SymI_HasProto(ALLOC_SE_THK_ctr) \
665 SymI_HasProto(ALLOC_THK_adm) \
666 SymI_HasProto(ALLOC_THK_gds) \
667 SymI_HasProto(ALLOC_THK_slp) \
668 SymI_HasProto(ALLOC_CON_ctr) \
669 SymI_HasProto(ALLOC_CON_adm) \
670 SymI_HasProto(ALLOC_CON_gds) \
671 SymI_HasProto(ALLOC_CON_slp) \
672 SymI_HasProto(ALLOC_TUP_ctr) \
673 SymI_HasProto(ALLOC_TUP_adm) \
674 SymI_HasProto(ALLOC_TUP_gds) \
675 SymI_HasProto(ALLOC_TUP_slp) \
676 SymI_HasProto(ALLOC_BH_ctr) \
677 SymI_HasProto(ALLOC_BH_adm) \
678 SymI_HasProto(ALLOC_BH_gds) \
679 SymI_HasProto(ALLOC_BH_slp) \
680 SymI_HasProto(ALLOC_PRIM_ctr) \
681 SymI_HasProto(ALLOC_PRIM_adm) \
682 SymI_HasProto(ALLOC_PRIM_gds) \
683 SymI_HasProto(ALLOC_PRIM_slp) \
684 SymI_HasProto(ALLOC_PAP_ctr) \
685 SymI_HasProto(ALLOC_PAP_adm) \
686 SymI_HasProto(ALLOC_PAP_gds) \
687 SymI_HasProto(ALLOC_PAP_slp) \
688 SymI_HasProto(ALLOC_TSO_ctr) \
689 SymI_HasProto(ALLOC_TSO_adm) \
690 SymI_HasProto(ALLOC_TSO_gds) \
691 SymI_HasProto(ALLOC_TSO_slp) \
692 SymI_HasProto(RET_NEW_ctr) \
693 SymI_HasProto(RET_OLD_ctr) \
694 SymI_HasProto(RET_UNBOXED_TUP_ctr) \
695 SymI_HasProto(RET_SEMI_loads_avoided)
696
697
698 // On most platforms, the garbage collector rewrites references
699 // to small integer and char objects to a set of common, shared ones.
700 //
701 // We don't do this when compiling to Windows DLLs at the moment because
702 // it doesn't support cross package data references well.
703 //
704 #if defined(__PIC__) && defined(mingw32_HOST_OS)
705 #define RTS_INTCHAR_SYMBOLS
706 #else
707 #define RTS_INTCHAR_SYMBOLS \
708 SymI_HasProto(stg_CHARLIKE_closure) \
709 SymI_HasProto(stg_INTLIKE_closure)
710 #endif
711
712
713 #define RTS_SYMBOLS \
714 Maybe_Stable_Names \
715 RTS_TICKY_SYMBOLS \
716 SymI_HasProto(StgReturn) \
717 SymI_HasProto(stg_enter_info) \
718 SymI_HasProto(stg_gc_void_info) \
719 SymI_HasProto(__stg_gc_enter_1) \
720 SymI_HasProto(stg_gc_noregs) \
721 SymI_HasProto(stg_gc_unpt_r1_info) \
722 SymI_HasProto(stg_gc_unpt_r1) \
723 SymI_HasProto(stg_gc_unbx_r1_info) \
724 SymI_HasProto(stg_gc_unbx_r1) \
725 SymI_HasProto(stg_gc_f1_info) \
726 SymI_HasProto(stg_gc_f1) \
727 SymI_HasProto(stg_gc_d1_info) \
728 SymI_HasProto(stg_gc_d1) \
729 SymI_HasProto(stg_gc_l1_info) \
730 SymI_HasProto(stg_gc_l1) \
731 SymI_HasProto(__stg_gc_fun) \
732 SymI_HasProto(stg_gc_fun_info) \
733 SymI_HasProto(stg_gc_gen) \
734 SymI_HasProto(stg_gc_gen_info) \
735 SymI_HasProto(stg_gc_gen_hp) \
736 SymI_HasProto(stg_gc_ut) \
737 SymI_HasProto(stg_gen_yield) \
738 SymI_HasProto(stg_yield_noregs) \
739 SymI_HasProto(stg_yield_to_interpreter) \
740 SymI_HasProto(stg_gen_block) \
741 SymI_HasProto(stg_block_noregs) \
742 SymI_HasProto(stg_block_1) \
743 SymI_HasProto(stg_block_takemvar) \
744 SymI_HasProto(stg_block_putmvar) \
745 MAIN_CAP_SYM \
746 SymI_HasProto(MallocFailHook) \
747 SymI_HasProto(OnExitHook) \
748 SymI_HasProto(OutOfHeapHook) \
749 SymI_HasProto(StackOverflowHook) \
750 SymI_HasProto(addDLL) \
751 SymI_HasProto(__int_encodeDouble) \
752 SymI_HasProto(__word_encodeDouble) \
753 SymI_HasProto(__2Int_encodeDouble) \
754 SymI_HasProto(__int_encodeFloat) \
755 SymI_HasProto(__word_encodeFloat) \
756 SymI_HasProto(stg_atomicallyzh) \
757 SymI_HasProto(barf) \
758 SymI_HasProto(debugBelch) \
759 SymI_HasProto(errorBelch) \
760 SymI_HasProto(sysErrorBelch) \
761 SymI_HasProto(stg_getMaskingStatezh) \
762 SymI_HasProto(stg_maskAsyncExceptionszh) \
763 SymI_HasProto(stg_maskUninterruptiblezh) \
764 SymI_HasProto(stg_catchzh) \
765 SymI_HasProto(stg_catchRetryzh) \
766 SymI_HasProto(stg_catchSTMzh) \
767 SymI_HasProto(stg_checkzh) \
768 SymI_HasProto(closure_flags) \
769 SymI_HasProto(cmp_thread) \
770 SymI_HasProto(createAdjustor) \
771 SymI_HasProto(stg_decodeDoublezu2Intzh) \
772 SymI_HasProto(stg_decodeFloatzuIntzh) \
773 SymI_HasProto(defaultsHook) \
774 SymI_HasProto(stg_delayzh) \
775 SymI_HasProto(stg_deRefWeakzh) \
776 SymI_HasProto(stg_deRefStablePtrzh) \
777 SymI_HasProto(dirty_MUT_VAR) \
778 SymI_HasProto(stg_forkzh) \
779 SymI_HasProto(stg_forkOnzh) \
780 SymI_HasProto(forkProcess) \
781 SymI_HasProto(forkOS_createThread) \
782 SymI_HasProto(freeHaskellFunctionPtr) \
783 SymI_HasProto(getOrSetTypeableStore) \
784 SymI_HasProto(getOrSetGHCConcSignalSignalHandlerStore) \
785 SymI_HasProto(getOrSetGHCConcWindowsPendingDelaysStore) \
786 SymI_HasProto(getOrSetGHCConcWindowsIOManagerThreadStore) \
787 SymI_HasProto(getOrSetGHCConcWindowsProddingStore) \
788 SymI_HasProto(getOrSetSystemEventThreadEventManagerStore) \
789 SymI_HasProto(getOrSetSystemEventThreadIOManagerThreadStore) \
790 SymI_HasProto(genSymZh) \
791 SymI_HasProto(genericRaise) \
792 SymI_HasProto(getProgArgv) \
793 SymI_HasProto(getFullProgArgv) \
794 SymI_HasProto(getStablePtr) \
795 SymI_HasProto(hs_init) \
796 SymI_HasProto(hs_exit) \
797 SymI_HasProto(hs_set_argv) \
798 SymI_HasProto(hs_add_root) \
799 SymI_HasProto(hs_perform_gc) \
800 SymI_HasProto(hs_free_stable_ptr) \
801 SymI_HasProto(hs_free_fun_ptr) \
802 SymI_HasProto(hs_hpc_rootModule) \
803 SymI_HasProto(hs_hpc_module) \
804 SymI_HasProto(initLinker) \
805 SymI_HasProto(stg_unpackClosurezh) \
806 SymI_HasProto(stg_getApStackValzh) \
807 SymI_HasProto(stg_getSparkzh) \
808 SymI_HasProto(stg_numSparkszh) \
809 SymI_HasProto(stg_isCurrentThreadBoundzh) \
810 SymI_HasProto(stg_isEmptyMVarzh) \
811 SymI_HasProto(stg_killThreadzh) \
812 SymI_HasProto(loadArchive) \
813 SymI_HasProto(loadObj) \
814 SymI_HasProto(insertStableSymbol) \
815 SymI_HasProto(insertSymbol) \
816 SymI_HasProto(lookupSymbol) \
817 SymI_HasProto(stg_makeStablePtrzh) \
818 SymI_HasProto(stg_mkApUpd0zh) \
819 SymI_HasProto(stg_myThreadIdzh) \
820 SymI_HasProto(stg_labelThreadzh) \
821 SymI_HasProto(stg_newArrayzh) \
822 SymI_HasProto(stg_newBCOzh) \
823 SymI_HasProto(stg_newByteArrayzh) \
824 SymI_HasProto_redirect(newCAF, newDynCAF) \
825 SymI_HasProto(stg_newMVarzh) \
826 SymI_HasProto(stg_newMutVarzh) \
827 SymI_HasProto(stg_newTVarzh) \
828 SymI_HasProto(stg_noDuplicatezh) \
829 SymI_HasProto(stg_atomicModifyMutVarzh) \
830 SymI_HasProto(stg_newPinnedByteArrayzh) \
831 SymI_HasProto(stg_newAlignedPinnedByteArrayzh) \
832 SymI_HasProto(newSpark) \
833 SymI_HasProto(performGC) \
834 SymI_HasProto(performMajorGC) \
835 SymI_HasProto(prog_argc) \
836 SymI_HasProto(prog_argv) \
837 SymI_HasProto(stg_putMVarzh) \
838 SymI_HasProto(stg_raisezh) \
839 SymI_HasProto(stg_raiseIOzh) \
840 SymI_HasProto(stg_readTVarzh) \
841 SymI_HasProto(stg_readTVarIOzh) \
842 SymI_HasProto(resumeThread) \
843 SymI_HasProto(resolveObjs) \
844 SymI_HasProto(stg_retryzh) \
845 SymI_HasProto(rts_apply) \
846 SymI_HasProto(rts_checkSchedStatus) \
847 SymI_HasProto(rts_eval) \
848 SymI_HasProto(rts_evalIO) \
849 SymI_HasProto(rts_evalLazyIO) \
850 SymI_HasProto(rts_evalStableIO) \
851 SymI_HasProto(rts_eval_) \
852 SymI_HasProto(rts_getBool) \
853 SymI_HasProto(rts_getChar) \
854 SymI_HasProto(rts_getDouble) \
855 SymI_HasProto(rts_getFloat) \
856 SymI_HasProto(rts_getInt) \
857 SymI_HasProto(rts_getInt8) \
858 SymI_HasProto(rts_getInt16) \
859 SymI_HasProto(rts_getInt32) \
860 SymI_HasProto(rts_getInt64) \
861 SymI_HasProto(rts_getPtr) \
862 SymI_HasProto(rts_getFunPtr) \
863 SymI_HasProto(rts_getStablePtr) \
864 SymI_HasProto(rts_getThreadId) \
865 SymI_HasProto(rts_getWord) \
866 SymI_HasProto(rts_getWord8) \
867 SymI_HasProto(rts_getWord16) \
868 SymI_HasProto(rts_getWord32) \
869 SymI_HasProto(rts_getWord64) \
870 SymI_HasProto(rts_lock) \
871 SymI_HasProto(rts_mkBool) \
872 SymI_HasProto(rts_mkChar) \
873 SymI_HasProto(rts_mkDouble) \
874 SymI_HasProto(rts_mkFloat) \
875 SymI_HasProto(rts_mkInt) \
876 SymI_HasProto(rts_mkInt8) \
877 SymI_HasProto(rts_mkInt16) \
878 SymI_HasProto(rts_mkInt32) \
879 SymI_HasProto(rts_mkInt64) \
880 SymI_HasProto(rts_mkPtr) \
881 SymI_HasProto(rts_mkFunPtr) \
882 SymI_HasProto(rts_mkStablePtr) \
883 SymI_HasProto(rts_mkString) \
884 SymI_HasProto(rts_mkWord) \
885 SymI_HasProto(rts_mkWord8) \
886 SymI_HasProto(rts_mkWord16) \
887 SymI_HasProto(rts_mkWord32) \
888 SymI_HasProto(rts_mkWord64) \
889 SymI_HasProto(rts_unlock) \
890 SymI_HasProto(rts_unsafeGetMyCapability) \
891 SymI_HasProto(rtsSupportsBoundThreads) \
892 SymI_HasProto(rts_isProfiled) \
893 SymI_HasProto(setProgArgv) \
894 SymI_HasProto(startupHaskell) \
895 SymI_HasProto(shutdownHaskell) \
896 SymI_HasProto(shutdownHaskellAndExit) \
897 SymI_HasProto(stable_ptr_table) \
898 SymI_HasProto(stackOverflow) \
899 SymI_HasProto(stg_CAF_BLACKHOLE_info) \
900 SymI_HasProto(stg_BLACKHOLE_info) \
901 SymI_HasProto(__stg_EAGER_BLACKHOLE_info) \
902 SymI_HasProto(stg_BLOCKING_QUEUE_CLEAN_info) \
903 SymI_HasProto(stg_BLOCKING_QUEUE_DIRTY_info) \
904 SymI_HasProto(startTimer) \
905 SymI_HasProto(stg_MVAR_CLEAN_info) \
906 SymI_HasProto(stg_MVAR_DIRTY_info) \
907 SymI_HasProto(stg_IND_STATIC_info) \
908 SymI_HasProto(stg_ARR_WORDS_info) \
909 SymI_HasProto(stg_MUT_ARR_PTRS_DIRTY_info) \
910 SymI_HasProto(stg_MUT_ARR_PTRS_FROZEN_info) \
911 SymI_HasProto(stg_MUT_ARR_PTRS_FROZEN0_info) \
912 SymI_HasProto(stg_WEAK_info) \
913 SymI_HasProto(stg_ap_v_info) \
914 SymI_HasProto(stg_ap_f_info) \
915 SymI_HasProto(stg_ap_d_info) \
916 SymI_HasProto(stg_ap_l_info) \
917 SymI_HasProto(stg_ap_n_info) \
918 SymI_HasProto(stg_ap_p_info) \
919 SymI_HasProto(stg_ap_pv_info) \
920 SymI_HasProto(stg_ap_pp_info) \
921 SymI_HasProto(stg_ap_ppv_info) \
922 SymI_HasProto(stg_ap_ppp_info) \
923 SymI_HasProto(stg_ap_pppv_info) \
924 SymI_HasProto(stg_ap_pppp_info) \
925 SymI_HasProto(stg_ap_ppppp_info) \
926 SymI_HasProto(stg_ap_pppppp_info) \
927 SymI_HasProto(stg_ap_0_fast) \
928 SymI_HasProto(stg_ap_v_fast) \
929 SymI_HasProto(stg_ap_f_fast) \
930 SymI_HasProto(stg_ap_d_fast) \
931 SymI_HasProto(stg_ap_l_fast) \
932 SymI_HasProto(stg_ap_n_fast) \
933 SymI_HasProto(stg_ap_p_fast) \
934 SymI_HasProto(stg_ap_pv_fast) \
935 SymI_HasProto(stg_ap_pp_fast) \
936 SymI_HasProto(stg_ap_ppv_fast) \
937 SymI_HasProto(stg_ap_ppp_fast) \
938 SymI_HasProto(stg_ap_pppv_fast) \
939 SymI_HasProto(stg_ap_pppp_fast) \
940 SymI_HasProto(stg_ap_ppppp_fast) \
941 SymI_HasProto(stg_ap_pppppp_fast) \
942 SymI_HasProto(stg_ap_1_upd_info) \
943 SymI_HasProto(stg_ap_2_upd_info) \
944 SymI_HasProto(stg_ap_3_upd_info) \
945 SymI_HasProto(stg_ap_4_upd_info) \
946 SymI_HasProto(stg_ap_5_upd_info) \
947 SymI_HasProto(stg_ap_6_upd_info) \
948 SymI_HasProto(stg_ap_7_upd_info) \
949 SymI_HasProto(stg_exit) \
950 SymI_HasProto(stg_sel_0_upd_info) \
951 SymI_HasProto(stg_sel_10_upd_info) \
952 SymI_HasProto(stg_sel_11_upd_info) \
953 SymI_HasProto(stg_sel_12_upd_info) \
954 SymI_HasProto(stg_sel_13_upd_info) \
955 SymI_HasProto(stg_sel_14_upd_info) \
956 SymI_HasProto(stg_sel_15_upd_info) \
957 SymI_HasProto(stg_sel_1_upd_info) \
958 SymI_HasProto(stg_sel_2_upd_info) \
959 SymI_HasProto(stg_sel_3_upd_info) \
960 SymI_HasProto(stg_sel_4_upd_info) \
961 SymI_HasProto(stg_sel_5_upd_info) \
962 SymI_HasProto(stg_sel_6_upd_info) \
963 SymI_HasProto(stg_sel_7_upd_info) \
964 SymI_HasProto(stg_sel_8_upd_info) \
965 SymI_HasProto(stg_sel_9_upd_info) \
966 SymI_HasProto(stg_upd_frame_info) \
967 SymI_HasProto(stg_bh_upd_frame_info) \
968 SymI_HasProto(suspendThread) \
969 SymI_HasProto(stg_takeMVarzh) \
970 SymI_HasProto(stg_threadStatuszh) \
971 SymI_HasProto(stg_tryPutMVarzh) \
972 SymI_HasProto(stg_tryTakeMVarzh) \
973 SymI_HasProto(stg_unmaskAsyncExceptionszh) \
974 SymI_HasProto(unloadObj) \
975 SymI_HasProto(stg_unsafeThawArrayzh) \
976 SymI_HasProto(stg_waitReadzh) \
977 SymI_HasProto(stg_waitWritezh) \
978 SymI_HasProto(stg_writeTVarzh) \
979 SymI_HasProto(stg_yieldzh) \
980 SymI_NeedsProto(stg_interp_constr_entry) \
981 SymI_HasProto(stg_arg_bitmaps) \
982 SymI_HasProto(alloc_blocks_lim) \
983 SymI_HasProto(g0) \
984 SymI_HasProto(allocate) \
985 SymI_HasProto(allocateExec) \
986 SymI_HasProto(freeExec) \
987 SymI_HasProto(getAllocations) \
988 SymI_HasProto(revertCAFs) \
989 SymI_HasProto(RtsFlags) \
990 SymI_NeedsProto(rts_breakpoint_io_action) \
991 SymI_NeedsProto(rts_stop_next_breakpoint) \
992 SymI_NeedsProto(rts_stop_on_exception) \
993 SymI_HasProto(stopTimer) \
994 SymI_HasProto(n_capabilities) \
995 SymI_HasProto(stg_traceCcszh) \
996 SymI_HasProto(stg_traceEventzh) \
997 RTS_USER_SIGNALS_SYMBOLS \
998 RTS_INTCHAR_SYMBOLS
999
1000
1001 // 64-bit support functions in libgcc.a
1002 #if defined(__GNUC__) && SIZEOF_VOID_P <= 4
1003 #define RTS_LIBGCC_SYMBOLS \
1004 SymI_NeedsProto(__divdi3) \
1005 SymI_NeedsProto(__udivdi3) \
1006 SymI_NeedsProto(__moddi3) \
1007 SymI_NeedsProto(__umoddi3) \
1008 SymI_NeedsProto(__muldi3) \
1009 SymI_NeedsProto(__ashldi3) \
1010 SymI_NeedsProto(__ashrdi3) \
1011 SymI_NeedsProto(__lshrdi3)
1012 #else
1013 #define RTS_LIBGCC_SYMBOLS
1014 #endif
1015
1016 #if defined(darwin_HOST_OS) && defined(powerpc_HOST_ARCH)
1017 // Symbols that don't have a leading underscore
1018 // on Mac OS X. They have to receive special treatment,
1019 // see machoInitSymbolsWithoutUnderscore()
1020 #define RTS_MACHO_NOUNDERLINE_SYMBOLS \
1021 SymI_NeedsProto(saveFP) \
1022 SymI_NeedsProto(restFP)
1023 #endif
1024
1025 /* entirely bogus claims about types of these symbols */
1026 #define SymI_NeedsProto(vvv) extern void vvv(void);
1027 #if defined(__PIC__) && defined(mingw32_HOST_OS)
1028 #define SymE_HasProto(vvv) SymE_HasProto(vvv);
1029 #define SymE_NeedsProto(vvv) extern void _imp__ ## vvv (void);
1030 #else
1031 #define SymE_NeedsProto(vvv) SymI_NeedsProto(vvv);
1032 #define SymE_HasProto(vvv) SymI_HasProto(vvv)
1033 #endif
1034 #define SymI_HasProto(vvv) /**/
1035 #define SymI_HasProto_redirect(vvv,xxx) /**/
1036 RTS_SYMBOLS
1037 RTS_RET_SYMBOLS
1038 RTS_POSIX_ONLY_SYMBOLS
1039 RTS_MINGW_ONLY_SYMBOLS
1040 RTS_CYGWIN_ONLY_SYMBOLS
1041 RTS_DARWIN_ONLY_SYMBOLS
1042 RTS_LIBGCC_SYMBOLS
1043 RTS_LIBFFI_SYMBOLS
1044 #undef SymI_NeedsProto
1045 #undef SymI_HasProto
1046 #undef SymI_HasProto_redirect
1047 #undef SymE_HasProto
1048 #undef SymE_NeedsProto
1049
1050 #ifdef LEADING_UNDERSCORE
1051 #define MAYBE_LEADING_UNDERSCORE_STR(s) ("_" s)
1052 #else
1053 #define MAYBE_LEADING_UNDERSCORE_STR(s) (s)
1054 #endif
1055
1056 #define SymI_HasProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
1057 (void*)(&(vvv)) },
1058 #define SymE_HasProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
1059 (void*)DLL_IMPORT_DATA_REF(vvv) },
1060
1061 #define SymI_NeedsProto(vvv) SymI_HasProto(vvv)
1062 #define SymE_NeedsProto(vvv) SymE_HasProto(vvv)
1063
1064 // SymI_HasProto_redirect allows us to redirect references to one symbol to
1065 // another symbol. See newCAF/newDynCAF for an example.
1066 #define SymI_HasProto_redirect(vvv,xxx) \
1067 { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
1068 (void*)(&(xxx)) },
1069
1070 static RtsSymbolVal rtsSyms[] = {
1071 RTS_SYMBOLS
1072 RTS_RET_SYMBOLS
1073 RTS_POSIX_ONLY_SYMBOLS
1074 RTS_MINGW_ONLY_SYMBOLS
1075 RTS_CYGWIN_ONLY_SYMBOLS
1076 RTS_DARWIN_ONLY_SYMBOLS
1077 RTS_LIBGCC_SYMBOLS
1078 RTS_LIBFFI_SYMBOLS
1079 #if defined(darwin_HOST_OS) && defined(i386_HOST_ARCH)
1080 // dyld stub code contains references to this,
1081 // but it should never be called because we treat
1082 // lazy pointers as nonlazy.
1083 { "dyld_stub_binding_helper", (void*)0xDEADBEEF },
1084 #endif
1085 { 0, 0 } /* sentinel */
1086 };
1087
1088
1089
1090 /* -----------------------------------------------------------------------------
1091 * Insert symbols into hash tables, checking for duplicates.
1092 */
1093
1094 static void ghciInsertStrHashTable ( char* obj_name,
1095 HashTable *table,
1096 char* key,
1097 void *data
1098 )
1099 {
1100 if (lookupHashTable(table, (StgWord)key) == NULL)
1101 {
1102 insertStrHashTable(table, (StgWord)key, data);
1103 return;
1104 }
1105 debugBelch(
1106 "\n\n"
1107 "GHCi runtime linker: fatal error: I found a duplicate definition for symbol\n"
1108 " %s\n"
1109 "whilst processing object file\n"
1110 " %s\n"
1111 "This could be caused by:\n"
1112 " * Loading two different object files which export the same symbol\n"
1113 " * Specifying the same object file twice on the GHCi command line\n"
1114 " * An incorrect `package.conf' entry, causing some object to be\n"
1115 " loaded twice.\n"
1116 "GHCi cannot safely continue in this situation. Exiting now. Sorry.\n"
1117 "\n",
1118 (char*)key,
1119 obj_name
1120 );
1121 stg_exit(1);
1122 }
1123 /* -----------------------------------------------------------------------------
1124 * initialize the object linker
1125 */
1126
1127
1128 static int linker_init_done = 0 ;
1129
1130 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1131 static void *dl_prog_handle;
1132 static regex_t re_invalid;
1133 static regex_t re_realso;
1134 #ifdef THREADED_RTS
1135 static Mutex dl_mutex; // mutex to protect dlopen/dlerror critical section
1136 #endif
1137 #endif
1138
1139 void
1140 initLinker( void )
1141 {
1142 RtsSymbolVal *sym;
1143 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1144 int compileResult;
1145 #endif
1146
1147 IF_DEBUG(linker, debugBelch("initLinker: start\n"));
1148
1149 /* Make initLinker idempotent, so we can call it
1150 before evey relevant operation; that means we
1151 don't need to initialise the linker separately */
1152 if (linker_init_done == 1) {
1153 IF_DEBUG(linker, debugBelch("initLinker: idempotent return\n"));
1154 return;
1155 } else {
1156 linker_init_done = 1;
1157 }
1158
1159 #if defined(THREADED_RTS) && (defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO))
1160 initMutex(&dl_mutex);
1161 #endif
1162 stablehash = allocStrHashTable();
1163 symhash = allocStrHashTable();
1164
1165 /* populate the symbol table with stuff from the RTS */
1166 for (sym = rtsSyms; sym->lbl != NULL; sym++) {
1167 ghciInsertStrHashTable("(GHCi built-in symbols)",
1168 symhash, sym->lbl, sym->addr);
1169 IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
1170 }
1171 # if defined(OBJFORMAT_MACHO) && defined(powerpc_HOST_ARCH)
1172 machoInitSymbolsWithoutUnderscore();
1173 # endif
1174
1175 # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1176 # if defined(RTLD_DEFAULT)
1177 dl_prog_handle = RTLD_DEFAULT;
1178 # else
1179 dl_prog_handle = dlopen(NULL, RTLD_LAZY);
1180 # endif /* RTLD_DEFAULT */
1181
1182 compileResult = regcomp(&re_invalid,
1183 "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*invalid ELF header",
1184 REG_EXTENDED);
1185 ASSERT( compileResult == 0 );
1186 compileResult = regcomp(&re_realso,
1187 "GROUP *\\( *(([^ )])+)",
1188 REG_EXTENDED);
1189 ASSERT( compileResult == 0 );
1190 # endif
1191
1192 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1193 if (RtsFlags.MiscFlags.linkerMemBase != 0) {
1194 // User-override for mmap_32bit_base
1195 mmap_32bit_base = (void*)RtsFlags.MiscFlags.linkerMemBase;
1196 }
1197 #endif
1198
1199 #if defined(mingw32_HOST_OS)
1200 /*
1201 * These two libraries cause problems when added to the static link,
1202 * but are necessary for resolving symbols in GHCi, hence we load
1203 * them manually here.
1204 */
1205 addDLL("msvcrt");
1206 addDLL("kernel32");
1207 #endif
1208
1209 IF_DEBUG(linker, debugBelch("initLinker: done\n"));
1210 return;
1211 }
1212
1213 void
1214 exitLinker( void ) {
1215 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1216 if (linker_init_done == 1) {
1217 regfree(&re_invalid);
1218 regfree(&re_realso);
1219 #ifdef THREADED_RTS
1220 closeMutex(&dl_mutex);
1221 #endif
1222 }
1223 #endif
1224 }
1225
1226 /* -----------------------------------------------------------------------------
1227 * Loading DLL or .so dynamic libraries
1228 * -----------------------------------------------------------------------------
1229 *
1230 * Add a DLL from which symbols may be found. In the ELF case, just
1231 * do RTLD_GLOBAL-style add, so no further messing around needs to
1232 * happen in order that symbols in the loaded .so are findable --
1233 * lookupSymbol() will subsequently see them by dlsym on the program's
1234 * dl-handle. Returns NULL if success, otherwise ptr to an err msg.
1235 *
1236 * In the PEi386 case, open the DLLs and put handles to them in a
1237 * linked list. When looking for a symbol, try all handles in the
1238 * list. This means that we need to load even DLLs that are guaranteed
1239 * to be in the ghc.exe image already, just so we can get a handle
1240 * to give to loadSymbol, so that we can find the symbols. For such
1241 * libraries, the LoadLibrary call should be a no-op except for returning
1242 * the handle.
1243 *
1244 */
1245
1246 #if defined(OBJFORMAT_PEi386)
1247 /* A record for storing handles into DLLs. */
1248
1249 typedef
1250 struct _OpenedDLL {
1251 char* name;
1252 struct _OpenedDLL* next;
1253 HINSTANCE instance;
1254 }
1255 OpenedDLL;
1256
1257 /* A list thereof. */
1258 static OpenedDLL* opened_dlls = NULL;
1259 #endif
1260
1261 # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1262
1263 static const char *
1264 internal_dlopen(const char *dll_name)
1265 {
1266 void *hdl;
1267 const char *errmsg;
1268 char *errmsg_copy;
1269
1270 // omitted: RTLD_NOW
1271 // see http://www.haskell.org/pipermail/cvs-ghc/2007-September/038570.html
1272 IF_DEBUG(linker,
1273 debugBelch("internal_dlopen: dll_name = '%s'\n", dll_name));
1274
1275 //-------------- Begin critical section ------------------
1276 // This critical section is necessary because dlerror() is not
1277 // required to be reentrant (see POSIX -- IEEE Std 1003.1-2008)
1278 // Also, the error message returned must be copied to preserve it
1279 // (see POSIX also)
1280
1281 ACQUIRE_LOCK(&dl_mutex);
1282 hdl = dlopen(dll_name, RTLD_LAZY | RTLD_GLOBAL);
1283
1284 errmsg = NULL;
1285 if (hdl == NULL) {
1286 /* dlopen failed; return a ptr to the error msg. */
1287 errmsg = dlerror();
1288 if (errmsg == NULL) errmsg = "addDLL: unknown error";
1289 errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL");
1290 strcpy(errmsg_copy, errmsg);
1291 errmsg = errmsg_copy;
1292 }
1293 RELEASE_LOCK(&dl_mutex);
1294 //--------------- End critical section -------------------
1295
1296 return errmsg;
1297 }
1298 # endif
1299
1300 const char *
1301 addDLL( char *dll_name )
1302 {
1303 # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1304 /* ------------------- ELF DLL loader ------------------- */
1305
1306 #define NMATCH 5
1307 regmatch_t match[NMATCH];
1308 const char *errmsg;
1309 FILE* fp;
1310 size_t match_length;
1311 #define MAXLINE 1000
1312 char line[MAXLINE];
1313 int result;
1314
1315 initLinker();
1316
1317 IF_DEBUG(linker, debugBelch("addDLL: dll_name = '%s'\n", dll_name));
1318 errmsg = internal_dlopen(dll_name);
1319
1320 if (errmsg == NULL) {
1321 return NULL;
1322 }
1323
1324 // GHC Trac ticket #2615
1325 // On some systems (e.g., Gentoo Linux) dynamic files (e.g. libc.so)
1326 // contain linker scripts rather than ELF-format object code. This
1327 // code handles the situation by recognizing the real object code
1328 // file name given in the linker script.
1329 //
1330 // If an "invalid ELF header" error occurs, it is assumed that the
1331 // .so file contains a linker script instead of ELF object code.
1332 // In this case, the code looks for the GROUP ( ... ) linker
1333 // directive. If one is found, the first file name inside the
1334 // parentheses is treated as the name of a dynamic library and the
1335 // code attempts to dlopen that file. If this is also unsuccessful,
1336 // an error message is returned.
1337
1338 // see if the error message is due to an invalid ELF header
1339 IF_DEBUG(linker, debugBelch("errmsg = '%s'\n", errmsg));
1340 result = regexec(&re_invalid, errmsg, (size_t) NMATCH, match, 0);
1341 IF_DEBUG(linker, debugBelch("result = %i\n", result));
1342 if (result == 0) {
1343 // success -- try to read the named file as a linker script
1344 match_length = (size_t) stg_min((match[1].rm_eo - match[1].rm_so),
1345 MAXLINE-1);
1346 strncpy(line, (errmsg+(match[1].rm_so)),match_length);
1347 line[match_length] = '\0'; // make sure string is null-terminated
1348 IF_DEBUG(linker, debugBelch ("file name = '%s'\n", line));
1349 if ((fp = fopen(line, "r")) == NULL) {
1350 return errmsg; // return original error if open fails
1351 }
1352 // try to find a GROUP ( ... ) command
1353 while (fgets(line, MAXLINE, fp) != NULL) {
1354 IF_DEBUG(linker, debugBelch("input line = %s", line));
1355 if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) {
1356 // success -- try to dlopen the first named file
1357 IF_DEBUG(linker, debugBelch("match%s\n",""));
1358 line[match[1].rm_eo] = '\0';
1359 errmsg = internal_dlopen(line+match[1].rm_so);
1360 break;
1361 }
1362 // if control reaches here, no GROUP ( ... ) directive was found
1363 // and the original error message is returned to the caller
1364 }
1365 fclose(fp);
1366 }
1367 return errmsg;
1368
1369 # elif defined(OBJFORMAT_PEi386)
1370 /* ------------------- Win32 DLL loader ------------------- */
1371
1372 char* buf;
1373 OpenedDLL* o_dll;
1374 HINSTANCE instance;
1375
1376 initLinker();
1377
1378 /* debugBelch("\naddDLL; dll_name = `%s'\n", dll_name); */
1379
1380 /* See if we've already got it, and ignore if so. */
1381 for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
1382 if (0 == strcmp(o_dll->name, dll_name))
1383 return NULL;
1384 }
1385
1386 /* The file name has no suffix (yet) so that we can try
1387 both foo.dll and foo.drv
1388
1389 The documentation for LoadLibrary says:
1390 If no file name extension is specified in the lpFileName
1391 parameter, the default library extension .dll is
1392 appended. However, the file name string can include a trailing
1393 point character (.) to indicate that the module name has no
1394 extension. */
1395
1396 buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
1397 sprintf(buf, "%s.DLL", dll_name);
1398 instance = LoadLibrary(buf);
1399 if (instance == NULL) {
1400 if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
1401 // KAA: allow loading of drivers (like winspool.drv)
1402 sprintf(buf, "%s.DRV", dll_name);
1403 instance = LoadLibrary(buf);
1404 if (instance == NULL) {
1405 if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
1406 // #1883: allow loading of unix-style libfoo.dll DLLs
1407 sprintf(buf, "lib%s.DLL", dll_name);
1408 instance = LoadLibrary(buf);
1409 if (instance == NULL) {
1410 goto error;
1411 }
1412 }
1413 }
1414 stgFree(buf);
1415
1416 /* Add this DLL to the list of DLLs in which to search for symbols. */
1417 o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
1418 o_dll->name = stgMallocBytes(1+strlen(dll_name), "addDLL");
1419 strcpy(o_dll->name, dll_name);
1420 o_dll->instance = instance;
1421 o_dll->next = opened_dlls;
1422 opened_dlls = o_dll;
1423
1424 return NULL;
1425
1426 error:
1427 stgFree(buf);
1428 sysErrorBelch(dll_name);
1429
1430 /* LoadLibrary failed; return a ptr to the error msg. */
1431 return "addDLL: could not load DLL";
1432
1433 # else
1434 barf("addDLL: not implemented on this platform");
1435 # endif
1436 }
1437
1438 /* -----------------------------------------------------------------------------
1439 * insert a stable symbol in the hash table
1440 */
1441
1442 void
1443 insertStableSymbol(char* obj_name, char* key, StgPtr p)
1444 {
1445 ghciInsertStrHashTable(obj_name, stablehash, key, getStablePtr(p));
1446 }
1447
1448
1449 /* -----------------------------------------------------------------------------
1450 * insert a symbol in the hash table
1451 */
1452 void
1453 insertSymbol(char* obj_name, char* key, void* data)
1454 {
1455 ghciInsertStrHashTable(obj_name, symhash, key, data);
1456 }
1457
1458 /* -----------------------------------------------------------------------------
1459 * lookup a symbol in the hash table
1460 */
1461 void *
1462 lookupSymbol( char *lbl )
1463 {
1464 void *val;
1465 IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s\n", lbl));
1466 initLinker() ;
1467 ASSERT(symhash != NULL);
1468 val = lookupStrHashTable(symhash, lbl);
1469
1470 if (val == NULL) {
1471 IF_DEBUG(linker, debugBelch("lookupSymbol: symbol not found\n"));
1472 # if defined(OBJFORMAT_ELF)
1473 return dlsym(dl_prog_handle, lbl);
1474 # elif defined(OBJFORMAT_MACHO)
1475 # if HAVE_DLFCN_H
1476 /* On OS X 10.3 and later, we use dlsym instead of the old legacy
1477 interface.
1478
1479 HACK: On OS X, global symbols are prefixed with an underscore.
1480 However, dlsym wants us to omit the leading underscore from the
1481 symbol name. For now, we simply strip it off here (and ONLY
1482 here).
1483 */
1484 IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s with dlsym\n", lbl));
1485 ASSERT(lbl[0] == '_');
1486 return dlsym(dl_prog_handle, lbl+1);
1487 # else
1488 if(NSIsSymbolNameDefined(lbl)) {
1489 NSSymbol symbol = NSLookupAndBindSymbol(lbl);
1490 return NSAddressOfSymbol(symbol);
1491 } else {
1492 return NULL;
1493 }
1494 # endif /* HAVE_DLFCN_H */
1495 # elif defined(OBJFORMAT_PEi386)
1496 void* sym;
1497
1498 sym = lookupSymbolInDLLs((unsigned char*)lbl);
1499 if (sym != NULL) { return sym; };
1500
1501 // Also try looking up the symbol without the @N suffix. Some
1502 // DLLs have the suffixes on their symbols, some don't.
1503 zapTrailingAtSign ( (unsigned char*)lbl );
1504 sym = lookupSymbolInDLLs((unsigned char*)lbl);
1505 if (sym != NULL) { return sym; };
1506 return NULL;
1507
1508 # else
1509 ASSERT(2+2 == 5);
1510 return NULL;
1511 # endif
1512 } else {
1513 IF_DEBUG(linker, debugBelch("lookupSymbol: value of %s is %p\n", lbl, val));
1514 return val;
1515 }
1516 }
1517
1518 /* -----------------------------------------------------------------------------
1519 * Debugging aid: look in GHCi's object symbol tables for symbols
1520 * within DELTA bytes of the specified address, and show their names.
1521 */
1522 #ifdef DEBUG
1523 void ghci_enquire ( char* addr );
1524
1525 void ghci_enquire ( char* addr )
1526 {
1527 int i;
1528 char* sym;
1529 char* a;
1530 const int DELTA = 64;
1531 ObjectCode* oc;
1532
1533 initLinker();
1534
1535 for (oc = objects; oc; oc = oc->next) {
1536 for (i = 0; i < oc->n_symbols; i++) {
1537 sym = oc->symbols[i];
1538 if (sym == NULL) continue;
1539 a = NULL;
1540 if (a == NULL) {
1541 a = lookupStrHashTable(symhash, sym);
1542 }
1543 if (a == NULL) {
1544 // debugBelch("ghci_enquire: can't find %s\n", sym);
1545 }
1546 else if (addr-DELTA <= a && a <= addr+DELTA) {
1547 debugBelch("%p + %3d == `%s'\n", addr, (int)(a - addr), sym);
1548 }
1549 }
1550 }
1551 }
1552 #endif
1553
1554 #ifdef USE_MMAP
1555 #define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))
1556
1557 static void *
1558 mmapForLinker (size_t bytes, nat flags, int fd)
1559 {
1560 void *map_addr = NULL;
1561 void *result;
1562 int pagesize, size;
1563 static nat fixed = 0;
1564
1565 pagesize = getpagesize();
1566 size = ROUND_UP(bytes, pagesize);
1567
1568 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1569 mmap_again:
1570
1571 if (mmap_32bit_base != 0) {
1572 map_addr = mmap_32bit_base;
1573 }
1574 #endif
1575
1576 result = mmap(map_addr, size, PROT_EXEC|PROT_READ|PROT_WRITE,
1577 MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, 0);
1578
1579 if (result == MAP_FAILED) {
1580 sysErrorBelch("mmap %lu bytes at %p",(lnat)size,map_addr);
1581 errorBelch("Try specifying an address with +RTS -xm<addr> -RTS");
1582 stg_exit(EXIT_FAILURE);
1583 }
1584
1585 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1586 if (mmap_32bit_base != 0) {
1587 if (result == map_addr) {
1588 mmap_32bit_base = (StgWord8*)map_addr + size;
1589 } else {
1590 if ((W_)result > 0x80000000) {
1591 // oops, we were given memory over 2Gb
1592 #if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)
1593 // Some platforms require MAP_FIXED. This is normally
1594 // a bad idea, because MAP_FIXED will overwrite
1595 // existing mappings.
1596 munmap(result,size);
1597 fixed = MAP_FIXED;
1598 goto mmap_again;
1599 #else
1600 barf("loadObj: failed to mmap() memory below 2Gb; asked for %lu bytes at %p. Try specifying an address with +RTS -xm<addr> -RTS", size, map_addr, result);
1601 #endif
1602 } else {
1603 // hmm, we were given memory somewhere else, but it's
1604 // still under 2Gb so we can use it. Next time, ask
1605 // for memory right after the place we just got some
1606 mmap_32bit_base = (StgWord8*)result + size;
1607 }
1608 }
1609 } else {
1610 if ((W_)result > 0x80000000) {
1611 // oops, we were given memory over 2Gb
1612 // ... try allocating memory somewhere else?;
1613 debugTrace(DEBUG_linker,"MAP_32BIT didn't work; gave us %lu bytes at 0x%p", bytes, result);
1614 munmap(result, size);
1615
1616 // Set a base address and try again... (guess: 1Gb)
1617 mmap_32bit_base = (void*)0x40000000;
1618 goto mmap_again;
1619 }
1620 }
1621 #endif
1622
1623 return result;
1624 }
1625 #endif // USE_MMAP
1626
1627 static ObjectCode*
1628 mkOc( char *path, char *image, int imageSize,
1629 char *archiveMemberName
1630 #ifndef USE_MMAP
1631 #ifdef darwin_HOST_OS
1632 , int misalignment
1633 #endif
1634 #endif
1635 ) {
1636 ObjectCode* oc;
1637
1638 oc = stgMallocBytes(sizeof(ObjectCode), "loadArchive(oc)");
1639
1640 # if defined(OBJFORMAT_ELF)
1641 oc->formatName = "ELF";
1642 # elif defined(OBJFORMAT_PEi386)
1643 oc->formatName = "PEi386";
1644 # elif defined(OBJFORMAT_MACHO)
1645 oc->formatName = "Mach-O";
1646 # else
1647 stgFree(oc);
1648 barf("loadObj: not implemented on this platform");
1649 # endif
1650
1651 oc->image = image;
1652 /* sigh, strdup() isn't a POSIX function, so do it the long way */
1653 oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
1654 strcpy(oc->fileName, path);
1655
1656 if (archiveMemberName) {
1657 oc->archiveMemberName = stgMallocBytes( strlen(archiveMemberName)+1, "loadObj" );
1658 strcpy(oc->archiveMemberName, archiveMemberName);
1659 }
1660 else {
1661 oc->archiveMemberName = NULL;
1662 }
1663
1664 oc->fileSize = imageSize;
1665 oc->symbols = NULL;
1666 oc->sections = NULL;
1667 oc->proddables = NULL;
1668
1669 #ifndef USE_MMAP
1670 #ifdef darwin_HOST_OS
1671 oc->misalignment = misalignment;
1672 #endif
1673 #endif
1674
1675 /* chain it onto the list of objects */
1676 oc->next = objects;
1677 objects = oc;
1678
1679 return oc;
1680 }
1681
1682 HsInt
1683 loadArchive( char *path )
1684 {
1685 ObjectCode* oc;
1686 char *image;
1687 int memberSize;
1688 FILE *f;
1689 int n;
1690 size_t thisFileNameSize;
1691 char *fileName;
1692 size_t fileNameSize;
1693 int isObject, isGnuIndex;
1694 char tmp[12];
1695 char *gnuFileIndex;
1696 int gnuFileIndexSize;
1697 #if !defined(USE_MMAP) && defined(darwin_HOST_OS)
1698 int misalignment;
1699 #endif
1700
1701 IF_DEBUG(linker, debugBelch("loadArchive: Loading archive `%s'\n", path));
1702
1703 gnuFileIndex = NULL;
1704 gnuFileIndexSize = 0;
1705
1706 fileNameSize = 32;
1707 fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)");
1708
1709 f = fopen(path, "rb");
1710 if (!f)
1711 barf("loadObj: can't read `%s'", path);
1712
1713 n = fread ( tmp, 1, 8, f );
1714 if (strncmp(tmp, "!<arch>\n", 8) != 0)
1715 barf("loadArchive: Not an archive: `%s'", path);
1716
1717 while(1) {
1718 n = fread ( fileName, 1, 16, f );
1719 if (n != 16) {
1720 if (feof(f)) {
1721 break;
1722 }
1723 else {
1724 barf("loadArchive: Failed reading file name from `%s'", path);
1725 }
1726 }
1727 n = fread ( tmp, 1, 12, f );
1728 if (n != 12)
1729 barf("loadArchive: Failed reading mod time from `%s'", path);
1730 n = fread ( tmp, 1, 6, f );
1731 if (n != 6)
1732 barf("loadArchive: Failed reading owner from `%s'", path);
1733 n = fread ( tmp, 1, 6, f );
1734 if (n != 6)
1735 barf("loadArchive: Failed reading group from `%s'", path);
1736 n = fread ( tmp, 1, 8, f );
1737 if (n != 8)
1738 barf("loadArchive: Failed reading mode from `%s'", path);
1739 n = fread ( tmp, 1, 10, f );
1740 if (n != 10)
1741 barf("loadArchive: Failed reading size from `%s'", path);
1742 tmp[10] = '\0';
1743 for (n = 0; isdigit(tmp[n]); n++);
1744 tmp[n] = '\0';
1745 memberSize = atoi(tmp);
1746 n = fread ( tmp, 1, 2, f );
1747 if (strncmp(tmp, "\x60\x0A", 2) != 0)
1748 barf("loadArchive: Failed reading magic from `%s' at %ld. Got %c%c",
1749 path, ftell(f), tmp[0], tmp[1]);
1750
1751 isGnuIndex = 0;
1752 /* Check for BSD-variant large filenames */
1753 if (0 == strncmp(fileName, "#1/", 3)) {
1754 fileName[16] = '\0';
1755 if (isdigit(fileName[3])) {
1756 for (n = 4; isdigit(fileName[n]); n++);
1757 fileName[n] = '\0';
1758 thisFileNameSize = atoi(fileName + 3);
1759 memberSize -= thisFileNameSize;
1760 if (thisFileNameSize >= fileNameSize) {
1761 /* Double it to avoid potentially continually
1762 increasing it by 1 */
1763 fileNameSize = thisFileNameSize * 2;
1764 fileName = stgReallocBytes(fileName, fileNameSize, "loadArchive(fileName)");
1765 }
1766 n = fread ( fileName, 1, thisFileNameSize, f );
1767 if (n != (int)thisFileNameSize) {
1768 barf("loadArchive: Failed reading filename from `%s'",
1769 path);
1770 }
1771 fileName[thisFileNameSize] = 0;
1772 }
1773 else {
1774 barf("loadArchive: BSD-variant filename size not found while reading filename from `%s'", path);
1775 }
1776 }
1777 /* Check for GNU file index file */
1778 else if (0 == strncmp(fileName, "//", 2)) {
1779 fileName[0] = '\0';
1780 thisFileNameSize = 0;
1781 isGnuIndex = 1;
1782 }
1783 /* Check for a file in the GNU file index */
1784 else if (fileName[0] == '/') {
1785 if (isdigit(fileName[1])) {
1786 int i;
1787
1788 for (n = 2; isdigit(fileName[n]); n++);
1789 fileName[n] = '\0';
1790 n = atoi(fileName + 1);
1791
1792 if (gnuFileIndex == NULL) {
1793 barf("loadArchive: GNU-variant filename without an index while reading from `%s'", path);
1794 }
1795 if (n < 0 || n > gnuFileIndexSize) {
1796 barf("loadArchive: GNU-variant filename offset %d out of range [0..%d] while reading filename from `%s'", n, gnuFileIndexSize, path);
1797 }
1798 if (n != 0 && gnuFileIndex[n - 1] != '\n') {
1799 barf("loadArchive: GNU-variant filename offset %d invalid (range [0..%d]) while reading filename from `%s'", n, gnuFileIndexSize, path);
1800 }
1801 for (i = n; gnuFileIndex[i] != '/'; i++);
1802 thisFileNameSize = i - n;
1803 if (thisFileNameSize >= fileNameSize) {
1804 /* Double it to avoid potentially continually
1805 increasing it by 1 */
1806 fileNameSize = thisFileNameSize * 2;
1807 fileName = stgReallocBytes(fileName, fileNameSize, "loadArchive(fileName)");
1808 }
1809 memcpy(fileName, gnuFileIndex + n, thisFileNameSize);
1810 fileName[thisFileNameSize] = '\0';
1811 }
1812 else if (fileName[1] == ' ') {
1813 fileName[0] = '\0';
1814 thisFileNameSize = 0;
1815 }
1816 else {
1817 barf("loadArchive: GNU-variant filename offset not found while reading filename from `%s'", path);
1818 }
1819 }
1820 /* Finally, the case where the filename field actually contains
1821 the filename */
1822 else {
1823 /* GNU ar terminates filenames with a '/', this allowing
1824 spaces in filenames. So first look to see if there is a
1825 terminating '/'. */
1826 for (thisFileNameSize = 0;
1827 thisFileNameSize < 16;
1828 thisFileNameSize++) {
1829 if (fileName[thisFileNameSize] == '/') {
1830 fileName[thisFileNameSize] = '\0';
1831 break;
1832 }
1833 }
1834 /* If we didn't find a '/', then a space teminates the
1835 filename. Note that if we don't find one, then
1836 thisFileNameSize ends up as 16, and we already have the
1837 '\0' at the end. */
1838 if (thisFileNameSize == 16) {
1839 for (thisFileNameSize = 0;
1840 thisFileNameSize < 16;
1841 thisFileNameSize++) {
1842 if (fileName[thisFileNameSize] == ' ') {
1843 fileName[thisFileNameSize] = '\0';
1844 break;
1845 }
1846 }
1847 }
1848 }
1849
1850 IF_DEBUG(linker,
1851 debugBelch("loadArchive: Found member file `%s'\n", fileName));
1852
1853 isObject = thisFileNameSize >= 2
1854 && fileName[thisFileNameSize - 2] == '.'
1855 && fileName[thisFileNameSize - 1] == 'o';
1856
1857 if (isObject) {
1858 char *archiveMemberName;
1859
1860 IF_DEBUG(linker, debugBelch("loadArchive: Member is an object file...loading...\n"));
1861
1862 /* We can't mmap from the archive directly, as object
1863 files need to be 8-byte aligned but files in .ar
1864 archives are 2-byte aligned. When possible we use mmap
1865 to get some anonymous memory, as on 64-bit platforms if
1866 we use malloc then we can be given memory above 2^32.
1867 In the mmap case we're probably wasting lots of space;
1868 we could do better. */
1869 #if defined(USE_MMAP)
1870 image = mmapForLinker(memberSize, MAP_ANONYMOUS, -1);
1871 #elif defined(darwin_HOST_OS)
1872 /* See loadObj() */
1873 misalignment = machoGetMisalignment(f);
1874 image = stgMallocBytes(memberSize + misalignment, "loadArchive(image)");
1875 image += misalignment;
1876 #else
1877 image = stgMallocBytes(memberSize, "loadArchive(image)");
1878 #endif
1879 n = fread ( image, 1, memberSize, f );
1880 if (n != memberSize) {
1881 barf("loadArchive: error whilst reading `%s'", path);
1882 }
1883
1884 archiveMemberName = stgMallocBytes(strlen(path) + thisFileNameSize + 3,
1885 "loadArchive(file)");
1886 sprintf(archiveMemberName, "%s(%.*s)",
1887 path, (int)thisFileNameSize, fileName);
1888
1889 oc = mkOc(path, image, memberSize, archiveMemberName
1890 #ifndef USE_MMAP
1891 #ifdef darwin_HOST_OS
1892 , misalignment
1893 #endif
1894 #endif
1895 );
1896
1897 stgFree(archiveMemberName);
1898
1899 if (0 == loadOc(oc)) {
1900 stgFree(fileName);
1901 return 0;
1902 }
1903 }
1904 else if (isGnuIndex) {
1905 if (gnuFileIndex != NULL) {
1906 barf("loadArchive: GNU-variant index found, but already have an index, while reading filename from `%s'", path);
1907 }
1908 IF_DEBUG(linker, debugBelch("loadArchive: Found GNU-variant file index\n"));
1909 #ifdef USE_MMAP
1910 gnuFileIndex = mmapForLinker(memberSize + 1, MAP_ANONYMOUS, -1);
1911 #else
1912 gnuFileIndex = stgMallocBytes(memberSize + 1, "loadArchive(image)");
1913 #endif
1914 n = fread ( gnuFileIndex, 1, memberSize, f );
1915 if (n != memberSize) {
1916 barf("loadArchive: error whilst reading `%s'", path);
1917 }
1918 gnuFileIndex[memberSize] = '/';
1919 gnuFileIndexSize = memberSize;
1920 }
1921 else {
1922 n = fseek(f, memberSize, SEEK_CUR);
1923 if (n != 0)
1924 barf("loadArchive: error whilst seeking by %d in `%s'",
1925 memberSize, path);
1926 }
1927 /* .ar files are 2-byte aligned */
1928 if (memberSize % 2) {
1929 n = fread ( tmp, 1, 1, f );
1930 if (n != 1) {
1931 if (feof(f)) {
1932 break;
1933 }
1934 else {
1935 barf("loadArchive: Failed reading padding from `%s'", path);
1936 }
1937 }
1938 }
1939 }
1940
1941 fclose(f);
1942
1943 stgFree(fileName);
1944 if (gnuFileIndex != NULL) {
1945 #ifdef USE_MMAP
1946 munmap(gnuFileIndex, gnuFileIndexSize + 1);
1947 #else
1948 stgFree(gnuFileIndex);
1949 #endif
1950 }
1951
1952 return 1;
1953 }
1954
1955 /* -----------------------------------------------------------------------------
1956 * Load an obj (populate the global symbol table, but don't resolve yet)
1957 *
1958 * Returns: 1 if ok, 0 on error.
1959 */
1960 HsInt
1961 loadObj( char *path )
1962 {
1963 ObjectCode* oc;
1964 char *image;
1965 int fileSize;
1966 struct stat st;
1967 int r;
1968 #ifdef USE_MMAP
1969 int fd;
1970 #else
1971 FILE *f;
1972 # if defined(darwin_HOST_OS)
1973 int misalignment;
1974 # endif
1975 #endif
1976 IF_DEBUG(linker, debugBelch("loadObj %s\n", path));
1977
1978 initLinker();
1979
1980 /* debugBelch("loadObj %s\n", path ); */
1981
1982 /* Check that we haven't already loaded this object.
1983 Ignore requests to load multiple times */
1984 {
1985 ObjectCode *o;
1986 int is_dup = 0;
1987 for (o = objects; o; o = o->next) {
1988 if (0 == strcmp(o->fileName, path)) {
1989 is_dup = 1;
1990 break; /* don't need to search further */
1991 }
1992 }
1993 if (is_dup) {
1994 IF_DEBUG(linker, debugBelch(
1995 "GHCi runtime linker: warning: looks like you're trying to load the\n"
1996 "same object file twice:\n"
1997 " %s\n"
1998 "GHCi will ignore this, but be warned.\n"
1999 , path));
2000 return 1; /* success */
2001 }
2002 }
2003
2004 r = stat(path, &st);
2005 if (r == -1) {
2006 IF_DEBUG(linker, debugBelch("File doesn't exist\n"));
2007 return 0;
2008 }
2009
2010 fileSize = st.st_size;
2011
2012 #ifdef USE_MMAP
2013 /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
2014
2015 #if defined(openbsd_HOST_OS)
2016 fd = open(path, O_RDONLY, S_IRUSR);
2017 #else
2018 fd = open(path, O_RDONLY);
2019 #endif
2020 if (fd == -1)
2021 barf("loadObj: can't open `%s'", path);
2022
2023 image = mmapForLinker(fileSize, 0, fd);
2024
2025 close(fd);
2026
2027 #else /* !USE_MMAP */
2028 /* load the image into memory */
2029 f = fopen(path, "rb");
2030 if (!f)
2031 barf("loadObj: can't read `%s'", path);
2032
2033 # if defined(mingw32_HOST_OS)
2034 // TODO: We would like to use allocateExec here, but allocateExec
2035 // cannot currently allocate blocks large enough.
2036 image = VirtualAlloc(NULL, fileSize, MEM_RESERVE | MEM_COMMIT,
2037 PAGE_EXECUTE_READWRITE);
2038 # elif defined(darwin_HOST_OS)
2039 // In a Mach-O .o file, all sections can and will be misaligned
2040 // if the total size of the headers is not a multiple of the
2041 // desired alignment. This is fine for .o files that only serve
2042 // as input for the static linker, but it's not fine for us,
2043 // as SSE (used by gcc for floating point) and Altivec require
2044 // 16-byte alignment.
2045 // We calculate the correct alignment from the header before
2046 // reading the file, and then we misalign image on purpose so
2047 // that the actual sections end up aligned again.
2048 misalignment = machoGetMisalignment(f);
2049 image = stgMallocBytes(fileSize + misalignment, "loadObj(image)");
2050 image += misalignment;
2051 # else
2052 image = stgMallocBytes(fileSize, "loadObj(image)");
2053 # endif
2054
2055 {
2056 int n;
2057 n = fread ( image, 1, fileSize, f );
2058 if (n != fileSize)
2059 barf("loadObj: error whilst reading `%s'", path);
2060 }
2061 fclose(f);
2062 #endif /* USE_MMAP */
2063
2064 oc = mkOc(path, image, fileSize, NULL
2065 #ifndef USE_MMAP
2066 #ifdef darwin_HOST_OS
2067 , misalignment
2068 #endif
2069 #endif
2070 );
2071
2072 return loadOc(oc);
2073 }
2074
2075 static HsInt
2076 loadOc( ObjectCode* oc ) {
2077 int r;
2078
2079 IF_DEBUG(linker, debugBelch("loadOc\n"));
2080
2081 # if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
2082 r = ocAllocateSymbolExtras_MachO ( oc );
2083 if (!r) {
2084 IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO failed\n"));
2085 return r;
2086 }
2087 # elif defined(OBJFORMAT_ELF) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
2088 r = ocAllocateSymbolExtras_ELF ( oc );
2089 if (!r) {
2090 IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_ELF failed\n"));
2091 return r;
2092 }
2093 #endif
2094
2095 /* verify the in-memory image */
2096 # if defined(OBJFORMAT_ELF)
2097 r = ocVerifyImage_ELF ( oc );
2098 # elif defined(OBJFORMAT_PEi386)
2099 r = ocVerifyImage_PEi386 ( oc );
2100 # elif defined(OBJFORMAT_MACHO)
2101 r = ocVerifyImage_MachO ( oc );
2102 # else
2103 barf("loadObj: no verify method");
2104 # endif
2105 if (!r) {
2106 IF_DEBUG(linker, debugBelch("ocVerifyImage_* failed\n"));
2107 return r;
2108 }
2109
2110 /* build the symbol list for this image */
2111 # if defined(OBJFORMAT_ELF)
2112 r = ocGetNames_ELF ( oc );
2113 # elif defined(OBJFORMAT_PEi386)
2114 r = ocGetNames_PEi386 ( oc );
2115 # elif defined(OBJFORMAT_MACHO)
2116 r = ocGetNames_MachO ( oc );
2117 # else
2118 barf("loadObj: no getNames method");
2119 # endif
2120 if (!r) {
2121 IF_DEBUG(linker, debugBelch("ocGetNames_* failed\n"));
2122 return r;
2123 }
2124
2125 /* loaded, but not resolved yet */
2126 oc->status = OBJECT_LOADED;
2127 IF_DEBUG(linker, debugBelch("loadObj done.\n"));
2128
2129 return 1;
2130 }
2131
2132 /* -----------------------------------------------------------------------------
2133 * resolve all the currently unlinked objects in memory
2134 *
2135 * Returns: 1 if ok, 0 on error.
2136 */
2137 HsInt
2138 resolveObjs( void )
2139 {
2140 ObjectCode *oc;
2141 int r;
2142
2143 IF_DEBUG(linker, debugBelch("resolveObjs: start\n"));
2144 initLinker();
2145
2146 for (oc = objects; oc; oc = oc->next) {
2147 if (oc->status != OBJECT_RESOLVED) {
2148 # if defined(OBJFORMAT_ELF)
2149 r = ocResolve_ELF ( oc );
2150 # elif defined(OBJFORMAT_PEi386)
2151 r = ocResolve_PEi386 ( oc );
2152 # elif defined(OBJFORMAT_MACHO)
2153 r = ocResolve_MachO ( oc );
2154 # else
2155 barf("resolveObjs: not implemented on this platform");
2156 # endif
2157 if (!r) { return r; }
2158 oc->status = OBJECT_RESOLVED;
2159 }
2160 }
2161 IF_DEBUG(linker, debugBelch("resolveObjs: done\n"));
2162 return 1;
2163 }
2164
2165 /* -----------------------------------------------------------------------------
2166 * delete an object from the pool
2167 */
2168 HsInt
2169 unloadObj( char *path )
2170 {
2171 ObjectCode *oc, *prev;
2172 HsBool unloadedAnyObj = HS_BOOL_FALSE;
2173
2174 ASSERT(symhash != NULL);
2175 ASSERT(objects != NULL);
2176
2177 initLinker();
2178
2179 prev = NULL;
2180 for (oc = objects; oc; prev = oc, oc = oc->next) {
2181 if (!strcmp(oc->fileName,path)) {
2182
2183 /* Remove all the mappings for the symbols within this
2184 * object..
2185 */
2186 {
2187 int i;
2188 for (i = 0; i < oc->n_symbols; i++) {
2189 if (oc->symbols[i] != NULL) {
2190 removeStrHashTable(symhash, oc->symbols[i], NULL);
2191 }
2192 }
2193 }
2194
2195 if (prev == NULL) {
2196 objects = oc->next;
2197 } else {
2198 prev->next = oc->next;
2199 }
2200
2201 // We're going to leave this in place, in case there are
2202 // any pointers from the heap into it:
2203 // #ifdef mingw32_HOST_OS
2204 // VirtualFree(oc->image);
2205 // #else
2206 // stgFree(oc->image);
2207 // #endif
2208 stgFree(oc->fileName);
2209 stgFree(oc->symbols);
2210 stgFree(oc->sections);
2211 stgFree(oc);
2212
2213 /* This could be a member of an archive so continue
2214 * unloading other members. */
2215 unloadedAnyObj = HS_BOOL_TRUE;
2216 }
2217 }
2218
2219 if (unloadedAnyObj) {
2220 return 1;
2221 }
2222 else {
2223 errorBelch("unloadObj: can't find `%s' to unload", path);
2224 return 0;
2225 }
2226 }
2227
2228 /* -----------------------------------------------------------------------------
2229 * Sanity checking. For each ObjectCode, maintain a list of address ranges
2230 * which may be prodded during relocation, and abort if we try and write
2231 * outside any of these.
2232 */
2233 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
2234 {
2235 ProddableBlock* pb
2236 = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
2237 IF_DEBUG(linker, debugBelch("addProddableBlock %p %p %d\n", oc, start, size));
2238 ASSERT(size > 0);
2239 pb->start = start;
2240 pb->size = size;
2241 pb->next = oc->proddables;
2242 oc->proddables = pb;
2243 }
2244
2245 static void checkProddableBlock ( ObjectCode* oc, void* addr )
2246 {
2247 ProddableBlock* pb;
2248 for (pb = oc->proddables; pb != NULL; pb = pb->next) {
2249 char* s = (char*)(pb->start);
2250 char* e = s + pb->size - 1;
2251 char* a = (char*)addr;
2252 /* Assumes that the biggest fixup involves a 4-byte write. This
2253 probably needs to be changed to 8 (ie, +7) on 64-bit
2254 plats. */
2255 if (a >= s && (a+3) <= e) return;
2256 }
2257 barf("checkProddableBlock: invalid fixup in runtime linker");
2258 }
2259
2260 /* -----------------------------------------------------------------------------
2261 * Section management.
2262 */
2263 static void addSection ( ObjectCode* oc, SectionKind kind,
2264 void* start, void* end )
2265 {
2266 Section* s = stgMallocBytes(sizeof(Section), "addSection");
2267 s->start = start;
2268 s->end = end;
2269 s->kind = kind;
2270 s->next = oc->sections;
2271 oc->sections = s;
2272 /*
2273 debugBelch("addSection: %p-%p (size %d), kind %d\n",
2274 start, ((char*)end)-1, end - start + 1, kind );
2275 */
2276 }
2277
2278
2279 /* --------------------------------------------------------------------------
2280 * Symbol Extras.
2281 * This is about allocating a small chunk of memory for every symbol in the
2282 * object file. We make sure that the SymboLExtras are always "in range" of
2283 * limited-range PC-relative instructions on various platforms by allocating
2284 * them right next to the object code itself.
2285 */
2286
2287 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
2288
2289 /*
2290 ocAllocateSymbolExtras
2291
2292 Allocate additional space at the end of the object file image to make room
2293 for jump islands (powerpc, x86_64) and GOT entries (x86_64).
2294
2295 PowerPC relative branch instructions have a 24 bit displacement field.
2296 As PPC code is always 4-byte-aligned, this yields a +-32MB range.
2297 If a particular imported symbol is outside this range, we have to redirect
2298 the jump to a short piece of new code that just loads the 32bit absolute
2299 address and jumps there.
2300 On x86_64, PC-relative jumps and PC-relative accesses to the GOT are limited
2301 to 32 bits (+-2GB).
2302
2303 This function just allocates space for one SymbolExtra for every
2304 undefined symbol in the object file. The code for the jump islands is
2305 filled in by makeSymbolExtra below.
2306 */
2307
2308 static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first )
2309 {
2310 #ifdef USE_MMAP
2311 int pagesize, n, m;
2312 #endif
2313 int aligned;
2314 #ifndef USE_MMAP
2315 int misalignment = 0;
2316 #ifdef darwin_HOST_OS
2317 misalignment = oc->misalignment;
2318 #endif
2319 #endif
2320
2321 if( count > 0 )
2322 {
2323 // round up to the nearest 4
2324 aligned = (oc->fileSize + 3) & ~3;
2325
2326 #ifdef USE_MMAP
2327 pagesize = getpagesize();
2328 n = ROUND_UP( oc->fileSize, pagesize );
2329 m = ROUND_UP( aligned + sizeof (SymbolExtra) * count, pagesize );
2330
2331 /* we try to use spare space at the end of the last page of the
2332 * image for the jump islands, but if there isn't enough space
2333 * then we have to map some (anonymously, remembering MAP_32BIT).
2334 */
2335 if( m > n ) // we need to allocate more pages
2336 {
2337 oc->symbol_extras = mmapForLinker(sizeof(SymbolExtra) * count,
2338 MAP_ANONYMOUS, -1);
2339 }
2340 else
2341 {
2342 oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
2343 }
2344 #else
2345 oc->image -= misalignment;
2346 oc->image = stgReallocBytes( oc->image,
2347 misalignment +
2348 aligned + sizeof (SymbolExtra) * count,
2349 "ocAllocateSymbolExtras" );
2350 oc->image += misalignment;
2351
2352 oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
2353 #endif /* USE_MMAP */
2354
2355 memset( oc->symbol_extras, 0, sizeof (SymbolExtra) * count );
2356 }
2357 else
2358 oc->symbol_extras = NULL;
2359
2360 oc->first_symbol_extra = first;
2361 oc->n_symbol_extras = count;
2362
2363 return 1;
2364 }
2365
2366 static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
2367 unsigned long symbolNumber,
2368 unsigned long target )
2369 {
2370 SymbolExtra *extra;
2371
2372 ASSERT( symbolNumber >= oc->first_symbol_extra
2373 && symbolNumber - oc->first_symbol_extra < oc->n_symbol_extras);
2374
2375 extra = &oc->symbol_extras[symbolNumber - oc->first_symbol_extra];
2376
2377 #ifdef powerpc_HOST_ARCH
2378 // lis r12, hi16(target)
2379 extra->jumpIsland.lis_r12 = 0x3d80;
2380 extra->jumpIsland.hi_addr = target >> 16;
2381
2382 // ori r12, r12, lo16(target)
2383 extra->jumpIsland.ori_r12_r12 = 0x618c;
2384 extra->jumpIsland.lo_addr = target & 0xffff;
2385
2386 // mtctr r12
2387 extra->jumpIsland.mtctr_r12 = 0x7d8903a6;
2388
2389 // bctr
2390 extra->jumpIsland.bctr = 0x4e800420;
2391 #endif
2392 #ifdef x86_64_HOST_ARCH
2393 // jmp *-14(%rip)
2394 static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
2395 extra->addr = target;
2396 memcpy(extra->jumpIsland, jmp, 6);
2397 #endif
2398
2399 return extra;
2400 }
2401
2402 #endif
2403
2404 /* --------------------------------------------------------------------------
2405 * PowerPC specifics (instruction cache flushing)
2406 * ------------------------------------------------------------------------*/
2407
2408 #ifdef powerpc_HOST_ARCH
2409 /*
2410 ocFlushInstructionCache
2411
2412 Flush the data & instruction caches.
2413 Because the PPC has split data/instruction caches, we have to
2414 do that whenever we modify code at runtime.
2415 */
2416 static void ocFlushInstructionCacheFrom(void* begin, size_t length)
2417 {
2418 size_t n = (length + 3) / 4;
2419 unsigned long* p = begin;
2420
2421 while (n--)
2422 {
2423 __asm__ volatile ( "dcbf 0,%0\n\t"
2424 "sync\n\t"
2425 "icbi 0,%0"
2426 :
2427 : "r" (p)
2428 );
2429 p++;
2430 }
2431 __asm__ volatile ( "sync\n\t"
2432 "isync"
2433 );
2434 }
2435 static void ocFlushInstructionCache( ObjectCode *oc )
2436 {
2437 /* The main object code */
2438 ocFlushInstructionCacheFrom(oc->image + oc->misalignment, oc->fileSize);
2439
2440 /* Jump Islands */
2441 ocFlushInstructionCacheFrom(oc->symbol_extras, sizeof(SymbolExtra) * oc->n_symbol_extras);
2442 }
2443 #endif
2444
2445 /* --------------------------------------------------------------------------
2446 * PEi386 specifics (Win32 targets)
2447 * ------------------------------------------------------------------------*/
2448
2449 /* The information for this linker comes from
2450 Microsoft Portable Executable
2451 and Common Object File Format Specification
2452 revision 5.1 January 1998
2453 which SimonM says comes from the MS Developer Network CDs.
2454
2455 It can be found there (on older CDs), but can also be found
2456 online at:
2457
2458 http://www.microsoft.com/hwdev/hardware/PECOFF.asp
2459
2460 (this is Rev 6.0 from February 1999).
2461
2462 Things move, so if that fails, try searching for it via
2463
2464 http://www.google.com/search?q=PE+COFF+specification
2465
2466 The ultimate reference for the PE format is the Winnt.h
2467 header file that comes with the Platform SDKs; as always,
2468 implementations will drift wrt their documentation.
2469
2470 A good background article on the PE format is Matt Pietrek's
2471 March 1994 article in Microsoft System Journal (MSJ)
2472 (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
2473 Win32 Portable Executable File Format." The info in there
2474 has recently been updated in a two part article in
2475 MSDN magazine, issues Feb and March 2002,
2476 "Inside Windows: An In-Depth Look into the Win32 Portable
2477 Executable File Format"
2478
2479 John Levine's book "Linkers and Loaders" contains useful
2480 info on PE too.
2481 */
2482
2483
2484 #if defined(OBJFORMAT_PEi386)
2485
2486
2487
2488 typedef unsigned char UChar;
2489 typedef unsigned short UInt16;
2490 typedef unsigned int UInt32;
2491 typedef int Int32;
2492
2493
2494 typedef
2495 struct {
2496 UInt16 Machine;
2497 UInt16 NumberOfSections;
2498 UInt32 TimeDateStamp;
2499 UInt32 PointerToSymbolTable;
2500 UInt32 NumberOfSymbols;
2501 UInt16 SizeOfOptionalHeader;
2502 UInt16 Characteristics;
2503 }
2504 COFF_header;
2505
2506 #define sizeof_COFF_header 20
2507
2508
2509 typedef
2510 struct {
2511 UChar Name[8];
2512 UInt32 VirtualSize;
2513 UInt32 VirtualAddress;
2514 UInt32 SizeOfRawData;
2515 UInt32 PointerToRawData;
2516 UInt32 PointerToRelocations;
2517 UInt32 PointerToLinenumbers;
2518 UInt16 NumberOfRelocations;
2519 UInt16 NumberOfLineNumbers;
2520 UInt32 Characteristics;
2521 }
2522 COFF_section;
2523
2524 #define sizeof_COFF_section 40
2525
2526
2527 typedef
2528 struct {
2529 UChar Name[8];
2530 UInt32 Value;
2531 UInt16 SectionNumber;
2532 UInt16 Type;
2533 UChar StorageClass;
2534 UChar NumberOfAuxSymbols;
2535 }
2536 COFF_symbol;
2537
2538 #define sizeof_COFF_symbol 18
2539
2540
2541 typedef
2542 struct {
2543 UInt32 VirtualAddress;
2544 UInt32 SymbolTableIndex;
2545 UInt16 Type;
2546 }
2547 COFF_reloc;
2548
2549 #define sizeof_COFF_reloc 10
2550
2551
2552 /* From PE spec doc, section 3.3.2 */
2553 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
2554 windows.h -- for the same purpose, but I want to know what I'm
2555 getting, here. */
2556 #define MYIMAGE_FILE_RELOCS_STRIPPED 0x0001
2557 #define MYIMAGE_FILE_EXECUTABLE_IMAGE 0x0002
2558 #define MYIMAGE_FILE_DLL 0x2000
2559 #define MYIMAGE_FILE_SYSTEM 0x1000
2560 #define MYIMAGE_FILE_BYTES_REVERSED_HI 0x8000
2561 #define MYIMAGE_FILE_BYTES_REVERSED_LO 0x0080
2562 #define MYIMAGE_FILE_32BIT_MACHINE 0x0100
2563
2564 /* From PE spec doc, section 5.4.2 and 5.4.4 */
2565 #define MYIMAGE_SYM_CLASS_EXTERNAL 2
2566 #define MYIMAGE_SYM_CLASS_STATIC 3
2567 #define MYIMAGE_SYM_UNDEFINED 0
2568
2569 /* From PE spec doc, section 4.1 */
2570 #define MYIMAGE_SCN_CNT_CODE 0x00000020
2571 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
2572 #define MYIMAGE_SCN_LNK_NRELOC_OVFL 0x01000000
2573
2574 /* From PE spec doc, section 5.2.1 */
2575 #define MYIMAGE_REL_I386_DIR32 0x0006
2576 #define MYIMAGE_REL_I386_REL32 0x0014
2577
2578
2579 /* We use myindex to calculate array addresses, rather than
2580 simply doing the normal subscript thing. That's because
2581 some of the above structs have sizes which are not
2582 a whole number of words. GCC rounds their sizes up to a
2583 whole number of words, which means that the address calcs
2584 arising from using normal C indexing or pointer arithmetic
2585 are just plain wrong. Sigh.
2586 */
2587 static UChar *
2588 myindex ( int scale, void* base, int index )
2589 {
2590 return
2591 ((UChar*)base) + scale * index;
2592 }
2593
2594
2595 static void
2596 printName ( UChar* name, UChar* strtab )
2597 {
2598 if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2599 UInt32 strtab_offset = * (UInt32*)(name+4);
2600 debugBelch("%s", strtab + strtab_offset );
2601 } else {
2602 int i;
2603 for (i = 0; i < 8; i++) {
2604 if (name[i] == 0) break;
2605 debugBelch("%c", name[i] );
2606 }
2607 }
2608 }
2609
2610
2611 static void
2612 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
2613 {
2614 if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2615 UInt32 strtab_offset = * (UInt32*)(name+4);
2616 strncpy ( (char*)dst, (char*)strtab+strtab_offset, dstSize );
2617 dst[dstSize-1] = 0;
2618 } else {
2619 int i = 0;
2620 while (1) {
2621 if (i >= 8) break;
2622 if (name[i] == 0) break;
2623 dst[i] = name[i];
2624 i++;
2625 }
2626 dst[i] = 0;
2627 }
2628 }
2629
2630
2631 static UChar *
2632 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
2633 {
2634 UChar* newstr;
2635 /* If the string is longer than 8 bytes, look in the
2636 string table for it -- this will be correctly zero terminated.
2637 */
2638 if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2639 UInt32 strtab_offset = * (UInt32*)(name+4);
2640 return ((UChar*)strtab) + strtab_offset;
2641 }
2642 /* Otherwise, if shorter than 8 bytes, return the original,
2643 which by defn is correctly terminated.
2644 */
2645 if (name[7]==0) return name;
2646 /* The annoying case: 8 bytes. Copy into a temporary
2647 (XXX which is never freed ...)
2648 */
2649 newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
2650 ASSERT(newstr);
2651 strncpy((char*)newstr,(char*)name,8);
2652 newstr[8] = 0;
2653 return newstr;
2654 }
2655
2656 /* Getting the name of a section is mildly tricky, so we make a
2657 function for it. Sadly, in one case we have to copy the string
2658 (when it is exactly 8 bytes long there's no trailing '\0'), so for
2659 consistency we *always* copy the string; the caller must free it
2660 */
2661 static char *
2662 cstring_from_section_name (UChar* name, UChar* strtab)
2663 {
2664 char *newstr;
2665
2666 if (name[0]=='/') {
2667 int strtab_offset = strtol((char*)name+1,NULL,10);
2668 int len = strlen(((char*)strtab) + strtab_offset);
2669
2670 newstr = stgMallocBytes(len, "cstring_from_section_symbol_name");
2671 strcpy((char*)newstr, (char*)((UChar*)strtab) + strtab_offset);
2672 return newstr;
2673 }
2674 else
2675 {
2676 newstr = stgMallocBytes(9, "cstring_from_section_symbol_name");
2677 ASSERT(newstr);
2678 strncpy((char*)newstr,(char*)name,8);
2679 newstr[8] = 0;
2680 return newstr;
2681 }
2682 }
2683
2684 /* Just compares the short names (first 8 chars) */
2685 static COFF_section *
2686 findPEi386SectionCalled ( ObjectCode* oc, UChar* name )
2687 {
2688 int i;
2689 COFF_header* hdr
2690 = (COFF_header*)(oc->image);
2691 COFF_section* sectab
2692 = (COFF_section*) (
2693 ((UChar*)(oc->image))
2694 + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2695 );
2696 for (i = 0; i < hdr->NumberOfSections; i++) {
2697 UChar* n1;
2698 UChar* n2;
2699 COFF_section* section_i
2700 = (COFF_section*)
2701 myindex ( sizeof_COFF_section, sectab, i );
2702 n1 = (UChar*) &(section_i->Name);
2703 n2 = name;
2704 if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
2705 n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
2706 n1[6]==n2[6] && n1[7]==n2[7])
2707 return section_i;
2708 }
2709
2710 return NULL;
2711 }
2712
2713
2714 static void
2715 zapTrailingAtSign ( UChar* sym )
2716 {
2717 # define my_isdigit(c) ((c) >= '0' && (c) <= '9')
2718 int i, j;
2719 if (sym[0] == 0) return;
2720 i = 0;
2721 while (sym[i] != 0) i++;
2722 i--;
2723 j = i;
2724 while (j > 0 && my_isdigit(sym[j])) j--;
2725 if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
2726 # undef my_isdigit
2727 }
2728
2729 static void *
2730 lookupSymbolInDLLs ( UChar *lbl )
2731 {
2732 OpenedDLL* o_dll;
2733 void *sym;
2734
2735 for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
2736 /* debugBelch("look in %s for %s\n", o_dll->name, lbl); */
2737
2738 if (lbl[0] == '_') {
2739 /* HACK: if the name has an initial underscore, try stripping
2740 it off & look that up first. I've yet to verify whether there's
2741 a Rule that governs whether an initial '_' *should always* be
2742 stripped off when mapping from import lib name to the DLL name.
2743 */
2744 sym = GetProcAddress(o_dll->instance, (char*)(lbl+1));
2745 if (sym != NULL) {
2746 /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
2747 return sym;
2748 }
2749 }
2750 sym = GetProcAddress(o_dll->instance, (char*)lbl);
2751 if (sym != NULL) {
2752 /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
2753 return sym;
2754 }
2755 }
2756 return NULL;
2757 }
2758
2759
2760 static int
2761 ocVerifyImage_PEi386 ( ObjectCode* oc )
2762 {
2763 int i;
2764 UInt32 j, noRelocs;
2765 COFF_header* hdr;
2766 COFF_section* sectab;
2767 COFF_symbol* symtab;
2768 UChar* strtab;
2769 /* debugBelch("\nLOADING %s\n", oc->fileName); */
2770 hdr = (COFF_header*)(oc->image);
2771 sectab = (COFF_section*) (
2772 ((UChar*)(oc->image))
2773 + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2774 );
2775 symtab = (COFF_symbol*) (
2776 ((UChar*)(oc->image))
2777 + hdr->PointerToSymbolTable
2778 );
2779 strtab = ((UChar*)symtab)
2780 + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2781
2782 if (hdr->Machine != 0x14c) {
2783 errorBelch("%s: Not x86 PEi386", oc->fileName);
2784 return 0;
2785 }
2786 if (hdr->SizeOfOptionalHeader != 0) {
2787 errorBelch("%s: PEi386 with nonempty optional header", oc->fileName);
2788 return 0;
2789 }
2790 if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
2791 (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
2792 (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
2793 (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
2794 errorBelch("%s: Not a PEi386 object file", oc->fileName);
2795 return 0;
2796 }
2797 if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
2798 /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
2799 errorBelch("%s: Invalid PEi386 word size or endiannness: %d",
2800 oc->fileName,
2801 (int)(hdr->Characteristics));
2802 return 0;
2803 }
2804 /* If the string table size is way crazy, this might indicate that
2805 there are more than 64k relocations, despite claims to the
2806 contrary. Hence this test. */
2807 /* debugBelch("strtab size %d\n", * (UInt32*)strtab); */
2808 #if 0
2809 if ( (*(UInt32*)strtab) > 600000 ) {
2810 /* Note that 600k has no special significance other than being
2811 big enough to handle the almost-2MB-sized lumps that
2812 constitute HSwin32*.o. */
2813 debugBelch("PEi386 object has suspiciously large string table; > 64k relocs?");
2814 return 0;
2815 }
2816 #endif
2817
2818 /* No further verification after this point; only debug printing. */
2819 i = 0;
2820 IF_DEBUG(linker, i=1);
2821 if (i == 0) return 1;
2822
2823 debugBelch( "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
2824 debugBelch( "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
2825 debugBelch( "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
2826
2827 debugBelch("\n" );
2828 debugBelch( "Machine: 0x%x\n", (UInt32)(hdr->Machine) );
2829 debugBelch( "# sections: %d\n", (UInt32)(hdr->NumberOfSections) );
2830 debugBelch( "time/date: 0x%x\n", (UInt32)(hdr->TimeDateStamp) );
2831 debugBelch( "symtab offset: %d\n", (UInt32)(hdr->PointerToSymbolTable) );
2832 debugBelch( "# symbols: %d\n", (UInt32)(hdr->NumberOfSymbols) );
2833 debugBelch( "sz of opt hdr: %d\n", (UInt32)(hdr->SizeOfOptionalHeader) );
2834 debugBelch( "characteristics: 0x%x\n", (UInt32)(hdr->Characteristics) );
2835
2836 /* Print the section table. */
2837 debugBelch("\n" );
2838 for (i = 0; i < hdr->NumberOfSections; i++) {
2839 COFF_reloc* reltab;
2840 COFF_section* sectab_i
2841 = (COFF_section*)
2842 myindex ( sizeof_COFF_section, sectab, i );
2843 debugBelch(
2844 "\n"
2845 "section %d\n"
2846 " name `",
2847 i
2848 );
2849 printName ( sectab_i->Name, strtab );
2850 debugBelch(
2851 "'\n"
2852 " vsize %d\n"
2853 " vaddr %d\n"
2854 " data sz %d\n"
2855 " data off %d\n"
2856 " num rel %d\n"
2857 " off rel %d\n"
2858 " ptr raw 0x%x\n",
2859 sectab_i->VirtualSize,
2860 sectab_i->VirtualAddress,
2861 sectab_i->SizeOfRawData,
2862 sectab_i->PointerToRawData,
2863 sectab_i->NumberOfRelocations,
2864 sectab_i->PointerToRelocations,
2865 sectab_i->PointerToRawData
2866 );
2867 reltab = (COFF_reloc*) (
2868 ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2869 );
2870
2871 if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2872 /* If the relocation field (a short) has overflowed, the
2873 * real count can be found in the first reloc entry.
2874 *
2875 * See Section 4.1 (last para) of the PE spec (rev6.0).
2876 */
2877 COFF_reloc* rel = (COFF_reloc*)
2878 myindex ( sizeof_COFF_reloc, reltab, 0 );
2879 noRelocs = rel->VirtualAddress;
2880 j = 1;
2881 } else {
2882 noRelocs = sectab_i->NumberOfRelocations;
2883 j = 0;
2884 }
2885
2886 for (; j < noRelocs; j++) {
2887 COFF_symbol* sym;
2888 COFF_reloc* rel = (COFF_reloc*)
2889 myindex ( sizeof_COFF_reloc, reltab, j );
2890 debugBelch(
2891 " type 0x%-4x vaddr 0x%-8x name `",
2892 (UInt32)rel->Type,
2893 rel->VirtualAddress );
2894 sym = (COFF_symbol*)
2895 myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
2896 /* Hmm..mysterious looking offset - what's it for? SOF */
2897 printName ( sym->Name, strtab -10 );
2898 debugBelch("'\n" );
2899 }
2900
2901 debugBelch("\n" );
2902 }
2903 debugBelch("\n" );
2904 debugBelch("string table has size 0x%x\n", * (UInt32*)strtab );
2905 debugBelch("---START of string table---\n");
2906 for (i = 4; i < *(Int32*)strtab; i++) {
2907 if (strtab[i] == 0)
2908 debugBelch("\n"); else
2909 debugBelch("%c", strtab[i] );
2910 }
2911 debugBelch("--- END of string table---\n");
2912
2913 debugBelch("\n" );
2914 i = 0;
2915 while (1) {
2916 COFF_symbol* symtab_i;
2917 if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2918 symtab_i = (COFF_symbol*)
2919 myindex ( sizeof_COFF_symbol, symtab, i );
2920 debugBelch(
2921 "symbol %d\n"
2922 " name `",
2923 i
2924 );
2925 printName ( symtab_i->Name, strtab );
2926 debugBelch(
2927 "'\n"
2928 " value 0x%x\n"
2929 " 1+sec# %d\n"
2930 " type 0x%x\n"
2931 " sclass 0x%x\n"
2932 " nAux %d\n",
2933 symtab_i->Value,
2934 (Int32)(symtab_i->SectionNumber),
2935 (UInt32)symtab_i->Type,
2936 (UInt32)symtab_i->StorageClass,
2937 (UInt32)symtab_i->NumberOfAuxSymbols
2938 );
2939 i += symtab_i->NumberOfAuxSymbols;
2940 i++;
2941 }
2942
2943 debugBelch("\n" );
2944 return 1;
2945 }
2946
2947
2948 static int
2949 ocGetNames_PEi386 ( ObjectCode* oc )
2950 {
2951 COFF_header* hdr;
2952 COFF_section* sectab;
2953 COFF_symbol* symtab;
2954 UChar* strtab;
2955
2956 UChar* sname;
2957 void* addr;
2958 int i;
2959
2960 hdr = (COFF_header*)(oc->image);
2961 sectab = (COFF_section*) (
2962 ((UChar*)(oc->image))
2963 + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2964 );
2965 symtab = (COFF_symbol*) (
2966 ((UChar*)(oc->image))
2967 + hdr->PointerToSymbolTable
2968 );
2969 strtab = ((UChar*)(oc->image))
2970 + hdr->PointerToSymbolTable
2971 + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2972
2973 /* Allocate space for any (local, anonymous) .bss sections. */
2974
2975 for (i = 0; i < hdr->NumberOfSections; i++) {
2976 UInt32 bss_sz;
2977 UChar* zspace;
2978 COFF_section* sectab_i
2979 = (COFF_section*)
2980 myindex ( sizeof_COFF_section, sectab, i );
2981
2982 char *secname = cstring_from_section_name(sectab_i->Name, strtab);
2983
2984 if (0 != strcmp(secname, ".bss")) {
2985 stgFree(secname);
2986 continue;
2987 }
2988
2989 stgFree(secname);
2990
2991 /* sof 10/05: the PE spec text isn't too clear regarding what
2992 * the SizeOfRawData field is supposed to hold for object
2993 * file sections containing just uninitialized data -- for executables,
2994 * it is supposed to be zero; unclear what it's supposed to be
2995 * for object files. However, VirtualSize is guaranteed to be
2996 * zero for object files, which definitely suggests that SizeOfRawData
2997 * will be non-zero (where else would the size of this .bss section be
2998 * stored?) Looking at the COFF_section info for incoming object files,
2999 * this certainly appears to be the case.
3000 *
3001 * => I suspect we've been incorrectly handling .bss sections in (relocatable)
3002 * object files up until now. This turned out to bite us with ghc-6.4.1's use
3003 * of gcc-3.4.x, which has started to emit initially-zeroed-out local 'static'
3004 * variable decls into to the .bss section. (The specific function in Q which
3005 * triggered this is libraries/base/cbits/dirUtils.c:__hscore_getFolderPath())
3006 */
3007 if (sectab_i->VirtualSize == 0 && sectab_i->SizeOfRawData == 0) continue;
3008 /* This is a non-empty .bss section. Allocate zeroed space for
3009 it, and set its PointerToRawData field such that oc->image +
3010 PointerToRawData == addr_of_zeroed_space. */
3011 bss_sz = sectab_i->VirtualSize;
3012 if ( bss_sz < sectab_i->SizeOfRawData) { bss_sz = sectab_i->SizeOfRawData; }
3013 zspace = stgCallocBytes(1, bss_sz, "ocGetNames_PEi386(anonymous bss)");
3014 sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
3015 addProddableBlock(oc, zspace, bss_sz);
3016 /* debugBelch("BSS anon section at 0x%x\n", zspace); */
3017 }
3018
3019 /* Copy section information into the ObjectCode. */
3020
3021 for (i = 0; i < hdr->NumberOfSections; i++) {
3022 UChar* start;
3023 UChar* end;
3024 UInt32 sz;
3025
3026 SectionKind kind
3027 = SECTIONKIND_OTHER;
3028 COFF_section* sectab_i
3029 = (COFF_section*)
3030 myindex ( sizeof_COFF_section, sectab, i );
3031
3032 char *secname = cstring_from_section_name(sectab_i->Name, strtab);
3033
3034 IF_DEBUG(linker, debugBelch("section name = %s\n", secname ));
3035
3036 # if 0
3037 /* I'm sure this is the Right Way to do it. However, the
3038 alternative of testing the sectab_i->Name field seems to
3039 work ok with Cygwin.
3040 */
3041 if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
3042 sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
3043 kind = SECTIONKIND_CODE_OR_RODATA;
3044 # endif
3045
3046 if (0==strcmp(".text",(char*)secname) ||
3047 0==strcmp(".rdata",(char*)secname)||
3048 0==strcmp(".rodata",(char*)secname))
3049 kind = SECTIONKIND_CODE_OR_RODATA;
3050 if (0==strcmp(".data",(char*)secname) ||
3051 0==strcmp(".bss",(char*)secname))
3052 kind = SECTIONKIND_RWDATA;
3053
3054 ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
3055 sz = sectab_i->SizeOfRawData;
3056 if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
3057
3058 start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
3059 end = start + sz - 1;
3060
3061 if (kind == SECTIONKIND_OTHER
3062 /* Ignore sections called which contain stabs debugging
3063 information. */
3064 && 0 != strcmp(".stab", (char*)secname)
3065 && 0 != strcmp(".stabstr", (char*)secname)
3066 /* ignore constructor section for now */
3067 && 0 != strcmp(".ctors", (char*)secname)
3068 /* ignore section generated from .ident */
3069 && 0!= strncmp(".debug", (char*)secname, 6)
3070 /* ignore unknown section that appeared in gcc 3.4.5(?) */
3071 && 0!= strcmp(".reloc", (char*)secname)
3072 && 0 != strcmp(".rdata$zzz", (char*)secname)
3073 ) {
3074 errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", secname, oc->fileName);
3075 stgFree(secname);
3076 return 0;
3077 }
3078
3079 if (kind != SECTIONKIND_OTHER && end >= start) {
3080 addSection(oc, kind, start, end);
3081 addProddableBlock(oc, start, end - start + 1);
3082 }
3083
3084 stgFree(secname);
3085 }
3086
3087 /* Copy exported symbols into the ObjectCode. */
3088
3089 oc->n_symbols = hdr->NumberOfSymbols;
3090 oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3091 "ocGetNames_PEi386(oc->symbols)");
3092 /* Call me paranoid; I don't care. */
3093 for (i = 0; i < oc->n_symbols; i++)
3094 oc->symbols[i] = NULL;
3095
3096 i = 0;
3097 while (1) {
3098 COFF_symbol* symtab_i;
3099 if (i >= (Int32)(hdr->NumberOfSymbols)) break;
3100 symtab_i = (COFF_symbol*)
3101 myindex ( sizeof_COFF_symbol, symtab, i );
3102
3103 addr = NULL;
3104
3105 if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
3106 && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
3107 /* This symbol is global and defined, viz, exported */
3108 /* for MYIMAGE_SYMCLASS_EXTERNAL
3109 && !MYIMAGE_SYM_UNDEFINED,
3110 the address of the symbol is:
3111 address of relevant section + offset in section
3112 */
3113 COFF_section* sectabent
3114 = (COFF_section*) myindex ( sizeof_COFF_section,
3115 sectab,
3116 symtab_i->SectionNumber-1 );
3117 addr = ((UChar*)(oc->image))
3118 + (sectabent->PointerToRawData
3119 + symtab_i->Value);
3120 }
3121 else
3122 if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
3123 && symtab_i->Value > 0) {
3124 /* This symbol isn't in any section at all, ie, global bss.
3125 Allocate zeroed space for it. */
3126 addr = stgCallocBytes(1, symtab_i->Value,
3127 "ocGetNames_PEi386(non-anonymous bss)");
3128 addSection(oc, SECTIONKIND_RWDATA, addr,
3129 ((UChar*)addr) + symtab_i->Value - 1);
3130 addProddableBlock(oc, addr, symtab_i->Value);
3131 /* debugBelch("BSS section at 0x%x\n", addr); */
3132 }
3133
3134 if (addr != NULL ) {
3135 sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
3136 /* debugBelch("addSymbol %p `%s \n", addr,sname); */
3137 IF_DEBUG(linker, debugBelch("addSymbol %p `%s'\n", addr,sname);)
3138 ASSERT(i >= 0 && i < oc->n_symbols);
3139 /* cstring_from_COFF_symbol_name always succeeds. */
3140 oc->symbols[i] = (char*)sname;
3141 ghciInsertStrHashTable(oc->fileName, symhash, (char*)sname, addr);
3142 } else {
3143 # if 0
3144 debugBelch(
3145 "IGNORING symbol %d\n"
3146 " name `",
3147 i
3148 );
3149 printName ( symtab_i->Name, strtab );
3150 debugBelch(
3151 "'\n"
3152 " value 0x%x\n"
3153 " 1+sec# %d\n"
3154 " type 0x%x\n"
3155 " sclass 0x%x\n"
3156 " nAux %d\n",
3157 symtab_i->Value,
3158 (Int32)(symtab_i->SectionNumber),
3159 (UInt32)symtab_i->Type,
3160 (UInt32)symtab_i->StorageClass,
3161 (UInt32)symtab_i->NumberOfAuxSymbols
3162 );
3163 # endif
3164 }
3165
3166 i += symtab_i->NumberOfAuxSymbols;
3167 i++;
3168 }
3169
3170 return 1;
3171 }
3172
3173
3174 static int
3175 ocResolve_PEi386 ( ObjectCode* oc )
3176 {
3177 COFF_header* hdr;
3178 COFF_section* sectab;
3179 COFF_symbol* symtab;
3180 UChar* strtab;
3181
3182 UInt32 A;
3183 UInt32 S;
3184 UInt32* pP;
3185
3186 int i;
3187 UInt32 j, noRelocs;
3188
3189 /* ToDo: should be variable-sized? But is at least safe in the
3190 sense of buffer-overrun-proof. */
3191 UChar symbol[1000];
3192 /* debugBelch("resolving for %s\n", oc->fileName); */
3193
3194 hdr = (COFF_header*)(oc->image);
3195 sectab = (COFF_section*) (
3196 ((UChar*)(oc->image))
3197 + sizeof_COFF_header + hdr->SizeOfOptionalHeader
3198 );
3199 symtab = (COFF_symbol*) (
3200 ((UChar*)(oc->image))
3201 + hdr->PointerToSymbolTable
3202 );
3203 strtab = ((UChar*)(oc->image))
3204 + hdr->PointerToSymbolTable
3205 + hdr->NumberOfSymbols * sizeof_COFF_symbol;
3206
3207 for (i = 0; i < hdr->NumberOfSections; i++) {
3208 COFF_section* sectab_i
3209 = (COFF_section*)
3210 myindex ( sizeof_COFF_section, sectab, i );
3211 COFF_reloc* reltab
3212 = (COFF_reloc*) (
3213 ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
3214 );
3215
3216 char *secname = cstring_from_section_name(sectab_i->Name, strtab);
3217
3218 /* Ignore sections called which contain stabs debugging
3219 information. */
3220 if (0 == strcmp(".stab", (char*)secname)
3221 || 0 == strcmp(".stabstr", (char*)secname)
3222 || 0 == strcmp(".ctors", (char*)secname)
3223 || 0 == strncmp(".debug", (char*)secname, 6)
3224 || 0 == strcmp(".rdata$zzz", (char*)secname)) {
3225 stgFree(secname);
3226 continue;
3227 }
3228
3229 stgFree(secname);
3230
3231 if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
3232 /* If the relocation field (a short) has overflowed, the
3233 * real count can be found in the first reloc entry.
3234 *
3235 * See Section 4.1 (last para) of the PE spec (rev6.0).
3236 *
3237 * Nov2003 update: the GNU linker still doesn't correctly
3238 * handle the generation of relocatable object files with
3239 * overflown relocations. Hence the output to warn of potential
3240 * troubles.
3241 */
3242 COFF_reloc* rel = (COFF_reloc*)
3243 myindex ( sizeof_COFF_reloc, reltab, 0 );
3244 noRelocs = rel->VirtualAddress;
3245
3246 /* 10/05: we now assume (and check for) a GNU ld that is capable
3247 * of handling object files with (>2^16) of relocs.
3248 */
3249 #if 0
3250 debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
3251 noRelocs);
3252 #endif
3253 j = 1;
3254 } else {
3255 noRelocs = sectab_i->NumberOfRelocations;
3256 j = 0;
3257 }
3258
3259
3260 for (; j < noRelocs; j++) {
3261 COFF_symbol* sym;
3262 COFF_reloc* reltab_j
3263 = (COFF_reloc*)
3264 myindex ( sizeof_COFF_reloc, reltab, j );
3265
3266 /* the location to patch */
3267 pP = (UInt32*)(
3268 ((UChar*)(oc->image))
3269 + (sectab_i->PointerToRawData
3270 + reltab_j->VirtualAddress
3271 - sectab_i->VirtualAddress )
3272 );
3273 /* the existing contents of pP */
3274 A = *pP;
3275 /* the symbol to connect to */
3276 sym = (COFF_symbol*)
3277 myindex ( sizeof_COFF_symbol,
3278 symtab, reltab_j->SymbolTableIndex );
3279 IF_DEBUG(linker,
3280 debugBelch(
3281 "reloc sec %2d num %3d: type 0x%-4x "
3282 "vaddr 0x%-8x name `",
3283 i, j,
3284 (UInt32)reltab_j->Type,
3285 reltab_j->VirtualAddress );
3286 printName ( sym->Name, strtab );
3287 debugBelch("'\n" ));
3288
3289 if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
3290 COFF_section* section_sym
3291 = findPEi386SectionCalled ( oc, sym->Name );
3292 if (!section_sym) {
3293 errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
3294 return 0;
3295 }
3296 S = ((UInt32)(oc->image))
3297 + (section_sym->PointerToRawData
3298 + sym->Value);
3299 } else {
3300 copyName ( sym->Name, strtab, symbol, 1000-1 );
3301 S = (UInt32) lookupSymbol( (char*)symbol );
3302 if ((void*)S != NULL) goto foundit;
3303 errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3304 return 0;
3305 foundit:;
3306 }
3307 checkProddableBlock(oc, pP);
3308 switch (reltab_j->Type) {
3309 case MYIMAGE_REL_I386_DIR32:
3310 *pP = A + S;
3311 break;
3312 case MYIMAGE_REL_I386_REL32:
3313 /* Tricky. We have to insert a displacement at
3314 pP which, when added to the PC for the _next_
3315 insn, gives the address of the target (S).
3316 Problem is to know the address of the next insn
3317 when we only know pP. We assume that this
3318 literal field is always the last in the insn,
3319 so that the address of the next insn is pP+4
3320 -- hence the constant 4.
3321 Also I don't know if A should be added, but so
3322 far it has always been zero.
3323
3324 SOF 05/2005: 'A' (old contents of *pP) have been observed
3325 to contain values other than zero (the 'wx' object file
3326 that came with wxhaskell-0.9.4; dunno how it was compiled..).
3327 So, add displacement to old value instead of asserting
3328 A to be zero. Fixes wxhaskell-related crashes, and no other
3329 ill effects have been observed.
3330
3331 Update: the reason why we're seeing these more elaborate
3332 relocations is due to a switch in how the NCG compiles SRTs
3333 and offsets to them from info tables. SRTs live in .(ro)data,
3334 while info tables live in .text, causing GAS to emit REL32/DISP32
3335 relocations with non-zero values. Adding the displacement is
3336 the right thing to do.
3337 */
3338 *pP = S - ((UInt32)pP) - 4 + A;
3339 break;
3340 default:
3341 debugBelch("%s: unhandled PEi386 relocation type %d",
3342 oc->fileName, reltab_j->Type);
3343 return 0;
3344 }
3345
3346 }
3347 }
3348
3349 IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
3350 return 1;
3351 }
3352
3353 #endif /* defined(OBJFORMAT_PEi386) */
3354
3355
3356 /* --------------------------------------------------------------------------
3357 * ELF specifics
3358 * ------------------------------------------------------------------------*/
3359
3360 #if defined(OBJFORMAT_ELF)
3361
3362 #define FALSE 0
3363 #define TRUE 1
3364
3365 #if defined(sparc_HOST_ARCH)
3366 # define ELF_TARGET_SPARC /* Used inside <elf.h> */
3367 #elif defined(i386_HOST_ARCH)
3368 # define ELF_TARGET_386 /* Used inside <elf.h> */
3369 #elif defined(x86_64_HOST_ARCH)
3370 # define ELF_TARGET_X64_64
3371 # define ELF_64BIT
3372 #endif
3373
3374 #if !defined(openbsd_HOST_OS)
3375 # include <elf.h>
3376 #else
3377 /* openbsd elf has things in different places, with diff names */
3378 # include <elf_abi.h>
3379 # include <machine/reloc.h>
3380 # define R_386_32 RELOC_32
3381 # define R_386_PC32 RELOC_PC32
3382 #endif
3383
3384 /* If elf.h doesn't define it */
3385 # ifndef R_X86_64_PC64
3386 # define R_X86_64_PC64 24
3387 # endif
3388
3389 /*
3390 * Define a set of types which can be used for both ELF32 and ELF64
3391 */
3392
3393 #ifdef ELF_64BIT
3394 #define ELFCLASS ELFCLASS64
3395 #define Elf_Addr Elf64_Addr
3396 #define Elf_Word Elf64_Word
3397 #define Elf_Sword Elf64_Sword
3398 #define Elf_Ehdr Elf64_Ehdr
3399 #define Elf_Phdr Elf64_Phdr
3400 #define Elf_Shdr Elf64_Shdr
3401 #define Elf_Sym Elf64_Sym
3402 #define Elf_Rel Elf64_Rel
3403 #define Elf_Rela Elf64_Rela
3404 #ifndef ELF_ST_TYPE
3405 #define ELF_ST_TYPE ELF64_ST_TYPE
3406 #endif
3407 #ifndef ELF_ST_BIND
3408 #define ELF_ST_BIND ELF64_ST_BIND
3409 #endif
3410 #ifndef ELF_R_TYPE
3411 #define ELF_R_TYPE ELF64_R_TYPE
3412 #endif
3413 #ifndef ELF_R_SYM
3414 #define ELF_R_SYM ELF64_R_SYM
3415 #endif
3416 #else
3417 #define ELFCLASS ELFCLASS32
3418 #define Elf_Addr Elf32_Addr
3419 #define Elf_Word Elf32_Word
3420 #define Elf_Sword Elf32_Sword
3421 #define Elf_Ehdr Elf32_Ehdr
3422 #define Elf_Phdr Elf32_Phdr
3423 #define Elf_Shdr Elf32_Shdr
3424 #define Elf_Sym Elf32_Sym
3425 #define Elf_Rel Elf32_Rel
3426 #define Elf_Rela Elf32_Rela
3427 #ifndef ELF_ST_TYPE
3428 #define ELF_ST_TYPE ELF32_ST_TYPE
3429 #endif
3430 #ifndef ELF_ST_BIND
3431 #define ELF_ST_BIND ELF32_ST_BIND
3432 #endif
3433 #ifndef ELF_R_TYPE
3434 #define ELF_R_TYPE ELF32_R_TYPE
3435 #endif
3436 #ifndef ELF_R_SYM
3437 #define ELF_R_SYM ELF32_R_SYM
3438 #endif
3439 #endif
3440
3441
3442 /*
3443 * Functions to allocate entries in dynamic sections. Currently we simply
3444 * preallocate a large number, and we don't check if a entry for the given
3445 * target already exists (a linear search is too slow). Ideally these
3446 * entries would be associated with symbols.
3447 */
3448
3449 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
3450 #define GOT_SIZE 0x20000
3451 #define FUNCTION_TABLE_SIZE 0x10000
3452 #define PLT_SIZE 0x08000
3453
3454 #ifdef ELF_NEED_GOT
3455 static Elf_Addr got[GOT_SIZE];
3456 static unsigned int gotIndex;
3457 static Elf_Addr gp_val = (Elf_Addr)got;
3458
3459 static Elf_Addr
3460 allocateGOTEntry(Elf_Addr target)
3461 {
3462 Elf_Addr *entry;
3463
3464 if (gotIndex >= GOT_SIZE)
3465 barf("Global offset table overflow");
3466
3467 entry = &got[gotIndex++];
3468 *entry = target;
3469 return (Elf_Addr)entry;
3470 }
3471 #endif
3472
3473 #ifdef ELF_FUNCTION_DESC
3474 typedef struct {
3475 Elf_Addr ip;
3476 Elf_Addr gp;
3477 } FunctionDesc;
3478
3479 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
3480 static unsigned int functionTableIndex;
3481
3482 static Elf_Addr
3483 allocateFunctionDesc(Elf_Addr target)
3484 {
3485 FunctionDesc *entry;
3486
3487 if (functionTableIndex >= FUNCTION_TABLE_SIZE)
3488 barf("Function table overflow");
3489
3490 entry = &functionTable[functionTableIndex++];
3491 entry->ip = target;
3492 entry->gp = (Elf_Addr)gp_val;
3493 return (Elf_Addr)entry;
3494 }
3495
3496 static Elf_Addr
3497 copyFunctionDesc(Elf_Addr target)
3498 {
3499 FunctionDesc *olddesc = (FunctionDesc *)target;
3500 FunctionDesc *newdesc;
3501
3502 newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
3503 newdesc->gp = olddesc->gp;
3504 return (Elf_Addr)newdesc;
3505 }
3506 #endif
3507
3508 #ifdef ELF_NEED_PLT
3509
3510 typedef struct {
3511 unsigned char code[sizeof(plt_code)];
3512 } PLTEntry;
3513
3514 static Elf_Addr
3515 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
3516 {
3517 PLTEntry *plt = (PLTEntry *)oc->plt;
3518 PLTEntry *entry;
3519
3520 if (oc->pltIndex >= PLT_SIZE)
3521 barf("Procedure table overflow");
3522
3523 entry = &plt[oc->pltIndex++];
3524 memcpy(entry->code, plt_code, sizeof(entry->code));
3525 PLT_RELOC(entry->code, target);
3526 return (Elf_Addr)entry;
3527 }
3528
3529 static unsigned int
3530 PLTSize(void)
3531 {
3532 return (PLT_SIZE * sizeof(PLTEntry));
3533 }
3534 #endif
3535
3536
3537 /*
3538 * Generic ELF functions
3539 */
3540
3541 static char *
3542 findElfSection ( void* objImage, Elf_Word sh_type )
3543 {
3544 char* ehdrC = (char*)objImage;
3545 Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
3546 Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
3547 char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
3548 char* ptr = NULL;
3549 int i;
3550
3551 for (i = 0; i < ehdr->e_shnum; i++) {
3552 if (shdr[i].sh_type == sh_type
3553 /* Ignore the section header's string table. */
3554 && i != ehdr->e_shstrndx
3555 /* Ignore string tables named .stabstr, as they contain
3556 debugging info. */
3557 && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
3558 ) {
3559 ptr = ehdrC + shdr[i].sh_offset;
3560 break;
3561 }
3562 }
3563 return ptr;
3564 }
3565
3566 static int
3567 ocVerifyImage_ELF ( ObjectCode* oc )
3568 {
3569 Elf_Shdr* shdr;
3570 Elf_Sym* stab;
3571 int i, j, nent, nstrtab, nsymtabs;
3572 char* sh_strtab;
3573 char* strtab;
3574
3575 char* ehdrC = (char*)(oc->image);
3576 Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
3577
3578 if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
3579 ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
3580 ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
3581 ehdr->e_ident[EI_MAG3] != ELFMAG3) {
3582 errorBelch("%s: not an ELF object", oc->fileName);
3583 return 0;
3584 }
3585
3586 if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
3587 errorBelch("%s: unsupported ELF format", oc->fileName);
3588 return 0;
3589 }
3590
3591 if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
3592 IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
3593 } else
3594 if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
3595 IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
3596 } else {
3597 errorBelch("%s: unknown endiannness", oc->fileName);
3598 return 0;
3599 }
3600
3601 if (ehdr->e_type != ET_REL) {
3602 errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
3603 return 0;
3604 }
3605 IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
3606
3607 IF_DEBUG(linker,debugBelch( "Architecture is " ));
3608 switch (ehdr->e_machine) {
3609 case EM_386: IF_DEBUG(linker,debugBelch( "x86" )); break;
3610 #ifdef EM_SPARC32PLUS
3611 case EM_SPARC32PLUS:
3612 #endif
3613 case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
3614 #ifdef EM_IA_64
3615 case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
3616 #endif
3617 case EM_PPC: IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
3618 #ifdef EM_X86_64
3619 case EM_X86_64: IF_DEBUG(linker,debugBelch( "x86_64" )); break;
3620 #elif defined(EM_AMD64)
3621 case EM_AMD64: IF_DEBUG(linker,debugBelch( "amd64" )); break;
3622 #endif
3623 default: IF_DEBUG(linker,debugBelch( "unknown" ));
3624 errorBelch("%s: unknown architecture (e_machine == %d)"
3625 , oc->fileName, ehdr->e_machine);
3626 return 0;
3627 }
3628
3629 IF_DEBUG(linker,debugBelch(
3630 "\nSection header table: start %ld, n_entries %d, ent_size %d\n",
3631 (long)ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize ));
3632
3633 ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
3634
3635 shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3636
3637 if (ehdr->e_shstrndx == SHN_UNDEF) {
3638 errorBelch("%s: no section header string table", oc->fileName);
3639 return 0;
3640 } else {
3641 IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
3642 ehdr->e_shstrndx));
3643 sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
3644 }
3645
3646 for (i = 0; i < ehdr->e_shnum; i++) {
3647 IF_DEBUG(linker,debugBelch("%2d: ", i ));
3648 IF_DEBUG(linker,debugBelch("type=%2d ", (int)shdr[i].sh_type ));
3649 IF_DEBUG(linker,debugBelch("size=%4d ", (int)shdr[i].sh_size ));
3650 IF_DEBUG(linker,debugBelch("offs=%4d ", (int)shdr[i].sh_offset ));
3651 IF_DEBUG(linker,debugBelch(" (%p .. %p) ",
3652 ehdrC + shdr[i].sh_offset,
3653 ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
3654
3655 if (shdr[i].sh_type == SHT_REL) {
3656 IF_DEBUG(linker,debugBelch("Rel " ));
3657 } else if (shdr[i].sh_type == SHT_RELA) {
3658 IF_DEBUG(linker,debugBelch("RelA " ));
3659 } else {
3660 IF_DEBUG(linker,debugBelch(" "));
3661 }
3662 if (sh_strtab) {
3663 IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
3664 }
3665 }
3666
3667 IF_DEBUG(linker,debugBelch( "\nString tables" ));
3668 strtab = NULL;
3669 nstrtab = 0;
3670 for (i = 0; i < ehdr->e_shnum; i++) {
3671 if (shdr[i].sh_type == SHT_STRTAB
3672 /* Ignore the section header's string table. */
3673 && i != ehdr->e_shstrndx
3674 /* Ignore string tables named .stabstr, as they contain
3675 debugging info. */
3676 && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
3677 ) {
3678 IF_DEBUG(linker,debugBelch(" section %d is a normal string table", i ));
3679 strtab = ehdrC + shdr[i].sh_offset;
3680 nstrtab++;
3681 }
3682 }
3683 if (nstrtab != 1) {
3684 errorBelch("%s: no string tables, or too many", oc->fileName);
3685 return 0;
3686 }
3687
3688 nsymtabs = 0;
3689 IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
3690 for (i = 0; i < ehdr->e_shnum; i++) {
3691 if (shdr[i].sh_type != SHT_SYMTAB) continue;
3692 IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
3693 nsymtabs++;
3694 stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3695 nent = shdr[i].sh_size / sizeof(Elf_Sym);
3696 IF_DEBUG(linker,debugBelch( " number of entries is apparently %d (%ld rem)\n",
3697 nent,
3698 (long)shdr[i].sh_size % sizeof(Elf_Sym)
3699 ));
3700 if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
3701 errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
3702 return 0;
3703 }
3704 for (j = 0; j < nent; j++) {
3705 IF_DEBUG(linker,debugBelch(" %2d ", j ));
3706 IF_DEBUG(linker,debugBelch(" sec=%-5d size=%-3d val=%5p ",
3707 (int)stab[j].st_shndx,
3708 (int)stab[j].st_size,
3709 (char*)stab[j].st_value ));
3710
3711 IF_DEBUG(linker,debugBelch("type=" ));
3712 switch (ELF_ST_TYPE(stab[j].st_info)) {
3713 case STT_NOTYPE: IF_DEBUG(linker,debugBelch("notype " )); break;
3714 case STT_OBJECT: IF_DEBUG(linker,debugBelch("object " )); break;
3715 case STT_FUNC : IF_DEBUG(linker,debugBelch("func " )); break;
3716 case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
3717 case STT_FILE: IF_DEBUG(linker,debugBelch("file " )); break;
3718 default: IF_DEBUG(linker,debugBelch("? " )); break;
3719 }
3720 IF_DEBUG(linker,debugBelch(" " ));
3721
3722 IF_DEBUG(linker,debugBelch("bind=" ));
3723 switch (ELF_ST_BIND(stab[j].st_info)) {
3724 case STB_LOCAL : IF_DEBUG(linker,debugBelch("local " )); break;
3725 case STB_GLOBAL: IF_DEBUG(linker,debugBelch("global" )); break;
3726 case STB_WEAK : IF_DEBUG(linker,debugBelch("weak " )); break;
3727 default: IF_DEBUG(linker,debugBelch("? " )); break;
3728 }
3729 IF_DEBUG(linker,debugBelch(" " ));
3730
3731 IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
3732 }
3733 }
3734
3735 if (nsymtabs == 0) {
3736 errorBelch("%s: didn't find any symbol tables", oc->fileName);
3737 return 0;
3738 }
3739
3740 return 1;
3741 }
3742
3743 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
3744 {
3745 *is_bss = FALSE;
3746
3747 if (hdr->sh_type == SHT_PROGBITS
3748 && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
3749 /* .text-style section */
3750 return SECTIONKIND_CODE_OR_RODATA;
3751 }
3752
3753 if (hdr->sh_type == SHT_PROGBITS
3754 && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3755 /* .data-style section */
3756 return SECTIONKIND_RWDATA;
3757 }
3758
3759 if (hdr->sh_type == SHT_PROGBITS
3760 && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
3761 /* .rodata-style section */
3762 return SECTIONKIND_CODE_OR_RODATA;
3763 }
3764
3765 if (hdr->sh_type == SHT_NOBITS
3766 && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3767 /* .bss-style section */
3768 *is_bss = TRUE;
3769 return SECTIONKIND_RWDATA;
3770 }
3771
3772 return SECTIONKIND_OTHER;
3773 }
3774
3775
3776 static int
3777 ocGetNames_ELF ( ObjectCode* oc )
3778 {
3779 int i, j, k, nent;
3780 Elf_Sym* stab;
3781
3782 char* ehdrC = (char*)(oc->image);
3783 Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
3784 char* strtab = findElfSection ( ehdrC, SHT_STRTAB );
3785 Elf_Shdr* shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3786
3787 ASSERT(symhash != NULL);
3788
3789 if (!strtab) {
3790 errorBelch("%s: no strtab", oc->fileName);
3791 return 0;
3792 }
3793
3794 k = 0;
3795 for (i = 0; i < ehdr->e_shnum; i++) {
3796 /* Figure out what kind of section it is. Logic derived from
3797 Figure 1.14 ("Special Sections") of the ELF document
3798 ("Portable Formats Specification, Version 1.1"). */
3799 int is_bss = FALSE;
3800 SectionKind kind = getSectionKind_ELF(&shdr[i], &is_bss);
3801
3802 if (is_bss && shdr[i].sh_size > 0) {
3803 /* This is a non-empty .bss section. Allocate zeroed space for
3804 it, and set its .sh_offset field such that
3805 ehdrC + .sh_offset == addr_of_zeroed_space. */
3806 char* zspace = stgCallocBytes(1, shdr[i].sh_size,
3807 "ocGetNames_ELF(BSS)");
3808 shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
3809 /*
3810 debugBelch("BSS section at 0x%x, size %d\n",
3811 zspace, shdr[i].sh_size);
3812 */
3813 }
3814
3815 /* fill in the section info */
3816 if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
3817 addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
3818 addSection(oc, kind, ehdrC + shdr[i].sh_offset,
3819 ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
3820 }
3821
3822 if (shdr[i].sh_type != SHT_SYMTAB) continue;
3823
3824 /* copy stuff into this module's object symbol table */
3825 stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3826 nent = shdr[i].sh_size / sizeof(Elf_Sym);
3827
3828 oc->n_symbols = nent;
3829 oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3830 "ocGetNames_ELF(oc->symbols)");
3831
3832 for (j = 0; j < nent; j++) {
3833
3834 char isLocal = FALSE; /* avoids uninit-var warning */
3835 char* ad = NULL;
3836 char* nm = strtab + stab[j].st_name;
3837 int secno = stab[j].st_shndx;
3838
3839 /* Figure out if we want to add it; if so, set ad to its
3840 address. Otherwise leave ad == NULL. */
3841
3842 if (secno == SHN_COMMON) {
3843 isLocal = FALSE;
3844 ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
3845 /*
3846 debugBelch("COMMON symbol, size %d name %s\n",
3847 stab[j].st_size, nm);
3848 */
3849 /* Pointless to do addProddableBlock() for this area,
3850 since the linker should never poke around in it. */
3851 }
3852 else
3853 if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
3854 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
3855 )
3856 /* and not an undefined symbol */
3857 && stab[j].st_shndx != SHN_UNDEF
3858 /* and not in a "special section" */
3859 && stab[j].st_shndx < SHN_LORESERVE
3860 &&
3861 /* and it's a not a section or string table or anything silly */
3862 ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
3863 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
3864 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
3865 )
3866 ) {
3867 /* Section 0 is the undefined section, hence > and not >=. */
3868 ASSERT(secno > 0 && secno < ehdr->e_shnum);
3869 /*
3870 if (shdr[secno].sh_type == SHT_NOBITS) {
3871 debugBelch(" BSS symbol, size %d off %d name %s\n",
3872 stab[j].st_size, stab[j].st_value, nm);
3873 }
3874 */
3875 ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
3876 if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
3877 isLocal = TRUE;
3878 } else {
3879 #ifdef ELF_FUNCTION_DESC
3880 /* dlsym() and the initialisation table both give us function
3881 * descriptors, so to be consistent we store function descriptors
3882 * in the symbol table */
3883 if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
3884 ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
3885 #endif
3886 IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p %s %s\n",
3887 ad, oc->fileName, nm ));
3888 isLocal = FALSE;
3889 }
3890 }
3891
3892 /* And the decision is ... */
3893
3894 if (ad != NULL) {
3895 ASSERT(nm != NULL);
3896 oc->symbols[j] = nm;
3897 /* Acquire! */
3898 if (isLocal) {
3899 /* Ignore entirely. */
3900 } else {
3901 ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
3902 }
3903 } else {
3904 /* Skip. */
3905 IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
3906 strtab + stab[j].st_name ));
3907 /*
3908 debugBelch(
3909 "skipping bind = %d, type = %d, shndx = %d `%s'\n",
3910 (int)ELF_ST_BIND(stab[j].st_info),
3911 (int)ELF_ST_TYPE(stab[j].st_info),
3912 (int)stab[j].st_shndx,
3913 strtab + stab[j].st_name
3914 );
3915 */
3916 oc->symbols[j] = NULL;
3917 }
3918
3919 }
3920 }
3921
3922 return 1;
3923 }
3924
3925 /* Do ELF relocations which lack an explicit addend. All x86-linux
3926 relocations appear to be of this form. */
3927 static int
3928 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
3929 Elf_Shdr* shdr, int shnum,
3930 Elf_Sym* stab, char* strtab )
3931 {
3932 int j;
3933 char *symbol;
3934 Elf_Word* targ;
3935 Elf_Rel* rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
3936 int nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
3937 int target_shndx = shdr[shnum].sh_info;
3938 int symtab_shndx = shdr[shnum].sh_link;
3939
3940 stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3941 targ = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
3942 IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3943 target_shndx, symtab_shndx ));
3944
3945 /* Skip sections that we're not interested in. */
3946 {
3947 int is_bss;
3948 SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
3949 if (kind == SECTIONKIND_OTHER) {
3950 IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
3951 return 1;
3952 }
3953 }
3954
3955 for (j = 0; j < nent; j++) {
3956 Elf_Addr offset = rtab[j].r_offset;
3957 Elf_Addr info = rtab[j].r_info;
3958
3959 Elf_Addr P = ((Elf_Addr)targ) + offset;
3960 Elf_Word* pP = (Elf_Word*)P;
3961 Elf_Addr A = *pP;
3962 Elf_Addr S;
3963 void* S_tmp;
3964 Elf_Addr value;
3965 StgStablePtr stablePtr;
3966 StgPtr stableVal;
3967
3968 IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
3969 j, (void*)offset, (void*)info ));
3970 if (!info) {
3971 IF_DEBUG(linker,debugBelch( " ZERO" ));
3972 S = 0;
3973 } else {
3974 Elf_Sym sym = stab[ELF_R_SYM(info)];
3975 /* First see if it is a local symbol. */
3976 if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3977 /* Yes, so we can get the address directly from the ELF symbol
3978 table. */
3979 symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3980 S = (Elf_Addr)
3981 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3982 + stab[ELF_R_SYM(info)].st_value);
3983
3984 } else {
3985 symbol = strtab + sym.st_name;
3986 stablePtr = (StgStablePtr)lookupHashTable(stablehash, (StgWord)symbol);
3987 if (NULL == stablePtr) {
3988 /* No, so look up the name in our global table. */
3989 S_tmp = lookupSymbol( symbol );
3990 S = (Elf_Addr)S_tmp;
3991 } else {
3992 stableVal = deRefStablePtr( stablePtr );
3993 S_tmp = stableVal;
3994 S = (Elf_Addr)S_tmp;
3995 }
3996 }
3997 if (!S) {
3998 errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3999 return 0;
4000 }
4001 IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n"<