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