rts/Linker.c: Convert #if/#else to if/else
[ghc.git] / rts / Linker.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 2000-2012
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 "Proftimer.h"
31 #include "GetEnv.h"
32 #include "Stable.h"
33 #include "RtsSymbols.h"
34
35 #if !defined(mingw32_HOST_OS)
36 #include "posix/Signals.h"
37 #endif
38
39 // get protos for is*()
40 #include <ctype.h>
41
42 #ifdef HAVE_SYS_TYPES_H
43 #include <sys/types.h>
44 #endif
45
46 #include <inttypes.h>
47 #include <stdlib.h>
48 #include <string.h>
49 #include <stdio.h>
50 #include <assert.h>
51 #include <libgen.h>
52
53 #ifdef HAVE_SYS_STAT_H
54 #include <sys/stat.h>
55 #endif
56
57 #if defined(HAVE_DLFCN_H)
58 #include <dlfcn.h>
59 #endif
60
61 #if defined(cygwin32_HOST_OS)
62 #ifdef HAVE_DIRENT_H
63 #include <dirent.h>
64 #endif
65
66 #ifdef HAVE_SYS_TIME_H
67 #include <sys/time.h>
68 #endif
69 #include <regex.h>
70 #include <sys/fcntl.h>
71 #include <sys/termios.h>
72 #include <sys/utime.h>
73 #include <sys/utsname.h>
74 #include <sys/wait.h>
75 #endif
76
77 #if (defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)) \
78 || (!defined(powerpc_HOST_ARCH) && \
79 ( defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || \
80 defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \
81 defined(openbsd_HOST_OS ) || defined(darwin_HOST_OS ) || \
82 defined(kfreebsdgnu_HOST_OS) || defined(gnu_HOST_OS ) || \
83 defined(solaris2_HOST_OS)))
84 /* Don't use mmap on powerpc_HOST_ARCH as mmap doesn't support
85 * reallocating but we need to allocate jump islands just after each
86 * object images. Otherwise relative branches to jump islands can fail
87 * due to 24-bits displacement overflow.
88 */
89 #define USE_MMAP
90 #include <fcntl.h>
91 #include <sys/mman.h>
92
93 #ifdef HAVE_UNISTD_H
94 #include <unistd.h>
95 #endif
96
97 #endif
98
99
100 /* PowerPC has relative branch instructions with only 24 bit displacements
101 * and therefore needs jump islands contiguous with each object code module.
102 */
103 #if (defined(USE_MMAP) && defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS))
104 #define USE_CONTIGUOUS_MMAP 1
105 #else
106 #define USE_CONTIGUOUS_MMAP 0
107 #endif
108
109 #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) || defined(gnu_HOST_OS)
110 # define OBJFORMAT_ELF
111 # include <regex.h> // regex is already used by dlopen() so this is OK
112 // to use here without requiring an additional lib
113 #elif defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
114 # define OBJFORMAT_PEi386
115 # include <windows.h>
116 # include <shfolder.h> /* SHGetFolderPathW */
117 # include <math.h>
118 #elif defined(darwin_HOST_OS)
119 # define OBJFORMAT_MACHO
120 # include <regex.h>
121 # include <mach/machine.h>
122 # include <mach-o/fat.h>
123 # include <mach-o/loader.h>
124 # include <mach-o/nlist.h>
125 # include <mach-o/reloc.h>
126 #if !defined(HAVE_DLFCN_H)
127 # include <mach-o/dyld.h>
128 #endif
129 #if defined(powerpc_HOST_ARCH)
130 # include <mach-o/ppc/reloc.h>
131 #endif
132 #if defined(x86_64_HOST_ARCH)
133 # include <mach-o/x86_64/reloc.h>
134 #endif
135 #endif
136
137 #if defined(x86_64_HOST_ARCH) && defined(darwin_HOST_OS)
138 #define ALWAYS_PIC
139 #endif
140
141 #if defined(dragonfly_HOST_OS)
142 #include <sys/tls.h>
143 #endif
144
145 typedef struct _RtsSymbolInfo {
146 void *value;
147 const ObjectCode *owner;
148 HsBool weak;
149 } RtsSymbolInfo;
150
151 /* Hash table mapping symbol names to RtsSymbolInfo */
152 static /*Str*/HashTable *symhash;
153
154 /* List of currently loaded objects */
155 ObjectCode *objects = NULL; /* initially empty */
156
157 /* List of objects that have been unloaded via unloadObj(), but are waiting
158 to be actually freed via checkUnload() */
159 ObjectCode *unloaded_objects = NULL; /* initially empty */
160
161 #ifdef THREADED_RTS
162 /* This protects all the Linker's global state except unloaded_objects */
163 Mutex linker_mutex;
164 /*
165 * This protects unloaded_objects. We have a separate mutex for this, because
166 * the GC needs to access unloaded_objects in checkUnload, while the linker only
167 * needs to access unloaded_objects in unloadObj(), so this allows most linker
168 * operations proceed concurrently with the GC.
169 */
170 Mutex linker_unloaded_mutex;
171 #endif
172
173 /* Type of the initializer */
174 typedef void (*init_t) (int argc, char **argv, char **env);
175
176 static HsInt isAlreadyLoaded( pathchar *path );
177 static HsInt loadOc( ObjectCode* oc );
178 static ObjectCode* mkOc( pathchar *path, char *image, int imageSize,
179 rtsBool mapped, char *archiveMemberName
180 #ifndef USE_MMAP
181 #ifdef darwin_HOST_OS
182 , int misalignment
183 #endif
184 #endif
185 );
186
187 // Use wchar_t for pathnames on Windows (#5697)
188 #if defined(mingw32_HOST_OS)
189 #define pathcmp wcscmp
190 #define pathlen wcslen
191 #define pathopen _wfopen
192 #define pathstat _wstat
193 #define struct_stat struct _stat
194 #define open wopen
195 #define WSTR(s) L##s
196 #else
197 #define pathcmp strcmp
198 #define pathlen strlen
199 #define pathopen fopen
200 #define pathstat stat
201 #define struct_stat struct stat
202 #define WSTR(s) s
203 #endif
204
205 static pathchar* pathdup(pathchar *path)
206 {
207 pathchar *ret;
208 #if defined(mingw32_HOST_OS)
209 ret = wcsdup(path);
210 #else
211 /* sigh, strdup() isn't a POSIX function, so do it the long way */
212 ret = stgMallocBytes( strlen(path)+1, "loadObj" );
213 strcpy(ret, path);
214 #endif
215 return ret;
216 }
217
218
219 #if defined(OBJFORMAT_ELF)
220 static int ocVerifyImage_ELF ( ObjectCode* oc );
221 static int ocGetNames_ELF ( ObjectCode* oc );
222 static int ocResolve_ELF ( ObjectCode* oc );
223 static int ocRunInit_ELF ( ObjectCode* oc );
224 #if NEED_SYMBOL_EXTRAS
225 static int ocAllocateSymbolExtras_ELF ( ObjectCode* oc );
226 #endif
227 #elif defined(OBJFORMAT_PEi386)
228 static int ocVerifyImage_PEi386 ( ObjectCode* oc );
229 static int ocGetNames_PEi386 ( ObjectCode* oc );
230 static int ocResolve_PEi386 ( ObjectCode* oc );
231 static int ocRunInit_PEi386 ( ObjectCode* oc );
232 static void *lookupSymbolInDLLs ( unsigned char *lbl );
233 /* See Note [mingw-w64 name decoration scheme] */
234 #ifndef x86_64_HOST_ARCH
235 static void zapTrailingAtSign ( unsigned char *sym );
236 #endif
237 static char *allocateImageAndTrampolines (
238 pathchar* arch_name, char* member_name,
239 #if defined(x86_64_HOST_ARCH)
240 FILE* f,
241 #endif
242 int size );
243 #if defined(x86_64_HOST_ARCH)
244 static int ocAllocateSymbolExtras_PEi386 ( ObjectCode* oc );
245 static size_t makeSymbolExtra_PEi386( ObjectCode* oc, size_t, char* symbol );
246 #define PEi386_IMAGE_OFFSET 4
247 #else
248 #define PEi386_IMAGE_OFFSET 0
249 #endif
250 #elif defined(OBJFORMAT_MACHO)
251 static int ocVerifyImage_MachO ( ObjectCode* oc );
252 static int ocGetNames_MachO ( ObjectCode* oc );
253 static int ocResolve_MachO ( ObjectCode* oc );
254 static int ocRunInit_MachO ( ObjectCode* oc );
255
256 #ifndef USE_MMAP
257 static int machoGetMisalignment( FILE * );
258 #endif
259 #if NEED_SYMBOL_EXTRAS
260 static int ocAllocateSymbolExtras_MachO ( ObjectCode* oc );
261 #endif
262 #ifdef powerpc_HOST_ARCH
263 static void machoInitSymbolsWithoutUnderscore( void );
264 #endif
265 #endif
266
267 static void freeProddableBlocks (ObjectCode *oc);
268
269 #ifdef USE_MMAP
270 /**
271 * An allocated page being filled by the allocator
272 */
273 struct m32_alloc_t {
274 void * base_addr; // Page address
275 unsigned int current_size; // Number of bytes already reserved
276 };
277
278 #define M32_MAX_PAGES 32
279
280 /**
281 * Allocator
282 *
283 * Currently an allocator is just a set of pages being filled. The maximum
284 * number of pages can be configured with M32_MAX_PAGES.
285 */
286 typedef struct m32_allocator_t {
287 struct m32_alloc_t pages[M32_MAX_PAGES];
288 } * m32_allocator;
289
290 // We use a global memory allocator
291 static struct m32_allocator_t allocator;
292
293 struct m32_allocator_t;
294 static void m32_allocator_init(struct m32_allocator_t *m32);
295 #endif
296
297 /* on x86_64 we have a problem with relocating symbol references in
298 * code that was compiled without -fPIC. By default, the small memory
299 * model is used, which assumes that symbol references can fit in a
300 * 32-bit slot. The system dynamic linker makes this work for
301 * references to shared libraries by either (a) allocating a jump
302 * table slot for code references, or (b) moving the symbol at load
303 * time (and copying its contents, if necessary) for data references.
304 *
305 * We unfortunately can't tell whether symbol references are to code
306 * or data. So for now we assume they are code (the vast majority
307 * are), and allocate jump-table slots. Unfortunately this will
308 * SILENTLY generate crashing code for data references. This hack is
309 * enabled by X86_64_ELF_NONPIC_HACK.
310 *
311 * One workaround is to use shared Haskell libraries. This is
312 * coming. Another workaround is to keep the static libraries but
313 * compile them with -fPIC, because that will generate PIC references
314 * to data which can be relocated. The PIC code is still too green to
315 * do this systematically, though.
316 *
317 * See bug #781
318 * See thread http://www.haskell.org/pipermail/cvs-ghc/2007-September/038458.html
319 *
320 * Naming Scheme for Symbol Macros
321 *
322 * SymI_*: symbol is internal to the RTS. It resides in an object
323 * file/library that is statically.
324 * SymE_*: symbol is external to the RTS library. It might be linked
325 * dynamically.
326 *
327 * Sym*_HasProto : the symbol prototype is imported in an include file
328 * or defined explicitly
329 * Sym*_NeedsProto: the symbol is undefined and we add a dummy
330 * default proto extern void sym(void);
331 */
332 #define X86_64_ELF_NONPIC_HACK 1
333
334 /* Link objects into the lower 2Gb on x86_64. GHC assumes the
335 * small memory model on this architecture (see gcc docs,
336 * -mcmodel=small).
337 *
338 * MAP_32BIT not available on OpenBSD/amd64
339 */
340 #if defined(x86_64_HOST_ARCH) && defined(MAP_32BIT)
341 #define TRY_MAP_32BIT MAP_32BIT
342 #else
343 #define TRY_MAP_32BIT 0
344 #endif
345
346 /*
347 * Due to the small memory model (see above), on x86_64 we have to map
348 * all our non-PIC object files into the low 2Gb of the address space
349 * (why 2Gb and not 4Gb? Because all addresses must be reachable
350 * using a 32-bit signed PC-relative offset). On Linux we can do this
351 * using the MAP_32BIT flag to mmap(), however on other OSs
352 * (e.g. *BSD, see #2063, and also on Linux inside Xen, see #2512), we
353 * can't do this. So on these systems, we have to pick a base address
354 * in the low 2Gb of the address space and try to allocate memory from
355 * there.
356 *
357 * We pick a default address based on the OS, but also make this
358 * configurable via an RTS flag (+RTS -xm)
359 */
360 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
361
362 #if defined(MAP_32BIT)
363 // Try to use MAP_32BIT
364 #define MMAP_32BIT_BASE_DEFAULT 0
365 #else
366 // A guess: 1Gb.
367 #define MMAP_32BIT_BASE_DEFAULT 0x40000000
368 #endif
369
370 static void *mmap_32bit_base = (void *)MMAP_32BIT_BASE_DEFAULT;
371 #endif
372
373 /* MAP_ANONYMOUS is MAP_ANON on some systems, e.g. OpenBSD */
374 #if !defined(MAP_ANONYMOUS) && defined(MAP_ANON)
375 #define MAP_ANONYMOUS MAP_ANON
376 #endif
377
378 /* -----------------------------------------------------------------------------
379 * Insert symbols into hash tables, checking for duplicates.
380 *
381 * Returns: 0 on failure, nonzero on success
382 */
383
384 static int ghciInsertSymbolTable(
385 pathchar* obj_name,
386 HashTable *table,
387 const char* key,
388 void *data,
389 HsBool weak,
390 ObjectCode *owner)
391 {
392 RtsSymbolInfo *pinfo = lookupStrHashTable(table, key);
393 if (!pinfo) /* new entry */
394 {
395 pinfo = stgMallocBytes(sizeof (*pinfo), "ghciInsertToSymbolTable");
396 pinfo->value = data;
397 pinfo->owner = owner;
398 pinfo->weak = weak;
399 insertStrHashTable(table, key, pinfo);
400 return 1;
401 }
402 else if ((!pinfo->weak || pinfo->value) && weak)
403 {
404 return 1; /* duplicate weak symbol, throw it away */
405 }
406 else if (pinfo->weak) /* weak symbol is in the table */
407 {
408 /* override the weak definition with the non-weak one */
409 pinfo->value = data;
410 pinfo->owner = owner;
411 pinfo->weak = HS_BOOL_FALSE;
412 return 1;
413 }
414 debugBelch(
415 "GHC runtime linker: fatal error: I found a duplicate definition for symbol\n"
416 " %s\n"
417 "whilst processing object file\n"
418 " %" PATH_FMT "\n"
419 "This could be caused by:\n"
420 " * Loading two different object files which export the same symbol\n"
421 " * Specifying the same object file twice on the GHCi command line\n"
422 " * An incorrect `package.conf' entry, causing some object to be\n"
423 " loaded twice.\n",
424 (char*)key,
425 obj_name
426 );
427 return 0;
428 }
429
430 static HsBool ghciLookupSymbolTable(HashTable *table,
431 const char *key, void **result)
432 {
433 RtsSymbolInfo *pinfo = lookupStrHashTable(table, key);
434 if (!pinfo) {
435 *result = NULL;
436 return HS_BOOL_FALSE;
437 }
438 if (pinfo->weak)
439 IF_DEBUG(linker, debugBelch("lookup: promoting %s\n", key));
440 /* Once it's looked up, it can no longer be overridden */
441 pinfo->weak = HS_BOOL_FALSE;
442
443 *result = pinfo->value;
444 return HS_BOOL_TRUE;
445 }
446
447 static void ghciRemoveSymbolTable(HashTable *table, const char *key,
448 ObjectCode *owner)
449 {
450 RtsSymbolInfo *pinfo = lookupStrHashTable(table, key);
451 if (!pinfo || owner != pinfo->owner) return;
452 removeStrHashTable(table, key, NULL);
453 stgFree(pinfo);
454 }
455 /* -----------------------------------------------------------------------------
456 * initialize the object linker
457 */
458
459
460 static int linker_init_done = 0 ;
461
462 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
463 static void *dl_prog_handle;
464 static regex_t re_invalid;
465 static regex_t re_realso;
466 #ifdef THREADED_RTS
467 static Mutex dl_mutex; // mutex to protect dlopen/dlerror critical section
468 #endif
469 #elif defined(OBJFORMAT_PEi386)
470 void addDLLHandle(pathchar* dll_name, HINSTANCE instance);
471 #endif
472
473 void initLinker (void)
474 {
475 // default to retaining CAFs for backwards compatibility. Most
476 // users will want initLinker_(0): otherwise unloadObj() will not
477 // be able to unload object files when they contain CAFs.
478 initLinker_(1);
479 }
480
481 void
482 initLinker_ (int retain_cafs)
483 {
484 RtsSymbolVal *sym;
485 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
486 int compileResult;
487 #endif
488
489 IF_DEBUG(linker, debugBelch("initLinker: start\n"));
490
491 /* Make initLinker idempotent, so we can call it
492 before every relevant operation; that means we
493 don't need to initialise the linker separately */
494 if (linker_init_done == 1) {
495 IF_DEBUG(linker, debugBelch("initLinker: idempotent return\n"));
496 return;
497 } else {
498 linker_init_done = 1;
499 }
500
501 objects = NULL;
502 unloaded_objects = NULL;
503
504 #if defined(THREADED_RTS)
505 initMutex(&linker_mutex);
506 initMutex(&linker_unloaded_mutex);
507 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
508 initMutex(&dl_mutex);
509 #endif
510 #endif
511 symhash = allocStrHashTable();
512
513 /* populate the symbol table with stuff from the RTS */
514 for (sym = rtsSyms; sym->lbl != NULL; sym++) {
515 if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"),
516 symhash, sym->lbl, sym->addr, HS_BOOL_FALSE, NULL)) {
517 barf("ghciInsertSymbolTable failed");
518 }
519 IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
520 }
521 # if defined(OBJFORMAT_MACHO) && defined(powerpc_HOST_ARCH)
522 machoInitSymbolsWithoutUnderscore();
523 # endif
524 /* GCC defines a special symbol __dso_handle which is resolved to NULL if
525 referenced from a statically linked module. We need to mimic this, but
526 we cannot use NULL because we use it to mean nonexistent symbols. So we
527 use an arbitrary (hopefully unique) address here.
528 */
529 if (! ghciInsertSymbolTable(WSTR("(GHCi special symbols)"),
530 symhash, "__dso_handle", (void *)0x12345687, HS_BOOL_FALSE, NULL)) {
531 barf("ghciInsertSymbolTable failed");
532 }
533
534 // Redirect newCAF to newRetainedCAF if retain_cafs is true.
535 if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"), symhash,
536 MAYBE_LEADING_UNDERSCORE_STR("newCAF"),
537 retain_cafs ? newRetainedCAF : newGCdCAF,
538 HS_BOOL_FALSE, NULL)) {
539 barf("ghciInsertSymbolTable failed");
540 }
541
542 # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
543 # if defined(RTLD_DEFAULT)
544 dl_prog_handle = RTLD_DEFAULT;
545 # else
546 dl_prog_handle = dlopen(NULL, RTLD_LAZY);
547 # endif /* RTLD_DEFAULT */
548
549 compileResult = regcomp(&re_invalid,
550 "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)",
551 REG_EXTENDED);
552 if (compileResult != 0) {
553 barf("Compiling re_invalid failed");
554 }
555 compileResult = regcomp(&re_realso,
556 "(GROUP|INPUT) *\\( *([^ )]+)",
557 REG_EXTENDED);
558 if (compileResult != 0) {
559 barf("Compiling re_realso failed");
560 }
561 # endif
562
563 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
564 if (RtsFlags.MiscFlags.linkerMemBase != 0) {
565 // User-override for mmap_32bit_base
566 mmap_32bit_base = (void*)RtsFlags.MiscFlags.linkerMemBase;
567 }
568 #endif
569
570 #if defined(mingw32_HOST_OS)
571 /*
572 * These two libraries cause problems when added to the static link,
573 * but are necessary for resolving symbols in GHCi, hence we load
574 * them manually here.
575 */
576 addDLL(WSTR("msvcrt"));
577 addDLL(WSTR("kernel32"));
578 addDLLHandle(WSTR("*.exe"), GetModuleHandle(NULL));
579 #endif
580
581 #ifdef USE_MMAP
582 m32_allocator_init(&allocator);
583 #endif
584
585 IF_DEBUG(linker, debugBelch("initLinker: done\n"));
586 return;
587 }
588
589 void
590 exitLinker( void ) {
591 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
592 if (linker_init_done == 1) {
593 regfree(&re_invalid);
594 regfree(&re_realso);
595 #ifdef THREADED_RTS
596 closeMutex(&dl_mutex);
597 #endif
598 }
599 #endif
600 if (linker_init_done == 1) {
601 freeHashTable(symhash, free);
602 }
603 #ifdef THREADED_RTS
604 closeMutex(&linker_mutex);
605 #endif
606 }
607
608 /* -----------------------------------------------------------------------------
609 * Loading DLL or .so dynamic libraries
610 * -----------------------------------------------------------------------------
611 *
612 * Add a DLL from which symbols may be found. In the ELF case, just
613 * do RTLD_GLOBAL-style add, so no further messing around needs to
614 * happen in order that symbols in the loaded .so are findable --
615 * lookupSymbol() will subsequently see them by dlsym on the program's
616 * dl-handle. Returns NULL if success, otherwise ptr to an err msg.
617 *
618 * In the PEi386 case, open the DLLs and put handles to them in a
619 * linked list. When looking for a symbol, try all handles in the
620 * list. This means that we need to load even DLLs that are guaranteed
621 * to be in the ghc.exe image already, just so we can get a handle
622 * to give to loadSymbol, so that we can find the symbols. For such
623 * libraries, the LoadLibrary call should be a no-op except for returning
624 * the handle.
625 *
626 */
627
628 #if defined(OBJFORMAT_PEi386)
629 /* A record for storing handles into DLLs. */
630
631 typedef
632 struct _OpenedDLL {
633 pathchar* name;
634 struct _OpenedDLL* next;
635 HINSTANCE instance;
636 }
637 OpenedDLL;
638
639 /* A list thereof. */
640 static OpenedDLL* opened_dlls = NULL;
641
642 /* A record for storing indirectly linked functions from DLLs. */
643 typedef
644 struct _IndirectAddr {
645 void* addr;
646 struct _IndirectAddr* next;
647 }
648 IndirectAddr;
649
650 /* A list thereof. */
651 static IndirectAddr* indirects = NULL;
652
653 /* Adds a DLL instance to the list of DLLs in which to search for symbols. */
654 void addDLLHandle(pathchar* dll_name, HINSTANCE instance) {
655 OpenedDLL* o_dll;
656 o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLLHandle" );
657 o_dll->name = dll_name ? pathdup(dll_name) : NULL;
658 o_dll->instance = instance;
659 o_dll->next = opened_dlls;
660 opened_dlls = o_dll;
661 }
662
663 #endif
664
665 # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
666
667 /* Suppose in ghci we load a temporary SO for a module containing
668 f = 1
669 and then modify the module, recompile, and load another temporary
670 SO with
671 f = 2
672 Then as we don't unload the first SO, dlsym will find the
673 f = 1
674 symbol whereas we want the
675 f = 2
676 symbol. We therefore need to keep our own SO handle list, and
677 try SOs in the right order. */
678
679 typedef
680 struct _OpenedSO {
681 struct _OpenedSO* next;
682 void *handle;
683 }
684 OpenedSO;
685
686 /* A list thereof. */
687 static OpenedSO* openedSOs = NULL;
688
689 static const char *
690 internal_dlopen(const char *dll_name)
691 {
692 OpenedSO* o_so;
693 void *hdl;
694 const char *errmsg;
695 char *errmsg_copy;
696
697 // omitted: RTLD_NOW
698 // see http://www.haskell.org/pipermail/cvs-ghc/2007-September/038570.html
699 IF_DEBUG(linker,
700 debugBelch("internal_dlopen: dll_name = '%s'\n", dll_name));
701
702 //-------------- Begin critical section ------------------
703 // This critical section is necessary because dlerror() is not
704 // required to be reentrant (see POSIX -- IEEE Std 1003.1-2008)
705 // Also, the error message returned must be copied to preserve it
706 // (see POSIX also)
707
708 ACQUIRE_LOCK(&dl_mutex);
709 hdl = dlopen(dll_name, RTLD_LAZY|RTLD_LOCAL); /* see Note [RTLD_LOCAL] */
710
711 errmsg = NULL;
712 if (hdl == NULL) {
713 /* dlopen failed; return a ptr to the error msg. */
714 errmsg = dlerror();
715 if (errmsg == NULL) errmsg = "addDLL: unknown error";
716 errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL");
717 strcpy(errmsg_copy, errmsg);
718 errmsg = errmsg_copy;
719 } else {
720 o_so = stgMallocBytes(sizeof(OpenedSO), "addDLL");
721 o_so->handle = hdl;
722 o_so->next = openedSOs;
723 openedSOs = o_so;
724 }
725
726 RELEASE_LOCK(&dl_mutex);
727 //--------------- End critical section -------------------
728
729 return errmsg;
730 }
731
732 /*
733 Note [RTLD_LOCAL]
734
735 In GHCi we want to be able to override previous .so's with newly
736 loaded .so's when we recompile something. This further implies that
737 when we look up a symbol in internal_dlsym() we have to iterate
738 through the loaded libraries (in order from most recently loaded to
739 oldest) looking up the symbol in each one until we find it.
740
741 However, this can cause problems for some symbols that are copied
742 by the linker into the executable image at runtime - see #8935 for a
743 lengthy discussion. To solve that problem we need to look up
744 symbols in the main executable *first*, before attempting to look
745 them up in the loaded .so's. But in order to make that work, we
746 have to always call dlopen with RTLD_LOCAL, so that the loaded
747 libraries don't populate the global symbol table.
748 */
749
750 static void *
751 internal_dlsym(const char *symbol) {
752 OpenedSO* o_so;
753 void *v;
754
755 // We acquire dl_mutex as concurrent dl* calls may alter dlerror
756 ACQUIRE_LOCK(&dl_mutex);
757 dlerror();
758 // look in program first
759 v = dlsym(dl_prog_handle, symbol);
760 if (dlerror() == NULL) {
761 RELEASE_LOCK(&dl_mutex);
762 return v;
763 }
764
765 for (o_so = openedSOs; o_so != NULL; o_so = o_so->next) {
766 v = dlsym(o_so->handle, symbol);
767 if (dlerror() == NULL) {
768 RELEASE_LOCK(&dl_mutex);
769 return v;
770 }
771 }
772 RELEASE_LOCK(&dl_mutex);
773 return v;
774 }
775 # endif
776
777 const char *
778 addDLL( pathchar *dll_name )
779 {
780 # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
781 /* ------------------- ELF DLL loader ------------------- */
782
783 #define NMATCH 5
784 regmatch_t match[NMATCH];
785 const char *errmsg;
786 FILE* fp;
787 size_t match_length;
788 #define MAXLINE 1000
789 char line[MAXLINE];
790 int result;
791
792 IF_DEBUG(linker, debugBelch("addDLL: dll_name = '%s'\n", dll_name));
793 errmsg = internal_dlopen(dll_name);
794
795 if (errmsg == NULL) {
796 return NULL;
797 }
798
799 // GHC Trac ticket #2615
800 // On some systems (e.g., Gentoo Linux) dynamic files (e.g. libc.so)
801 // contain linker scripts rather than ELF-format object code. This
802 // code handles the situation by recognizing the real object code
803 // file name given in the linker script.
804 //
805 // If an "invalid ELF header" error occurs, it is assumed that the
806 // .so file contains a linker script instead of ELF object code.
807 // In this case, the code looks for the GROUP ( ... ) linker
808 // directive. If one is found, the first file name inside the
809 // parentheses is treated as the name of a dynamic library and the
810 // code attempts to dlopen that file. If this is also unsuccessful,
811 // an error message is returned.
812
813 // see if the error message is due to an invalid ELF header
814 IF_DEBUG(linker, debugBelch("errmsg = '%s'\n", errmsg));
815 result = regexec(&re_invalid, errmsg, (size_t) NMATCH, match, 0);
816 IF_DEBUG(linker, debugBelch("result = %i\n", result));
817 if (result == 0) {
818 // success -- try to read the named file as a linker script
819 match_length = (size_t) stg_min((match[1].rm_eo - match[1].rm_so),
820 MAXLINE-1);
821 strncpy(line, (errmsg+(match[1].rm_so)),match_length);
822 line[match_length] = '\0'; // make sure string is null-terminated
823 IF_DEBUG(linker, debugBelch ("file name = '%s'\n", line));
824 if ((fp = fopen(line, "r")) == NULL) {
825 return errmsg; // return original error if open fails
826 }
827 // try to find a GROUP or INPUT ( ... ) command
828 while (fgets(line, MAXLINE, fp) != NULL) {
829 IF_DEBUG(linker, debugBelch("input line = %s", line));
830 if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) {
831 // success -- try to dlopen the first named file
832 IF_DEBUG(linker, debugBelch("match%s\n",""));
833 line[match[2].rm_eo] = '\0';
834 stgFree((void*)errmsg); // Free old message before creating new one
835 errmsg = internal_dlopen(line+match[2].rm_so);
836 break;
837 }
838 // if control reaches here, no GROUP or INPUT ( ... ) directive
839 // was found and the original error message is returned to the
840 // caller
841 }
842 fclose(fp);
843 }
844 return errmsg;
845
846 # elif defined(OBJFORMAT_PEi386)
847 /* ------------------- Win32 DLL loader ------------------- */
848
849 pathchar* buf;
850 OpenedDLL* o_dll;
851 HINSTANCE instance;
852
853 /* debugBelch("\naddDLL; dll_name = `%s'\n", dll_name); */
854
855 /* See if we've already got it, and ignore if so. */
856 for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
857 if (0 == pathcmp(o_dll->name, dll_name))
858 return NULL;
859 }
860
861 /* The file name has no suffix (yet) so that we can try
862 both foo.dll and foo.drv
863
864 The documentation for LoadLibrary says:
865 If no file name extension is specified in the lpFileName
866 parameter, the default library extension .dll is
867 appended. However, the file name string can include a trailing
868 point character (.) to indicate that the module name has no
869 extension. */
870
871 size_t bufsize = pathlen(dll_name) + 10;
872 buf = stgMallocBytes(bufsize * sizeof(wchar_t), "addDLL");
873 snwprintf(buf, bufsize, L"%s.DLL", dll_name);
874 instance = LoadLibraryW(buf);
875 if (instance == NULL) {
876 if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
877 // KAA: allow loading of drivers (like winspool.drv)
878 snwprintf(buf, bufsize, L"%s.DRV", dll_name);
879 instance = LoadLibraryW(buf);
880 if (instance == NULL) {
881 if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
882 // #1883: allow loading of unix-style libfoo.dll DLLs
883 snwprintf(buf, bufsize, L"lib%s.DLL", dll_name);
884 instance = LoadLibraryW(buf);
885 if (instance == NULL) {
886 goto error;
887 }
888 }
889 }
890 stgFree(buf);
891
892 addDLLHandle(dll_name, instance);
893
894 return NULL;
895
896 error:
897 stgFree(buf);
898 sysErrorBelch("%" PATH_FMT, dll_name);
899
900 /* LoadLibrary failed; return a ptr to the error msg. */
901 return "addDLL: could not load DLL";
902
903 # else
904 barf("addDLL: not implemented on this platform");
905 # endif
906 }
907
908 /* -----------------------------------------------------------------------------
909 * insert a symbol in the hash table
910 *
911 * Returns: 0 on failure, nozero on success
912 */
913 HsInt insertSymbol(pathchar* obj_name, char* key, void* data)
914 {
915 return ghciInsertSymbolTable(obj_name, symhash, key, data, HS_BOOL_FALSE, NULL);
916 }
917
918 /* -----------------------------------------------------------------------------
919 * lookup a symbol in the hash table
920 */
921 static void* lookupSymbol_ (char *lbl)
922 {
923 void *val;
924 IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s\n", lbl));
925
926 ASSERT(symhash != NULL);
927
928 if (!ghciLookupSymbolTable(symhash, lbl, &val)) {
929 IF_DEBUG(linker, debugBelch("lookupSymbol: symbol not found\n"));
930 # if defined(OBJFORMAT_ELF)
931 return internal_dlsym(lbl);
932 # elif defined(OBJFORMAT_MACHO)
933 # if HAVE_DLFCN_H
934 /* On OS X 10.3 and later, we use dlsym instead of the old legacy
935 interface.
936
937 HACK: On OS X, all symbols are prefixed with an underscore.
938 However, dlsym wants us to omit the leading underscore from the
939 symbol name -- the dlsym routine puts it back on before searching
940 for the symbol. For now, we simply strip it off here (and ONLY
941 here).
942 */
943 IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s with dlsym\n", lbl));
944 ASSERT(lbl[0] == '_');
945 return internal_dlsym(lbl + 1);
946 # else
947 if (NSIsSymbolNameDefined(lbl)) {
948 NSSymbol symbol = NSLookupAndBindSymbol(lbl);
949 return NSAddressOfSymbol(symbol);
950 } else {
951 return NULL;
952 }
953 # endif /* HAVE_DLFCN_H */
954 # elif defined(OBJFORMAT_PEi386)
955 void* sym;
956
957 /* See Note [mingw-w64 name decoration scheme] */
958 #ifndef x86_64_HOST_ARCH
959 zapTrailingAtSign ( (unsigned char*)lbl );
960 #endif
961 sym = lookupSymbolInDLLs((unsigned char*)lbl);
962 return sym; // might be NULL if not found
963
964 # else
965 ASSERT(2+2 == 5);
966 return NULL;
967 # endif
968 } else {
969 IF_DEBUG(linker, debugBelch("lookupSymbol: value of %s is %p\n", lbl, val));
970 return val;
971 }
972 }
973
974 void* lookupSymbol( char *lbl )
975 {
976 ACQUIRE_LOCK(&linker_mutex);
977 char *r = lookupSymbol_(lbl);
978 RELEASE_LOCK(&linker_mutex);
979 return r;
980 }
981
982 /* -----------------------------------------------------------------------------
983 Create a StablePtr for a foreign export. This is normally called by
984 a C function with __attribute__((constructor)), which is generated
985 by GHC and linked into the module.
986
987 If the object code is being loaded dynamically, then we remember
988 which StablePtrs were allocated by the constructors and free them
989 again in unloadObj().
990 -------------------------------------------------------------------------- */
991
992 static ObjectCode *loading_obj = NULL;
993
994 StgStablePtr foreignExportStablePtr (StgPtr p)
995 {
996 ForeignExportStablePtr *fe_sptr;
997 StgStablePtr *sptr;
998
999 sptr = getStablePtr(p);
1000
1001 if (loading_obj != NULL) {
1002 fe_sptr = stgMallocBytes(sizeof(ForeignExportStablePtr),
1003 "foreignExportStablePtr");
1004 fe_sptr->stable_ptr = sptr;
1005 fe_sptr->next = loading_obj->stable_ptrs;
1006 loading_obj->stable_ptrs = fe_sptr;
1007 }
1008
1009 return sptr;
1010 }
1011
1012
1013 /* -----------------------------------------------------------------------------
1014 * Debugging aid: look in GHCi's object symbol tables for symbols
1015 * within DELTA bytes of the specified address, and show their names.
1016 */
1017 #ifdef DEBUG
1018 void ghci_enquire ( char* addr );
1019
1020 void ghci_enquire ( char* addr )
1021 {
1022 int i;
1023 char* sym;
1024 char* a;
1025 const int DELTA = 64;
1026 ObjectCode* oc;
1027
1028 for (oc = objects; oc; oc = oc->next) {
1029 for (i = 0; i < oc->n_symbols; i++) {
1030 sym = oc->symbols[i];
1031 if (sym == NULL) continue;
1032 a = NULL;
1033 if (a == NULL) {
1034 ghciLookupSymbolTable(symhash, sym, (void **)&a);
1035 }
1036 if (a == NULL) {
1037 // debugBelch("ghci_enquire: can't find %s\n", sym);
1038 }
1039 else if (addr-DELTA <= a && a <= addr+DELTA) {
1040 debugBelch("%p + %3d == `%s'\n", addr, (int)(a - addr), sym);
1041 }
1042 }
1043 }
1044 }
1045 #endif
1046
1047 #ifdef USE_MMAP
1048 #define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))
1049 #define ROUND_DOWN(x,size) (x & ~(size - 1))
1050
1051 static StgWord getPageSize(void)
1052 {
1053 static StgWord pagesize = 0;
1054 if (pagesize == 0) {
1055 pagesize = sysconf(_SC_PAGESIZE);
1056 }
1057 return pagesize;
1058 }
1059
1060 static StgWord roundUpToPage (StgWord size)
1061 {
1062 return ROUND_UP(size, getPageSize());
1063 }
1064
1065 #ifdef OBJFORMAT_ELF
1066 static StgWord roundDownToPage (StgWord size)
1067 {
1068 return ROUND_DOWN(size, getPageSize());
1069 }
1070 #endif
1071
1072 //
1073 // Returns NULL on failure.
1074 //
1075 static void * mmapForLinker (size_t bytes, nat flags, int fd, int offset)
1076 {
1077 void *map_addr = NULL;
1078 void *result;
1079 StgWord size;
1080 static nat fixed = 0;
1081
1082 IF_DEBUG(linker, debugBelch("mmapForLinker: start\n"));
1083 size = roundUpToPage(bytes);
1084
1085 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1086 mmap_again:
1087
1088 if (mmap_32bit_base != 0) {
1089 map_addr = mmap_32bit_base;
1090 }
1091 #endif
1092
1093 IF_DEBUG(linker,
1094 debugBelch("mmapForLinker: \tprotection %#0x\n",
1095 PROT_EXEC | PROT_READ | PROT_WRITE));
1096 IF_DEBUG(linker,
1097 debugBelch("mmapForLinker: \tflags %#0x\n",
1098 MAP_PRIVATE | TRY_MAP_32BIT | fixed | flags));
1099
1100 result = mmap(map_addr, size,
1101 PROT_EXEC|PROT_READ|PROT_WRITE,
1102 MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, offset);
1103
1104 if (result == MAP_FAILED) {
1105 sysErrorBelch("mmap %" FMT_Word " bytes at %p",(W_)size,map_addr);
1106 errorBelch("Try specifying an address with +RTS -xm<addr> -RTS");
1107 return NULL;
1108 }
1109
1110 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1111 if (mmap_32bit_base != 0) {
1112 if (result == map_addr) {
1113 mmap_32bit_base = (StgWord8*)map_addr + size;
1114 } else {
1115 if ((W_)result > 0x80000000) {
1116 // oops, we were given memory over 2Gb
1117 munmap(result,size);
1118 #if defined(freebsd_HOST_OS) || \
1119 defined(kfreebsdgnu_HOST_OS) || \
1120 defined(dragonfly_HOST_OS)
1121 // Some platforms require MAP_FIXED. This is normally
1122 // a bad idea, because MAP_FIXED will overwrite
1123 // existing mappings.
1124 fixed = MAP_FIXED;
1125 goto mmap_again;
1126 #else
1127 errorBelch("loadObj: failed to mmap() memory below 2Gb; "
1128 "asked for %lu bytes at %p. "
1129 "Try specifying an address with +RTS -xm<addr> -RTS",
1130 size, map_addr);
1131 return NULL;
1132 #endif
1133 } else {
1134 // hmm, we were given memory somewhere else, but it's
1135 // still under 2Gb so we can use it. Next time, ask
1136 // for memory right after the place we just got some
1137 mmap_32bit_base = (StgWord8*)result + size;
1138 }
1139 }
1140 } else {
1141 if ((W_)result > 0x80000000) {
1142 // oops, we were given memory over 2Gb
1143 // ... try allocating memory somewhere else?;
1144 debugTrace(DEBUG_linker,
1145 "MAP_32BIT didn't work; gave us %lu bytes at 0x%p",
1146 bytes, result);
1147 munmap(result, size);
1148
1149 // Set a base address and try again... (guess: 1Gb)
1150 mmap_32bit_base = (void*)0x40000000;
1151 goto mmap_again;
1152 }
1153 }
1154 #endif
1155
1156 IF_DEBUG(linker,
1157 debugBelch("mmapForLinker: mapped %" FMT_Word
1158 " bytes starting at %p\n", (W_)size, result));
1159 IF_DEBUG(linker,
1160 debugBelch("mmapForLinker: done\n"));
1161
1162 return result;
1163 }
1164
1165 /*
1166
1167 Note [M32 Allocator]
1168 ~~~~~~~~~~~~~~~~~~~~
1169
1170 A memory allocator that allocates only pages in the 32-bit range (lower 2GB).
1171 This is useful on 64-bit platforms to ensure that addresses of allocated
1172 objects can be referenced with a 32-bit relative offset.
1173
1174 Initially, the linker used `mmap` to allocate a page per object. Hence it
1175 wasted a lot of space for small objects (see #9314). With this allocator, we
1176 try to fill pages as much as we can for small objects.
1177
1178 How does it work?
1179 -----------------
1180
1181 For small objects, a Word64 counter is added at the beginning of the page they
1182 are stored in. It indicates the number of objects that are still alive in the
1183 page. When the counter drops down to zero, the page is freed. The counter is
1184 atomically decremented, hence the deallocation is thread-safe.
1185
1186 During the allocation phase, the allocator keeps track of some pages that are
1187 not totally filled: the number of pages in the "filling" list is configurable
1188 with M32_MAX_PAGES. Allocation consists in finding some place in one of these
1189 pages or starting a new one, then increasing the page counter. If none of the
1190 pages in the "filling" list has enough free space, the most filled one is
1191 flushed (see below) and a new one is allocated.
1192
1193 The allocator holds a reference on pages in the "filling" list: the counter in
1194 these pages is 1+n where n is the current number of objects allocated in the
1195 page. Hence allocated objects can be freed while the allocator is using
1196 (filling) the page. Flushing a page consists in decreasing its counter and
1197 removing it from the "filling" list. By extension, flushing the allocator
1198 consists in flushing all the pages in the "filling" list. Don't forget to
1199 flush the allocator at the end of the allocation phase in order to avoid space
1200 leaks!
1201
1202 Large objects are objects that are larger than a page (minus the bytes required
1203 for the counter and the optional padding). These objects are allocated into
1204 their own set of pages. We can differentiate large and small objects from
1205 their address: large objects are aligned on page size while small objects never
1206 are (because of the space reserved for the page's object counter).
1207
1208 For large objects, the remaining space at the end of the last page is left
1209 unused by the allocator. It can be used with care as it will be freed with the
1210 associated large object. GHC linker uses this feature/hack, hence changing the
1211 implementation of the M32 allocator must be done with care (i.e. do not try to
1212 improve the allocator to avoid wasting this space without modifying the linker
1213 code accordingly).
1214
1215 Object allocation is *not* thread-safe (however it could be done easily with a
1216 lock in the allocator structure). Object deallocation is thread-safe.
1217
1218 */
1219
1220 /****************************************************************************
1221 * M32 ALLOCATOR (see Note [M32 Allocator]
1222 ***************************************************************************/
1223
1224 /**
1225 * Wrapper for `unmap` that handles error cases.
1226 */
1227 static void munmapForLinker (void * addr, size_t size)
1228 {
1229 int r = munmap(addr,size);
1230 if (r == -1) {
1231 // Should we abort here?
1232 sysErrorBelch("munmap");
1233 }
1234 }
1235
1236 /**
1237 * Initialize the allocator structure
1238 */
1239 static void m32_allocator_init(m32_allocator m32) {
1240 memset(m32, 0, sizeof(struct m32_allocator_t));
1241 }
1242
1243 /**
1244 * Atomically decrement the object counter on the given page and release the
1245 * page if necessary. The given address must be the *base address* of the page.
1246 *
1247 * You shouldn't have to use this method. Use `m32_free` instead.
1248 */
1249 static void m32_free_internal(void * addr) {
1250 uint64_t c = __sync_sub_and_fetch((uint64_t*)addr, 1);
1251 if (c == 0) {
1252 munmapForLinker(addr, getPageSize());
1253 }
1254 }
1255
1256 /**
1257 * Release the allocator's reference to pages on the "filling" list. This
1258 * should be called when it is believed that no more allocations will be needed
1259 * from the allocator to ensure that empty pages waiting to be filled aren't
1260 * unnecessarily held.
1261 */
1262 static void m32_allocator_flush(m32_allocator m32) {
1263 int i;
1264 for (i=0; i<M32_MAX_PAGES; i++) {
1265 void * addr = __sync_fetch_and_and(&m32->pages[i].base_addr, 0x0);
1266 if (addr != 0) {
1267 m32_free_internal(addr);
1268 }
1269 }
1270 }
1271
1272 // Return true if the object has its own dedicated set of pages
1273 #define m32_is_large_object(size,alignment) \
1274 (size >= getPageSize() - ROUND_UP(8,alignment))
1275
1276 // Return true if the object has its own dedicated set of pages
1277 #define m32_is_large_object_addr(addr) \
1278 ((uintptr_t) addr % getPageSize() == 0)
1279
1280 /**
1281 * Free the memory associated with an object.
1282 *
1283 * If the object is "small", the object counter of the page it is allocated in
1284 * is decremented and the page is not freed until all of its objects are freed.
1285 */
1286 static void m32_free(void *addr, unsigned int size) {
1287 uintptr_t m = (uintptr_t) addr % getPageSize();
1288
1289 if (m == 0) {
1290 // large object
1291 munmapForLinker(addr,ROUND_UP(size,getPageSize()));
1292 }
1293 else {
1294 // small object
1295 void * page_addr = (void*)((uintptr_t)addr - m);
1296 m32_free_internal(page_addr);
1297 }
1298 }
1299
1300 /**
1301 * Allocate `size` bytes of memory with the given alignment
1302 */
1303 static void *
1304 m32_alloc(m32_allocator m32, unsigned int size,
1305 unsigned int alignment) {
1306
1307 unsigned int pgsz = (unsigned int)getPageSize();
1308
1309 if (m32_is_large_object(size,alignment)) {
1310 // large object
1311 return mmapForLinker(size,MAP_ANONYMOUS,-1,0);
1312 }
1313 else {
1314 // small object
1315 // Try to find a page that can contain it
1316 int empty = -1;
1317 int most_filled = -1;
1318 int i;
1319 for (i=0; i<M32_MAX_PAGES; i++) {
1320 // empty page
1321 if (m32->pages[i].base_addr == 0) {
1322 empty = empty == -1 ? i : empty;
1323 continue;
1324 }
1325 // page can contain the buffer?
1326 unsigned int alsize = ROUND_UP(m32->pages[i].current_size, alignment);
1327 if (size <= pgsz - alsize) {
1328 void * addr = (char*)m32->pages[i].base_addr + alsize;
1329 m32->pages[i].current_size = alsize + size;
1330 // increment the counter atomically
1331 __sync_fetch_and_add((uint64_t*)m32->pages[i].base_addr, 1);
1332 return addr;
1333 }
1334 // most filled?
1335 if (most_filled == -1
1336 || m32->pages[most_filled].current_size < m32->pages[i].current_size)
1337 {
1338 most_filled = i;
1339 }
1340 }
1341
1342 // If we haven't found an empty page, flush the most filled one
1343 if (empty == -1) {
1344 m32_free_internal(m32->pages[most_filled].base_addr);
1345 m32->pages[most_filled].base_addr = 0;
1346 m32->pages[most_filled].current_size = 0;
1347 empty = most_filled;
1348 }
1349
1350 // Allocate a new page
1351 void * addr = mmapForLinker(pgsz,MAP_ANONYMOUS,-1,0);
1352 if (addr == NULL) {
1353 return NULL;
1354 }
1355 m32->pages[empty].base_addr = addr;
1356 // Add 8 bytes for the counter + padding
1357 m32->pages[empty].current_size = size+ROUND_UP(8,alignment);
1358 // Initialize the counter:
1359 // 1 for the allocator + 1 for the returned allocated memory
1360 *((uint64_t*)addr) = 2;
1361 return (char*)addr + ROUND_UP(8,alignment);
1362 }
1363 }
1364
1365 /****************************************************************************
1366 * END (M32 ALLOCATOR)
1367 ***************************************************************************/
1368
1369 #endif // USE_MMAP
1370
1371 /*
1372 * Remove symbols from the symbol table, and free oc->symbols.
1373 * This operation is idempotent.
1374 */
1375 static void removeOcSymbols (ObjectCode *oc)
1376 {
1377 if (oc->symbols == NULL) return;
1378
1379 // Remove all the mappings for the symbols within this object..
1380 int i;
1381 for (i = 0; i < oc->n_symbols; i++) {
1382 if (oc->symbols[i] != NULL) {
1383 ghciRemoveSymbolTable(symhash, oc->symbols[i], oc);
1384 }
1385 }
1386
1387 stgFree(oc->symbols);
1388 oc->symbols = NULL;
1389 }
1390
1391 /*
1392 * Release StablePtrs and free oc->stable_ptrs.
1393 * This operation is idempotent.
1394 */
1395 static void freeOcStablePtrs (ObjectCode *oc)
1396 {
1397 // Release any StablePtrs that were created when this
1398 // object module was initialized.
1399 ForeignExportStablePtr *fe_ptr, *next;
1400
1401 for (fe_ptr = oc->stable_ptrs; fe_ptr != NULL; fe_ptr = next) {
1402 next = fe_ptr->next;
1403 freeStablePtr(fe_ptr->stable_ptr);
1404 stgFree(fe_ptr);
1405 }
1406 oc->stable_ptrs = NULL;
1407 }
1408
1409 static void
1410 freePreloadObjectFile (ObjectCode *oc)
1411 {
1412 #ifdef USE_MMAP
1413
1414 if (oc->imageMapped) {
1415 munmap(oc->image, oc->fileSize);
1416 } else {
1417 stgFree(oc->image);
1418 }
1419
1420 #elif defined(mingw32_HOST_OS)
1421
1422 VirtualFree(oc->image - PEi386_IMAGE_OFFSET, 0, MEM_RELEASE);
1423
1424 IndirectAddr *ia, *ia_next;
1425 ia = indirects;
1426 while (ia != NULL) {
1427 ia_next = ia->next;
1428 stgFree(ia);
1429 ia = ia_next;
1430 }
1431 indirects = NULL;
1432
1433 #else
1434
1435 stgFree(oc->image);
1436
1437 #endif
1438
1439 oc->image = NULL;
1440 oc->fileSize = 0;
1441 }
1442
1443 /*
1444 * freeObjectCode() releases all the pieces of an ObjectCode. It is called by
1445 * the GC when a previously unloaded ObjectCode has been determined to be
1446 * unused, and when an error occurs during loadObj().
1447 */
1448 void freeObjectCode (ObjectCode *oc)
1449 {
1450 freePreloadObjectFile(oc);
1451
1452 if (oc->symbols != NULL) {
1453 stgFree(oc->symbols);
1454 oc->symbols = NULL;
1455 }
1456
1457 if (oc->sections != NULL) {
1458 int i;
1459 for (i=0; i < oc->n_sections; i++) {
1460 if (oc->sections[i].start != NULL) {
1461 switch(oc->sections[i].alloc){
1462 #ifdef USE_MMAP
1463 case SECTION_MMAP:
1464 munmap(oc->sections[i].mapped_start,
1465 oc->sections[i].mapped_size);
1466 break;
1467 case SECTION_M32:
1468 m32_free(oc->sections[i].start,
1469 oc->sections[i].size);
1470 break;
1471 #endif
1472 case SECTION_MALLOC:
1473 stgFree(oc->sections[i].start);
1474 break;
1475 default:
1476 break;
1477 }
1478 }
1479 }
1480 stgFree(oc->sections);
1481 }
1482
1483 freeProddableBlocks(oc);
1484
1485 /* Free symbol_extras. On x86_64 Windows, symbol_extras are allocated
1486 * alongside the image, so we don't need to free. */
1487 #if NEED_SYMBOL_EXTRAS && (!defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS))
1488 #ifdef USE_MMAP
1489 if (!USE_CONTIGUOUS_MMAP && oc->symbol_extras != NULL)
1490 {
1491 m32_free(oc->symbol_extras, sizeof(SymbolExtra) * oc->n_symbol_extras);
1492 }
1493 #else // !USE_MMAP
1494 stgFree(oc->symbol_extras);
1495 #endif
1496 #endif
1497
1498 stgFree(oc->fileName);
1499 stgFree(oc->archiveMemberName);
1500 stgFree(oc);
1501 }
1502
1503
1504 static ObjectCode*
1505 mkOc( pathchar *path, char *image, int imageSize,
1506 rtsBool mapped, char *archiveMemberName
1507 #ifndef USE_MMAP
1508 #ifdef darwin_HOST_OS
1509 , int misalignment
1510 #endif
1511 #endif
1512 ) {
1513 ObjectCode* oc;
1514
1515 IF_DEBUG(linker, debugBelch("mkOc: start\n"));
1516 oc = stgMallocBytes(sizeof(ObjectCode), "mkOc(oc)");
1517
1518 # if defined(OBJFORMAT_ELF)
1519 oc->formatName = "ELF";
1520 # elif defined(OBJFORMAT_PEi386)
1521 oc->formatName = "PEi386";
1522 # elif defined(OBJFORMAT_MACHO)
1523 oc->formatName = "Mach-O";
1524 # else
1525 stgFree(oc);
1526 barf("loadObj: not implemented on this platform");
1527 # endif
1528
1529 oc->image = image;
1530 oc->fileName = pathdup(path);
1531
1532 if (archiveMemberName) {
1533 oc->archiveMemberName = stgMallocBytes( strlen(archiveMemberName)+1, "loadObj" );
1534 strcpy(oc->archiveMemberName, archiveMemberName);
1535 }
1536 else {
1537 oc->archiveMemberName = NULL;
1538 }
1539
1540 oc->fileSize = imageSize;
1541 oc->symbols = NULL;
1542 oc->n_sections = 0;
1543 oc->sections = NULL;
1544 oc->proddables = NULL;
1545 oc->stable_ptrs = NULL;
1546 #if NEED_SYMBOL_EXTRAS
1547 oc->symbol_extras = NULL;
1548 #endif
1549 oc->imageMapped = mapped;
1550
1551 #ifndef USE_MMAP
1552 #ifdef darwin_HOST_OS
1553 oc->misalignment = misalignment;
1554 #endif
1555 #endif
1556
1557 /* chain it onto the list of objects */
1558 oc->next = NULL;
1559
1560 IF_DEBUG(linker, debugBelch("mkOc: done\n"));
1561 return oc;
1562 }
1563
1564 /* -----------------------------------------------------------------------------
1565 * Check if an object or archive is already loaded.
1566 *
1567 * Returns: 1 if the path is already loaded, 0 otherwise.
1568 */
1569 static HsInt
1570 isAlreadyLoaded( pathchar *path )
1571 {
1572 ObjectCode *o;
1573 for (o = objects; o; o = o->next) {
1574 if (0 == pathcmp(o->fileName, path)) {
1575 return 1; /* already loaded */
1576 }
1577 }
1578 return 0; /* not loaded yet */
1579 }
1580
1581 static HsInt loadArchive_ (pathchar *path)
1582 {
1583 ObjectCode* oc;
1584 char *image;
1585 int memberSize;
1586 FILE *f;
1587 int n;
1588 size_t thisFileNameSize;
1589 char *fileName;
1590 size_t fileNameSize;
1591 int isObject, isGnuIndex, isThin;
1592 char tmp[20];
1593 char *gnuFileIndex;
1594 int gnuFileIndexSize;
1595 #if defined(darwin_HOST_OS)
1596 int i;
1597 uint32_t nfat_arch, nfat_offset, cputype, cpusubtype;
1598 #if defined(i386_HOST_ARCH)
1599 const uint32_t mycputype = CPU_TYPE_X86;
1600 const uint32_t mycpusubtype = CPU_SUBTYPE_X86_ALL;
1601 #elif defined(x86_64_HOST_ARCH)
1602 const uint32_t mycputype = CPU_TYPE_X86_64;
1603 const uint32_t mycpusubtype = CPU_SUBTYPE_X86_64_ALL;
1604 #elif defined(powerpc_HOST_ARCH)
1605 const uint32_t mycputype = CPU_TYPE_POWERPC;
1606 const uint32_t mycpusubtype = CPU_SUBTYPE_POWERPC_ALL;
1607 #elif defined(powerpc64_HOST_ARCH)
1608 const uint32_t mycputype = CPU_TYPE_POWERPC64;
1609 const uint32_t mycpusubtype = CPU_SUBTYPE_POWERPC_ALL;
1610 #else
1611 #error Unknown Darwin architecture
1612 #endif
1613 #if !defined(USE_MMAP)
1614 int misalignment;
1615 #endif
1616 #endif
1617
1618 /* TODO: don't call barf() on error, instead return an error code, freeing
1619 * all resources correctly. This function is pretty complex, so it needs
1620 * to be refactored to make this practical. */
1621
1622 IF_DEBUG(linker, debugBelch("loadArchive: start\n"));
1623 IF_DEBUG(linker, debugBelch("loadArchive: Loading archive `%" PATH_FMT" '\n", path));
1624
1625 /* Check that we haven't already loaded this archive.
1626 Ignore requests to load multiple times */
1627 if (isAlreadyLoaded(path)) {
1628 IF_DEBUG(linker,
1629 debugBelch("ignoring repeated load of %" PATH_FMT "\n", path));
1630 return 1; /* success */
1631 }
1632
1633 gnuFileIndex = NULL;
1634 gnuFileIndexSize = 0;
1635
1636 fileNameSize = 32;
1637 fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)");
1638
1639 isThin = 0;
1640
1641 f = pathopen(path, WSTR("rb"));
1642 if (!f)
1643 barf("loadObj: can't read `%s'", path);
1644
1645 /* Check if this is an archive by looking for the magic "!<arch>\n"
1646 * string. Usually, if this fails, we barf and quit. On Darwin however,
1647 * we may have a fat archive, which contains archives for more than
1648 * one architecture. Fat archives start with the magic number 0xcafebabe,
1649 * always stored big endian. If we find a fat_header, we scan through
1650 * the fat_arch structs, searching through for one for our host
1651 * architecture. If a matching struct is found, we read the offset
1652 * of our archive data (nfat_offset) and seek forward nfat_offset bytes
1653 * from the start of the file.
1654 *
1655 * A subtlety is that all of the members of the fat_header and fat_arch
1656 * structs are stored big endian, so we need to call byte order
1657 * conversion functions.
1658 *
1659 * If we find the appropriate architecture in a fat archive, we gobble
1660 * its magic "!<arch>\n" string and continue processing just as if
1661 * we had a single architecture archive.
1662 */
1663
1664 n = fread ( tmp, 1, 8, f );
1665 if (n != 8)
1666 barf("loadArchive: Failed reading header from `%s'", path);
1667 if (strncmp(tmp, "!<arch>\n", 8) == 0) {}
1668 #if !defined(mingw32_HOST_OS)
1669 /* See Note [thin archives on Windows] */
1670 else if (strncmp(tmp, "!<thin>\n", 8) == 0) {
1671 isThin = 1;
1672 }
1673 #endif
1674 #if defined(darwin_HOST_OS)
1675 /* Not a standard archive, look for a fat archive magic number: */
1676 else if (ntohl(*(uint32_t *)tmp) == FAT_MAGIC) {
1677 nfat_arch = ntohl(*(uint32_t *)(tmp + 4));
1678 IF_DEBUG(linker, debugBelch("loadArchive: found a fat archive containing %d architectures\n", nfat_arch));
1679 nfat_offset = 0;
1680
1681 for (i = 0; i < (int)nfat_arch; i++) {
1682 /* search for the right arch */
1683 n = fread( tmp, 1, 20, f );
1684 if (n != 8)
1685 barf("loadArchive: Failed reading arch from `%s'", path);
1686 cputype = ntohl(*(uint32_t *)tmp);
1687 cpusubtype = ntohl(*(uint32_t *)(tmp + 4));
1688
1689 if (cputype == mycputype && cpusubtype == mycpusubtype) {
1690 IF_DEBUG(linker, debugBelch("loadArchive: found my archive in a fat archive\n"));
1691 nfat_offset = ntohl(*(uint32_t *)(tmp + 8));
1692 break;
1693 }
1694 }
1695
1696 if (nfat_offset == 0) {
1697 barf ("loadArchive: searched %d architectures, but no host arch found", (int)nfat_arch);
1698 }
1699 else {
1700 n = fseek( f, nfat_offset, SEEK_SET );
1701 if (n != 0)
1702 barf("loadArchive: Failed to seek to arch in `%s'", path);
1703 n = fread ( tmp, 1, 8, f );
1704 if (n != 8)
1705 barf("loadArchive: Failed reading header from `%s'", path);
1706 if (strncmp(tmp, "!<arch>\n", 8) != 0) {
1707 barf("loadArchive: couldn't find archive in `%s' at offset %d", path, nfat_offset);
1708 }
1709 }
1710 }
1711 else {
1712 barf("loadArchive: Neither an archive, nor a fat archive: `%s'", path);
1713 }
1714 #else
1715 else {
1716 barf("loadArchive: Not an archive: `%s'", path);
1717 }
1718 #endif
1719
1720 IF_DEBUG(linker, debugBelch("loadArchive: loading archive contents\n"));
1721
1722 while(1) {
1723 n = fread ( fileName, 1, 16, f );
1724 if (n != 16) {
1725 if (feof(f)) {
1726 IF_DEBUG(linker, debugBelch("loadArchive: EOF while reading from '%" PATH_FMT "'\n", path));
1727 break;
1728 }
1729 else {
1730 barf("loadArchive: Failed reading file name from `%s'", path);
1731 }
1732 }
1733
1734 #if defined(darwin_HOST_OS)
1735 if (strncmp(fileName, "!<arch>\n", 8) == 0) {
1736 IF_DEBUG(linker, debugBelch("loadArchive: found the start of another archive, breaking\n"));
1737 break;
1738 }
1739 #endif
1740
1741 n = fread ( tmp, 1, 12, f );
1742 if (n != 12)
1743 barf("loadArchive: Failed reading mod time from `%s'", path);
1744 n = fread ( tmp, 1, 6, f );
1745 if (n != 6)
1746 barf("loadArchive: Failed reading owner from `%s'", path);
1747 n = fread ( tmp, 1, 6, f );
1748 if (n != 6)
1749 barf("loadArchive: Failed reading group from `%s'", path);
1750 n = fread ( tmp, 1, 8, f );
1751 if (n != 8)
1752 barf("loadArchive: Failed reading mode from `%s'", path);
1753 n = fread ( tmp, 1, 10, f );
1754 if (n != 10)
1755 barf("loadArchive: Failed reading size from `%s'", path);
1756 tmp[10] = '\0';
1757 for (n = 0; isdigit(tmp[n]); n++);
1758 tmp[n] = '\0';
1759 memberSize = atoi(tmp);
1760
1761 IF_DEBUG(linker, debugBelch("loadArchive: size of this archive member is %d\n", memberSize));
1762 n = fread ( tmp, 1, 2, f );
1763 if (n != 2)
1764 barf("loadArchive: Failed reading magic from `%s'", path);
1765 if (strncmp(tmp, "\x60\x0A", 2) != 0)
1766 barf("loadArchive: Failed reading magic from `%s' at %ld. Got %c%c",
1767 path, ftell(f), tmp[0], tmp[1]);
1768
1769 isGnuIndex = 0;
1770 /* Check for BSD-variant large filenames */
1771 if (0 == strncmp(fileName, "#1/", 3)) {
1772 fileName[16] = '\0';
1773 if (isdigit(fileName[3])) {
1774 for (n = 4; isdigit(fileName[n]); n++);
1775 fileName[n] = '\0';
1776 thisFileNameSize = atoi(fileName + 3);
1777 memberSize -= thisFileNameSize;
1778 if (thisFileNameSize >= fileNameSize) {
1779 /* Double it to avoid potentially continually
1780 increasing it by 1 */
1781 fileNameSize = thisFileNameSize * 2;
1782 fileName = stgReallocBytes(fileName, fileNameSize, "loadArchive(fileName)");
1783 }
1784 n = fread ( fileName, 1, thisFileNameSize, f );
1785 if (n != (int)thisFileNameSize) {
1786 barf("loadArchive: Failed reading filename from `%s'",
1787 path);
1788 }
1789 fileName[thisFileNameSize] = 0;
1790
1791 /* On OS X at least, thisFileNameSize is the size of the
1792 fileName field, not the length of the fileName
1793 itself. */
1794 thisFileNameSize = strlen(fileName);
1795 }
1796 else {
1797 barf("loadArchive: BSD-variant filename size not found while reading filename from `%s'", path);
1798 }
1799 }
1800 /* Check for GNU file index file */
1801 else if (0 == strncmp(fileName, "//", 2)) {
1802 fileName[0] = '\0';
1803 thisFileNameSize = 0;
1804 isGnuIndex = 1;
1805 }
1806 /* Check for a file in the GNU file index */
1807 else if (fileName[0] == '/') {
1808 if (isdigit(fileName[1])) {
1809 int i;
1810
1811 for (n = 2; isdigit(fileName[n]); n++);
1812 fileName[n] = '\0';
1813 n = atoi(fileName + 1);
1814
1815 if (gnuFileIndex == NULL) {
1816 barf("loadArchive: GNU-variant filename without an index while reading from `%s'", path);
1817 }
1818 if (n < 0 || n > gnuFileIndexSize) {
1819 barf("loadArchive: GNU-variant filename offset %d out of range [0..%d] while reading filename from `%s'", n, gnuFileIndexSize, path);
1820 }
1821 if (n != 0 && gnuFileIndex[n - 1] != '\n') {
1822 barf("loadArchive: GNU-variant filename offset %d invalid (range [0..%d]) while reading filename from `%s'", n, gnuFileIndexSize, path);
1823 }
1824 for (i = n; gnuFileIndex[i] != '\n'; i++);
1825 thisFileNameSize = i - n - 1;
1826 if (thisFileNameSize >= fileNameSize) {
1827 /* Double it to avoid potentially continually
1828 increasing it by 1 */
1829 fileNameSize = thisFileNameSize * 2;
1830 fileName = stgReallocBytes(fileName, fileNameSize, "loadArchive(fileName)");
1831 }
1832 memcpy(fileName, gnuFileIndex + n, thisFileNameSize);
1833 fileName[thisFileNameSize] = '\0';
1834 }
1835 else if (fileName[1] == ' ') {
1836 fileName[0] = '\0';
1837 thisFileNameSize = 0;
1838 }
1839 else {
1840 barf("loadArchive: GNU-variant filename offset not found while reading filename from `%s'", path);
1841 }
1842 }
1843 /* Finally, the case where the filename field actually contains
1844 the filename */
1845 else {
1846 /* GNU ar terminates filenames with a '/', this allowing
1847 spaces in filenames. So first look to see if there is a
1848 terminating '/'. */
1849 for (thisFileNameSize = 0;
1850 thisFileNameSize < 16;
1851 thisFileNameSize++) {
1852 if (fileName[thisFileNameSize] == '/') {
1853 fileName[thisFileNameSize] = '\0';
1854 break;
1855 }
1856 }
1857 /* If we didn't find a '/', then a space teminates the
1858 filename. Note that if we don't find one, then
1859 thisFileNameSize ends up as 16, and we already have the
1860 '\0' at the end. */
1861 if (thisFileNameSize == 16) {
1862 for (thisFileNameSize = 0;
1863 thisFileNameSize < 16;
1864 thisFileNameSize++) {
1865 if (fileName[thisFileNameSize] == ' ') {
1866 fileName[thisFileNameSize] = '\0';
1867 break;
1868 }
1869 }
1870 }
1871 }
1872
1873 IF_DEBUG(linker,
1874 debugBelch("loadArchive: Found member file `%s'\n", fileName));
1875
1876 isObject = thisFileNameSize >= 2
1877 && fileName[thisFileNameSize - 2] == '.'
1878 && fileName[thisFileNameSize - 1] == 'o';
1879
1880 IF_DEBUG(linker, debugBelch("loadArchive: \tthisFileNameSize = %d\n", (int)thisFileNameSize));
1881 IF_DEBUG(linker, debugBelch("loadArchive: \tisObject = %d\n", isObject));
1882
1883 if (isObject) {
1884 char *archiveMemberName;
1885
1886 IF_DEBUG(linker, debugBelch("loadArchive: Member is an object file...loading...\n"));
1887
1888 #if defined(mingw32_HOST_OS)
1889 // TODO: We would like to use allocateExec here, but allocateExec
1890 // cannot currently allocate blocks large enough.
1891 image = allocateImageAndTrampolines(path, fileName,
1892 #if defined(x86_64_HOST_ARCH)
1893 f,
1894 #endif
1895 memberSize);
1896 #elif defined(darwin_HOST_OS)
1897 #if defined(USE_MMAP)
1898 image = mmapForLinker(memberSize, MAP_ANONYMOUS, -1, 0);
1899 #else
1900 /* See loadObj() */
1901 misalignment = machoGetMisalignment(f);
1902 image = stgMallocBytes(memberSize + misalignment, "loadArchive(image)");
1903 image += misalignment;
1904 #endif // USE_MMAP
1905
1906 #else // not windows or darwin
1907 image = stgMallocBytes(memberSize, "loadArchive(image)");
1908 #endif
1909
1910 #if !defined(mingw32_HOST_OS)
1911 /*
1912 * Note [thin archives on Windows]
1913 * This doesn't compile on Windows because it assumes
1914 * char* pathnames, and we use wchar_t* on Windows. It's
1915 * not trivial to fix, so I'm leaving it disabled on
1916 * Windows for now --SDM
1917 */
1918 if (isThin) {
1919 FILE *member;
1920 char *pathCopy, *dirName, *memberPath;
1921
1922 /* Allocate and setup the dirname of the archive. We'll need
1923 this to locate the thin member */
1924 pathCopy = stgMallocBytes(strlen(path) + 1, "loadArchive(file)");
1925 strcpy(pathCopy, path);
1926 dirName = dirname(pathCopy);
1927
1928 /* Append the relative member name to the dirname. This should be
1929 be the full path to the actual thin member. */
1930 memberPath = stgMallocBytes(
1931 strlen(path) + 1 + strlen(fileName) + 1, "loadArchive(file)");
1932 strcpy(memberPath, dirName);
1933 memberPath[strlen(dirName)] = '/';
1934 strcpy(memberPath + strlen(dirName) + 1, fileName);
1935
1936 member = pathopen(memberPath, WSTR("rb"));
1937 if (!member)
1938 barf("loadObj: can't read `%s'", path);
1939
1940 n = fread ( image, 1, memberSize, member );
1941 if (n != memberSize) {
1942 barf("loadArchive: error whilst reading `%s'", fileName);
1943 }
1944
1945 fclose(member);
1946 stgFree(memberPath);
1947 stgFree(pathCopy);
1948 }
1949 else
1950 #endif
1951 {
1952 n = fread ( image, 1, memberSize, f );
1953 if (n != memberSize) {
1954 barf("loadArchive: error whilst reading `%s'", path);
1955 }
1956 }
1957
1958 archiveMemberName = stgMallocBytes(pathlen(path) + thisFileNameSize + 3,
1959 "loadArchive(file)");
1960 sprintf(archiveMemberName, "%" PATH_FMT "(%.*s)",
1961 path, (int)thisFileNameSize, fileName);
1962
1963 oc = mkOc(path, image, memberSize, rtsFalse, archiveMemberName
1964 #if !defined(USE_MMAP) && defined(darwin_HOST_OS)
1965 , misalignment
1966 #endif
1967 );
1968
1969 stgFree(archiveMemberName);
1970
1971 if (0 == loadOc(oc)) {
1972 stgFree(fileName);
1973 fclose(f);
1974 return 0;
1975 } else {
1976 oc->next = objects;
1977 objects = oc;
1978 }
1979 }
1980 else if (isGnuIndex) {
1981 if (gnuFileIndex != NULL) {
1982 barf("loadArchive: GNU-variant index found, but already have an index, while reading filename from `%s'", path);
1983 }
1984 IF_DEBUG(linker, debugBelch("loadArchive: Found GNU-variant file index\n"));
1985 #ifdef USE_MMAP
1986 gnuFileIndex = mmapForLinker(memberSize + 1, MAP_ANONYMOUS, -1, 0);
1987 #else
1988 gnuFileIndex = stgMallocBytes(memberSize + 1, "loadArchive(image)");
1989 #endif
1990 n = fread ( gnuFileIndex, 1, memberSize, f );
1991 if (n != memberSize) {
1992 barf("loadArchive: error whilst reading `%s'", path);
1993 }
1994 gnuFileIndex[memberSize] = '/';
1995 gnuFileIndexSize = memberSize;
1996 }
1997 else {
1998 IF_DEBUG(linker, debugBelch("loadArchive: '%s' does not appear to be an object file\n", fileName));
1999 if (!isThin || thisFileNameSize == 0) {
2000 n = fseek(f, memberSize, SEEK_CUR);
2001 if (n != 0)
2002 barf("loadArchive: error whilst seeking by %d in `%s'",
2003 memberSize, path);
2004 }
2005 }
2006
2007 /* .ar files are 2-byte aligned */
2008 if (!(isThin && thisFileNameSize > 0) && memberSize % 2) {
2009 IF_DEBUG(linker, debugBelch("loadArchive: trying to read one pad byte\n"));
2010 n = fread ( tmp, 1, 1, f );
2011 if (n != 1) {
2012 if (feof(f)) {
2013 IF_DEBUG(linker, debugBelch("loadArchive: found EOF while reading one pad byte\n"));
2014 break;
2015 }
2016 else {
2017 barf("loadArchive: Failed reading padding from `%s'", path);
2018 }
2019 }
2020 IF_DEBUG(linker, debugBelch("loadArchive: successfully read one pad byte\n"));
2021 }
2022 IF_DEBUG(linker, debugBelch("loadArchive: reached end of archive loading while loop\n"));
2023 }
2024
2025 fclose(f);
2026
2027 stgFree(fileName);
2028 if (gnuFileIndex != NULL) {
2029 #ifdef USE_MMAP
2030 munmap(gnuFileIndex, gnuFileIndexSize + 1);
2031 #else
2032 stgFree(gnuFileIndex);
2033 #endif
2034 }
2035
2036 #ifdef USE_MMAP
2037 m32_allocator_flush(&allocator);
2038 #endif
2039
2040 IF_DEBUG(linker, debugBelch("loadArchive: done\n"));
2041 return 1;
2042 }
2043
2044 HsInt loadArchive (pathchar *path)
2045 {
2046 ACQUIRE_LOCK(&linker_mutex);
2047 HsInt r = loadArchive_(path);
2048 RELEASE_LOCK(&linker_mutex);
2049 return r;
2050 }
2051
2052 //
2053 // Load the object file into memory. This will not be its final resting place,
2054 // as on 64-bit platforms we need to map its segments into the low 2Gb of the
2055 // address space, properly aligned.
2056 //
2057 static ObjectCode *
2058 preloadObjectFile (pathchar *path)
2059 {
2060 int fileSize;
2061 struct_stat st;
2062 int r;
2063 void *image;
2064 ObjectCode *oc;
2065 #if !defined(USE_MMAP) && defined(darwin_HOST_OS)
2066 int misalignment;
2067 #endif
2068
2069 r = pathstat(path, &st);
2070 if (r == -1) {
2071 errorBelch("loadObj: %" PATH_FMT ": file doesn't exist", path);
2072 return NULL;
2073 }
2074
2075 fileSize = st.st_size;
2076
2077 #ifdef USE_MMAP
2078 int fd;
2079
2080 /* On many architectures malloc'd memory isn't executable, so we need to use
2081 * mmap. */
2082
2083 #if defined(openbsd_HOST_OS)
2084 fd = open(path, O_RDONLY, S_IRUSR);
2085 #else
2086 fd = open(path, O_RDONLY);
2087 #endif
2088 if (fd == -1) {
2089 errorBelch("loadObj: can't open %s", path);
2090 return NULL;
2091 }
2092
2093 image = mmap(NULL, fileSize, PROT_READ|PROT_WRITE|PROT_EXEC,
2094 MAP_PRIVATE, fd, 0);
2095 // not 32-bit yet, we'll remap later
2096 close(fd);
2097
2098 #else /* !USE_MMAP */
2099 FILE *f;
2100
2101 /* load the image into memory */
2102 /* coverity[toctou] */
2103 f = pathopen(path, WSTR("rb"));
2104 if (!f) {
2105 errorBelch("loadObj: can't read `%" PATH_FMT "'", path);
2106 return NULL;
2107 }
2108
2109 # if defined(mingw32_HOST_OS)
2110
2111 // TODO: We would like to use allocateExec here, but allocateExec
2112 // cannot currently allocate blocks large enough.
2113 image = allocateImageAndTrampolines(path, "itself",
2114 #if defined(x86_64_HOST_ARCH)
2115 f,
2116 #endif
2117 fileSize);
2118 if (image == NULL) {
2119 fclose(f);
2120 return NULL;
2121 }
2122
2123 # elif defined(darwin_HOST_OS)
2124
2125 // In a Mach-O .o file, all sections can and will be misaligned
2126 // if the total size of the headers is not a multiple of the
2127 // desired alignment. This is fine for .o files that only serve
2128 // as input for the static linker, but it's not fine for us,
2129 // as SSE (used by gcc for floating point) and Altivec require
2130 // 16-byte alignment.
2131 // We calculate the correct alignment from the header before
2132 // reading the file, and then we misalign image on purpose so
2133 // that the actual sections end up aligned again.
2134 misalignment = machoGetMisalignment(f);
2135 image = stgMallocBytes(fileSize + misalignment, "loadObj(image)");
2136 image += misalignment;
2137
2138 # else /* !defined(mingw32_HOST_OS) */
2139
2140 image = stgMallocBytes(fileSize, "loadObj(image)");
2141
2142 #endif
2143
2144 int n;
2145 n = fread ( image, 1, fileSize, f );
2146 fclose(f);
2147 if (n != fileSize) {
2148 errorBelch("loadObj: error whilst reading `%" PATH_FMT "'", path);
2149 stgFree(image);
2150 return NULL;
2151 }
2152
2153 #endif /* USE_MMAP */
2154
2155 oc = mkOc(path, image, fileSize, rtsTrue, NULL
2156 #if !defined(USE_MMAP) && defined(darwin_HOST_OS)
2157 , misalignment
2158 #endif
2159 );
2160
2161 return oc;
2162 }
2163
2164 /* -----------------------------------------------------------------------------
2165 * Load an obj (populate the global symbol table, but don't resolve yet)
2166 *
2167 * Returns: 1 if ok, 0 on error.
2168 */
2169 static HsInt loadObj_ (pathchar *path)
2170 {
2171 ObjectCode* oc;
2172 IF_DEBUG(linker, debugBelch("loadObj %" PATH_FMT "\n", path));
2173
2174 /* debugBelch("loadObj %s\n", path ); */
2175
2176 /* Check that we haven't already loaded this object.
2177 Ignore requests to load multiple times */
2178
2179 if (isAlreadyLoaded(path)) {
2180 IF_DEBUG(linker,
2181 debugBelch("ignoring repeated load of %" PATH_FMT "\n", path));
2182 return 1; /* success */
2183 }
2184
2185 oc = preloadObjectFile(path);
2186 if (oc == NULL) return 0;
2187
2188 if (! loadOc(oc)) {
2189 // failed; free everything we've allocated
2190 removeOcSymbols(oc);
2191 // no need to freeOcStablePtrs, they aren't created until resolveObjs()
2192 freeObjectCode(oc);
2193 return 0;
2194 }
2195
2196 oc->next = objects;
2197 objects = oc;
2198 return 1;
2199 }
2200
2201 HsInt loadObj (pathchar *path)
2202 {
2203 ACQUIRE_LOCK(&linker_mutex);
2204 HsInt r = loadObj_(path);
2205 RELEASE_LOCK(&linker_mutex);
2206 return r;
2207 }
2208
2209 static HsInt loadOc (ObjectCode* oc)
2210 {
2211 int r;
2212
2213 IF_DEBUG(linker, debugBelch("loadOc: start\n"));
2214
2215 /* verify the in-memory image */
2216 # if defined(OBJFORMAT_ELF)
2217 r = ocVerifyImage_ELF ( oc );
2218 # elif defined(OBJFORMAT_PEi386)
2219 r = ocVerifyImage_PEi386 ( oc );
2220 # elif defined(OBJFORMAT_MACHO)
2221 r = ocVerifyImage_MachO ( oc );
2222 # else
2223 barf("loadObj: no verify method");
2224 # endif
2225 if (!r) {
2226 IF_DEBUG(linker, debugBelch("loadOc: ocVerifyImage_* failed\n"));
2227 return r;
2228 }
2229
2230 #if NEED_SYMBOL_EXTRAS
2231 # if defined(OBJFORMAT_MACHO)
2232 r = ocAllocateSymbolExtras_MachO ( oc );
2233 if (!r) {
2234 IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_MachO failed\n"));
2235 return r;
2236 }
2237 # elif defined(OBJFORMAT_ELF)
2238 r = ocAllocateSymbolExtras_ELF ( oc );
2239 if (!r) {
2240 IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_ELF failed\n"));
2241 return r;
2242 }
2243 # elif defined(OBJFORMAT_PEi386)
2244 ocAllocateSymbolExtras_PEi386 ( oc );
2245 # endif
2246 #endif
2247
2248 /* build the symbol list for this image */
2249 # if defined(OBJFORMAT_ELF)
2250 r = ocGetNames_ELF ( oc );
2251 # elif defined(OBJFORMAT_PEi386)
2252 r = ocGetNames_PEi386 ( oc );
2253 # elif defined(OBJFORMAT_MACHO)
2254 r = ocGetNames_MachO ( oc );
2255 # else
2256 barf("loadObj: no getNames method");
2257 # endif
2258 if (!r) {
2259 IF_DEBUG(linker, debugBelch("loadOc: ocGetNames_* failed\n"));
2260 return r;
2261 }
2262
2263 /* loaded, but not resolved yet */
2264 oc->status = OBJECT_LOADED;
2265 IF_DEBUG(linker, debugBelch("loadOc: done.\n"));
2266
2267 return 1;
2268 }
2269
2270 /* -----------------------------------------------------------------------------
2271 * resolve all the currently unlinked objects in memory
2272 *
2273 * Returns: 1 if ok, 0 on error.
2274 */
2275 static HsInt resolveObjs_ (void)
2276 {
2277 ObjectCode *oc;
2278 int r;
2279
2280 IF_DEBUG(linker, debugBelch("resolveObjs: start\n"));
2281
2282 for (oc = objects; oc; oc = oc->next) {
2283 if (oc->status != OBJECT_RESOLVED) {
2284 # if defined(OBJFORMAT_ELF)
2285 r = ocResolve_ELF ( oc );
2286 # elif defined(OBJFORMAT_PEi386)
2287 r = ocResolve_PEi386 ( oc );
2288 # elif defined(OBJFORMAT_MACHO)
2289 r = ocResolve_MachO ( oc );
2290 # else
2291 barf("resolveObjs: not implemented on this platform");
2292 # endif
2293 if (!r) { return r; }
2294
2295 // run init/init_array/ctors/mod_init_func
2296
2297 loading_obj = oc; // tells foreignExportStablePtr what to do
2298 #if defined(OBJFORMAT_ELF)
2299 r = ocRunInit_ELF ( oc );
2300 #elif defined(OBJFORMAT_PEi386)
2301 r = ocRunInit_PEi386 ( oc );
2302 #elif defined(OBJFORMAT_MACHO)
2303 r = ocRunInit_MachO ( oc );
2304 #else
2305 barf("resolveObjs: initializers not implemented on this platform");
2306 #endif
2307 loading_obj = NULL;
2308
2309 if (!r) { return r; }
2310
2311 oc->status = OBJECT_RESOLVED;
2312 }
2313 }
2314 IF_DEBUG(linker, debugBelch("resolveObjs: done\n"));
2315 return 1;
2316 }
2317
2318 HsInt resolveObjs (void)
2319 {
2320 ACQUIRE_LOCK(&linker_mutex);
2321 HsInt r = resolveObjs_();
2322 RELEASE_LOCK(&linker_mutex);
2323 return r;
2324 }
2325
2326 /* -----------------------------------------------------------------------------
2327 * delete an object from the pool
2328 */
2329 static HsInt unloadObj_ (pathchar *path, rtsBool just_purge)
2330 {
2331 ObjectCode *oc, *prev, *next;
2332 HsBool unloadedAnyObj = HS_BOOL_FALSE;
2333
2334 ASSERT(symhash != NULL);
2335 ASSERT(objects != NULL);
2336
2337 IF_DEBUG(linker, debugBelch("unloadObj: %" PATH_FMT "\n", path));
2338
2339 prev = NULL;
2340 for (oc = objects; oc; oc = next) {
2341 next = oc->next; // oc might be freed
2342
2343 if (!pathcmp(oc->fileName,path)) {
2344
2345 // these are both idempotent, so in just_purge mode we can
2346 // later call unloadObj() to really unload the object.
2347 removeOcSymbols(oc);
2348 freeOcStablePtrs(oc);
2349
2350 if (!just_purge) {
2351 if (prev == NULL) {
2352 objects = oc->next;
2353 } else {
2354 prev->next = oc->next;
2355 }
2356 ACQUIRE_LOCK(&linker_unloaded_mutex);
2357 oc->next = unloaded_objects;
2358 unloaded_objects = oc;
2359 oc->status = OBJECT_UNLOADED;
2360 RELEASE_LOCK(&linker_unloaded_mutex);
2361 // We do not own oc any more; it can be released at any time by
2362 // the GC in checkUnload().
2363 } else {
2364 prev = oc;
2365 }
2366
2367 /* This could be a member of an archive so continue
2368 * unloading other members. */
2369 unloadedAnyObj = HS_BOOL_TRUE;
2370 } else {
2371 prev = oc;
2372 }
2373 }
2374
2375 if (unloadedAnyObj) {
2376 return 1;
2377 }
2378 else {
2379 errorBelch("unloadObj: can't find `%" PATH_FMT "' to unload", path);
2380 return 0;
2381 }
2382 }
2383
2384 HsInt unloadObj (pathchar *path)
2385 {
2386 ACQUIRE_LOCK(&linker_mutex);
2387 HsInt r = unloadObj_(path, rtsFalse);
2388 RELEASE_LOCK(&linker_mutex);
2389 return r;
2390 }
2391
2392 HsInt purgeObj (pathchar *path)
2393 {
2394 ACQUIRE_LOCK(&linker_mutex);
2395 HsInt r = unloadObj_(path, rtsTrue);
2396 RELEASE_LOCK(&linker_mutex);
2397 return r;
2398 }
2399
2400 /* -----------------------------------------------------------------------------
2401 * Sanity checking. For each ObjectCode, maintain a list of address ranges
2402 * which may be prodded during relocation, and abort if we try and write
2403 * outside any of these.
2404 */
2405 static void
2406 addProddableBlock ( ObjectCode* oc, void* start, int size )
2407 {
2408 ProddableBlock* pb
2409 = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
2410
2411 IF_DEBUG(linker, debugBelch("addProddableBlock: %p %p %d\n", oc, start, size));
2412 ASSERT(size > 0);
2413 pb->start = start;
2414 pb->size = size;
2415 pb->next = oc->proddables;
2416 oc->proddables = pb;
2417 }
2418
2419 static void
2420 checkProddableBlock (ObjectCode *oc, void *addr, size_t size )
2421 {
2422 ProddableBlock* pb;
2423
2424 for (pb = oc->proddables; pb != NULL; pb = pb->next) {
2425 char* s = (char*)(pb->start);
2426 char* e = s + pb->size;
2427 char* a = (char*)addr;
2428 if (a >= s && (a+size) <= e) return;
2429 }
2430 barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr);
2431 }
2432
2433 static void freeProddableBlocks (ObjectCode *oc)
2434 {
2435 ProddableBlock *pb, *next;
2436
2437 for (pb = oc->proddables; pb != NULL; pb = next) {
2438 next = pb->next;
2439 stgFree(pb);
2440 }
2441 oc->proddables = NULL;
2442 }
2443
2444 /* -----------------------------------------------------------------------------
2445 * Section management.
2446 */
2447 static void
2448 addSection (Section *s, SectionKind kind, SectionAlloc alloc,
2449 void* start, StgWord size, StgWord mapped_offset,
2450 void* mapped_start, StgWord mapped_size)
2451 {
2452 s->start = start; /* actual start of section in memory */
2453 s->size = size; /* actual size of section in memory */
2454 s->kind = kind;
2455 s->alloc = alloc;
2456 s->mapped_offset = mapped_offset; /* offset from the image of mapped_start */
2457
2458 s->mapped_start = mapped_start; /* start of mmap() block */
2459 s->mapped_size = mapped_size; /* size of mmap() block */
2460
2461 IF_DEBUG(linker,
2462 debugBelch("addSection: %p-%p (size %" FMT_Word "), kind %d\n",
2463 start, (void*)((StgWord)start + size),
2464 size, kind ));
2465 }
2466
2467
2468 /* --------------------------------------------------------------------------
2469 * Symbol Extras.
2470 * This is about allocating a small chunk of memory for every symbol in the
2471 * object file. We make sure that the SymboLExtras are always "in range" of
2472 * limited-range PC-relative instructions on various platforms by allocating
2473 * them right next to the object code itself.
2474 */
2475
2476 #if NEED_SYMBOL_EXTRAS
2477 #if !defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS)
2478
2479 /*
2480 ocAllocateSymbolExtras
2481
2482 Allocate additional space at the end of the object file image to make room
2483 for jump islands (powerpc, x86_64, arm) and GOT entries (x86_64).
2484
2485 PowerPC relative branch instructions have a 24 bit displacement field.
2486 As PPC code is always 4-byte-aligned, this yields a +-32MB range.
2487 If a particular imported symbol is outside this range, we have to redirect
2488 the jump to a short piece of new code that just loads the 32bit absolute
2489 address and jumps there.
2490 On x86_64, PC-relative jumps and PC-relative accesses to the GOT are limited
2491 to 32 bits (+-2GB).
2492
2493 This function just allocates space for one SymbolExtra for every
2494 undefined symbol in the object file. The code for the jump islands is
2495 filled in by makeSymbolExtra below.
2496 */
2497
2498 static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first )
2499 {
2500 StgWord n;
2501 #ifndef USE_MMAP
2502 int misalignment = 0;
2503 #ifdef darwin_HOST_OS
2504 int aligned;
2505 #endif
2506 #endif
2507
2508 #ifdef USE_MMAP
2509 if (USE_CONTIGUOUS_MMAP)
2510 {
2511 n = roundUpToPage(oc->fileSize);
2512
2513 /* Keep image and symbol_extras contiguous */
2514 void *new = mmapForLinker(n + (sizeof(SymbolExtra) * count),
2515 MAP_ANONYMOUS, -1, 0);
2516 if (new)
2517 {
2518 memcpy(new, oc->image, oc->fileSize);
2519 if (oc->imageMapped) {
2520 munmap(oc->image, n);
2521 }
2522 oc->image = new;
2523 oc->imageMapped = rtsTrue;
2524 oc->fileSize = n + (sizeof(SymbolExtra) * count);
2525 oc->symbol_extras = (SymbolExtra *) (oc->image + n);
2526 }
2527 else {
2528 oc->symbol_extras = NULL;
2529 return 0;
2530 }
2531 }
2532 else
2533 #endif
2534
2535 if( count > 0 )
2536 {
2537 #ifdef USE_MMAP
2538 n = roundUpToPage(oc->fileSize);
2539
2540 oc->symbol_extras = m32_alloc(&allocator,
2541 sizeof(SymbolExtra) * count, 8);
2542 if (oc->symbol_extras == NULL) return 0;
2543 #else
2544 // round up to the nearest 4
2545 aligned = (oc->fileSize + 3) & ~3;
2546
2547 misalignment = oc->misalignment;
2548
2549 oc->image -= misalignment;
2550 oc->image = stgReallocBytes( oc->image,
2551 misalignment +
2552 aligned + sizeof (SymbolExtra) * count,
2553 "ocAllocateSymbolExtras" );
2554 oc->image += misalignment;
2555
2556 oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
2557 #endif /* USE_MMAP */
2558 }
2559
2560 if (oc->symbol_extras != NULL) {
2561 memset( oc->symbol_extras, 0, sizeof (SymbolExtra) * count );
2562 }
2563
2564 oc->first_symbol_extra = first;
2565 oc->n_symbol_extras = count;
2566
2567 return 1;
2568 }
2569
2570 #endif
2571 #endif // NEED_SYMBOL_EXTRAS
2572
2573 #if defined(arm_HOST_ARCH)
2574
2575 static void
2576 ocFlushInstructionCache( ObjectCode *oc )
2577 {
2578 // Object code
2579 __clear_cache(oc->image, oc->image + oc->fileSize);
2580 // Jump islands
2581 __clear_cache(oc->symbol_extras, &oc->symbol_extras[oc->n_symbol_extras]);
2582 }
2583
2584 #endif
2585
2586 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
2587 #if !defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS)
2588
2589 static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
2590 unsigned long symbolNumber,
2591 unsigned long target )
2592 {
2593 SymbolExtra *extra;
2594
2595 ASSERT( symbolNumber >= oc->first_symbol_extra
2596 && symbolNumber - oc->first_symbol_extra < oc->n_symbol_extras);
2597
2598 extra = &oc->symbol_extras[symbolNumber - oc->first_symbol_extra];
2599
2600 #ifdef powerpc_HOST_ARCH
2601 // lis r12, hi16(target)
2602 extra->jumpIsland.lis_r12 = 0x3d80;
2603 extra->jumpIsland.hi_addr = target >> 16;
2604
2605 // ori r12, r12, lo16(target)
2606 extra->jumpIsland.ori_r12_r12 = 0x618c;
2607 extra->jumpIsland.lo_addr = target & 0xffff;
2608
2609 // mtctr r12
2610 extra->jumpIsland.mtctr_r12 = 0x7d8903a6;
2611
2612 // bctr
2613 extra->jumpIsland.bctr = 0x4e800420;
2614 #endif
2615 #ifdef x86_64_HOST_ARCH
2616 // jmp *-14(%rip)
2617 static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
2618 extra->addr = target;
2619 memcpy(extra->jumpIsland, jmp, 6);
2620 #endif
2621
2622 return extra;
2623 }
2624
2625 #endif
2626 #endif // defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
2627
2628 #ifdef arm_HOST_ARCH
2629 static SymbolExtra* makeArmSymbolExtra( ObjectCode* oc,
2630 unsigned long symbolNumber,
2631 unsigned long target,
2632 int fromThumb,
2633 int toThumb )
2634 {
2635 SymbolExtra *extra;
2636
2637 ASSERT( symbolNumber >= oc->first_symbol_extra
2638 && symbolNumber - oc->first_symbol_extra < oc->n_symbol_extras);
2639
2640 extra = &oc->symbol_extras[symbolNumber - oc->first_symbol_extra];
2641
2642 // Make sure instruction mode bit is set properly
2643 if (toThumb)
2644 target |= 1;
2645 else
2646 target &= ~1;
2647
2648 if (!fromThumb) {
2649 // In ARM encoding:
2650 // movw r12, #0
2651 // movt r12, #0
2652 // bx r12
2653 uint32_t code[] = { 0xe300c000, 0xe340c000, 0xe12fff1c };
2654
2655 // Patch lower half-word into movw
2656 code[0] |= ((target>>12) & 0xf) << 16;
2657 code[0] |= target & 0xfff;
2658 // Patch upper half-word into movt
2659 target >>= 16;
2660 code[1] |= ((target>>12) & 0xf) << 16;
2661 code[1] |= target & 0xfff;
2662
2663 memcpy(extra->jumpIsland, code, 12);
2664
2665 } else {
2666 // In Thumb encoding:
2667 // movw r12, #0
2668 // movt r12, #0
2669 // bx r12
2670 uint16_t code[] = { 0xf240, 0x0c00,
2671 0xf2c0, 0x0c00,
2672 0x4760 };
2673
2674 // Patch lower half-word into movw
2675 code[0] |= (target>>12) & 0xf;
2676 code[0] |= ((target>>11) & 0x1) << 10;
2677 code[1] |= ((target>>8) & 0x7) << 12;
2678 code[1] |= target & 0xff;
2679 // Patch upper half-word into movt
2680 target >>= 16;
2681 code[2] |= (target>>12) & 0xf;
2682 code[2] |= ((target>>11) & 0x1) << 10;
2683 code[3] |= ((target>>8) & 0x7) << 12;
2684 code[3] |= target & 0xff;
2685
2686 memcpy(extra->jumpIsland, code, 10);
2687 }
2688
2689 return extra;
2690 }
2691 #endif // arm_HOST_ARCH
2692
2693 /* --------------------------------------------------------------------------
2694 * PowerPC specifics (instruction cache flushing)
2695 * ------------------------------------------------------------------------*/
2696
2697 #ifdef powerpc_HOST_ARCH
2698 /*
2699 ocFlushInstructionCache
2700
2701 Flush the data & instruction caches.
2702 Because the PPC has split data/instruction caches, we have to
2703 do that whenever we modify code at runtime.
2704 */
2705
2706 static void
2707 ocFlushInstructionCacheFrom(void* begin, size_t length)
2708 {
2709 size_t n = (length + 3) / 4;
2710 unsigned long* p = begin;
2711
2712 while (n--)
2713 {
2714 __asm__ volatile ( "dcbf 0,%0\n\t"
2715 "sync\n\t"
2716 "icbi 0,%0"
2717 :
2718 : "r" (p)
2719 );
2720 p++;
2721 }
2722 __asm__ volatile ( "sync\n\t"
2723 "isync"
2724 );
2725 }
2726
2727 static void
2728 ocFlushInstructionCache( ObjectCode *oc )
2729 {
2730 /* The main object code */
2731 ocFlushInstructionCacheFrom(oc->image
2732 #ifdef darwin_HOST_OS
2733 + oc->misalignment
2734 #endif
2735 , oc->fileSize);
2736
2737 /* Jump Islands */
2738 ocFlushInstructionCacheFrom(oc->symbol_extras, sizeof(SymbolExtra) * oc->n_symbol_extras);
2739 }
2740 #endif /* powerpc_HOST_ARCH */
2741
2742
2743 /* --------------------------------------------------------------------------
2744 * PEi386(+) specifics (Win32 targets)
2745 * ------------------------------------------------------------------------*/
2746
2747 /* The information for this linker comes from
2748 Microsoft Portable Executable
2749 and Common Object File Format Specification
2750 revision 8.3 February 2013
2751
2752 It can be found online at:
2753
2754 https://msdn.microsoft.com/en-us/windows/hardware/gg463119.aspx
2755
2756 Things move, so if that fails, try searching for it via
2757
2758 http://www.google.com/search?q=PE+COFF+specification
2759
2760 The ultimate reference for the PE format is the Winnt.h
2761 header file that comes with the Platform SDKs; as always,
2762 implementations will drift wrt their documentation.
2763
2764 A good background article on the PE format is Matt Pietrek's
2765 March 1994 article in Microsoft System Journal (MSJ)
2766 (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
2767 Win32 Portable Executable File Format." The info in there
2768 has recently been updated in a two part article in
2769 MSDN magazine, issues Feb and March 2002,
2770 "Inside Windows: An In-Depth Look into the Win32 Portable
2771 Executable File Format"
2772
2773 John Levine's book "Linkers and Loaders" contains useful
2774 info on PE too.
2775
2776 The PE specification doesn't specify how to do the actual
2777 relocations. For this reason, and because both PE and ELF are
2778 based on COFF, the relocations for the PEi386+ code is based on
2779 the ELF relocations for the equivalent relocation type.
2780
2781 The ELF ABI can be found at
2782
2783 http://www.x86-64.org/documentation/abi.pdf
2784
2785 The current code is based on version 0.99.6 - October 2013
2786 */
2787
2788
2789 #if defined(OBJFORMAT_PEi386)
2790
2791
2792
2793 typedef unsigned char UChar;
2794 typedef unsigned short UInt16;
2795 typedef unsigned int UInt32;
2796 typedef int Int32;
2797 typedef unsigned long long int UInt64;
2798
2799
2800 typedef
2801 struct {
2802 UInt16 Machine;
2803 UInt16 NumberOfSections;
2804 UInt32 TimeDateStamp;
2805 UInt32 PointerToSymbolTable;
2806 UInt32 NumberOfSymbols;
2807 UInt16 SizeOfOptionalHeader;
2808 UInt16 Characteristics;
2809 }
2810 COFF_header;
2811
2812 #define sizeof_COFF_header 20
2813
2814
2815 typedef
2816 struct {
2817 UChar Name[8];
2818 UInt32 VirtualSize;
2819 UInt32 VirtualAddress;
2820 UInt32 SizeOfRawData;
2821 UInt32 PointerToRawData;
2822 UInt32 PointerToRelocations;
2823 UInt32 PointerToLinenumbers;
2824 UInt16 NumberOfRelocations;
2825 UInt16 NumberOfLineNumbers;
2826 UInt32 Characteristics;
2827 }
2828 COFF_section;
2829
2830 #define sizeof_COFF_section 40
2831
2832
2833 typedef
2834 struct {
2835 UChar Name[8];
2836 UInt32 Value;
2837 UInt16 SectionNumber;
2838 UInt16 Type;
2839 UChar StorageClass;
2840 UChar NumberOfAuxSymbols;
2841 }
2842 COFF_symbol;
2843
2844 #define sizeof_COFF_symbol 18
2845
2846
2847 typedef
2848 struct {
2849 UInt32 VirtualAddress;
2850 UInt32 SymbolTableIndex;
2851 UInt16 Type;
2852 }
2853 COFF_reloc;
2854
2855 #define sizeof_COFF_reloc 10
2856
2857
2858 /* From PE spec doc, section 3.3.2 */
2859 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
2860 windows.h -- for the same purpose, but I want to know what I'm
2861 getting, here. */
2862 #define MYIMAGE_FILE_RELOCS_STRIPPED 0x0001
2863 #define MYIMAGE_FILE_EXECUTABLE_IMAGE 0x0002
2864 #define MYIMAGE_FILE_DLL 0x2000
2865 #define MYIMAGE_FILE_SYSTEM 0x1000
2866 #define MYIMAGE_FILE_BYTES_REVERSED_HI 0x8000
2867 #define MYIMAGE_FILE_BYTES_REVERSED_LO 0x0080
2868 #define MYIMAGE_FILE_32BIT_MACHINE 0x0100
2869
2870 /* From PE spec doc, section 5.4.2 and 5.4.4 */
2871 #define MYIMAGE_SYM_CLASS_EXTERNAL 2
2872 #define MYIMAGE_SYM_CLASS_STATIC 3
2873 #define MYIMAGE_SYM_UNDEFINED 0
2874
2875 /* From PE spec doc, section 3.1 */
2876 #define MYIMAGE_SCN_CNT_CODE 0x00000020
2877 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
2878 #define MYIMAGE_SCN_CNT_UNINITIALIZED_DATA 0x00000080
2879 #define MYIMAGE_SCN_LNK_COMDAT 0x00001000
2880 #define MYIMAGE_SCN_LNK_NRELOC_OVFL 0x01000000
2881 #define MYIMAGE_SCN_LNK_REMOVE 0x00000800
2882 #define MYIMAGE_SCN_MEM_DISCARDABLE 0x02000000
2883
2884 /* From PE spec doc, section 5.2.1 */
2885 #define MYIMAGE_REL_I386_DIR32 0x0006
2886 #define MYIMAGE_REL_I386_REL32 0x0014
2887
2888 static int verifyCOFFHeader ( COFF_header *hdr, pathchar *filename);
2889
2890 /* We assume file pointer is right at the
2891 beginning of COFF object.
2892 */
2893 static char *
2894 allocateImageAndTrampolines (
2895 pathchar* arch_name, char* member_name,
2896 #if defined(x86_64_HOST_ARCH)
2897 FILE* f,
2898 #endif
2899 int size )
2900 {
2901 char* image;
2902 #if defined(x86_64_HOST_ARCH)
2903 /* PeCoff contains number of symbols right in it's header, so
2904 we can reserve the room for symbolExtras right here. */
2905 COFF_header hdr;
2906 size_t n;
2907
2908 n = fread ( &hdr, 1, sizeof_COFF_header, f );
2909 if (n != sizeof( COFF_header )) {
2910 errorBelch("getNumberOfSymbols: error whilst reading `%s' header in `%S'",
2911 member_name, arch_name);
2912 return NULL;
2913 }
2914 fseek( f, -sizeof_COFF_header, SEEK_CUR );
2915
2916 if (!verifyCOFFHeader(&hdr, arch_name)) {
2917 return 0;
2918 }
2919
2920 /* We get back 8-byte aligned memory (is that guaranteed?), but
2921 the offsets to the sections within the file are all 4 mod 8
2922 (is that guaranteed?). We therefore need to offset the image
2923 by 4, so that all the pointers are 8-byte aligned, so that
2924 pointer tagging works. */
2925 /* For 32-bit case we don't need this, hence we use macro PEi386_IMAGE_OFFSET,
2926 which equals to 4 for 64-bit case and 0 for 32-bit case. */
2927 /* We allocate trampolines area for all symbols right behind
2928 image data, aligned on 8. */
2929 size = ((PEi386_IMAGE_OFFSET + size + 0x7) & ~0x7)
2930 + hdr.NumberOfSymbols * sizeof(SymbolExtra);
2931 #endif
2932 image = VirtualAlloc(NULL, size,
2933 MEM_RESERVE | MEM_COMMIT,
2934 PAGE_EXECUTE_READWRITE);
2935
2936 if (image == NULL) {
2937 errorBelch("%" PATH_FMT ": failed to allocate memory for image for %s",
2938 arch_name, member_name);
2939 return NULL;
2940 }
2941
2942 return image + PEi386_IMAGE_OFFSET;
2943 }
2944
2945 /* We use myindex to calculate array addresses, rather than
2946 simply doing the normal subscript thing. That's because
2947 some of the above structs have sizes which are not
2948 a whole number of words. GCC rounds their sizes up to a
2949 whole number of words, which means that the address calcs
2950 arising from using normal C indexing or pointer arithmetic
2951 are just plain wrong. Sigh.
2952 */
2953 static UChar *
2954 myindex ( int scale, void* base, int index )
2955 {
2956 return
2957 ((UChar*)base) + scale * index;
2958 }
2959
2960
2961 static void
2962 printName ( UChar* name, UChar* strtab )
2963 {
2964 if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2965 UInt32 strtab_offset = * (UInt32*)(name+4);
2966 debugBelch("%s", strtab + strtab_offset );
2967 } else {
2968 int i;
2969 for (i = 0; i < 8; i++) {
2970 if (name[i] == 0) break;
2971 debugBelch("%c", name[i] );
2972 }
2973 }
2974 }
2975
2976
2977 static void
2978 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
2979 {
2980 if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2981 UInt32 strtab_offset = * (UInt32*)(name+4);
2982 strncpy ( (char*)dst, (char*)strtab+strtab_offset, dstSize );
2983 dst[dstSize-1] = 0;
2984 } else {
2985 int i = 0;
2986 while (1) {
2987 if (i >= 8) break;
2988 if (name[i] == 0) break;
2989 dst[i] = name[i];
2990 i++;
2991 }
2992 dst[i] = 0;
2993 }
2994 }
2995
2996
2997 static UChar *
2998 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
2999 {
3000 UChar* newstr;
3001 /* If the string is longer than 8 bytes, look in the
3002 string table for it -- this will be correctly zero terminated.
3003 */
3004 if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
3005 UInt32 strtab_offset = * (UInt32*)(name+4);
3006 return ((UChar*)strtab) + strtab_offset;
3007 }
3008 /* Otherwise, if shorter than 8 bytes, return the original,
3009 which by defn is correctly terminated.
3010 */
3011 if (name[7]==0) return name;
3012 /* The annoying case: 8 bytes. Copy into a temporary
3013 (XXX which is never freed ...)
3014 */
3015 newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
3016 ASSERT(newstr);
3017 strncpy((char*)newstr,(char*)name,8);
3018 newstr[8] = 0;
3019 return newstr;
3020 }
3021
3022 /* Getting the name of a section is mildly tricky, so we make a
3023 function for it. Sadly, in one case we have to copy the string
3024 (when it is exactly 8 bytes long there's no trailing '\0'), so for
3025 consistency we *always* copy the string; the caller must free it
3026 */
3027 static char *
3028 cstring_from_section_name (UChar* name, UChar* strtab)
3029 {
3030 char *newstr;
3031
3032 if (name[0]=='/') {
3033 int strtab_offset = strtol((char*)name+1,NULL,10);
3034 int len = strlen(((char*)strtab) + strtab_offset);
3035
3036 newstr = stgMallocBytes(len+1, "cstring_from_section_symbol_name");
3037 strcpy((char*)newstr, (char*)((UChar*)strtab) + strtab_offset);
3038 return newstr;
3039 }
3040 else
3041 {
3042 newstr = stgMallocBytes(9, "cstring_from_section_symbol_name");
3043 ASSERT(newstr);
3044 strncpy((char*)newstr,(char*)name,8);
3045 newstr[8] = 0;
3046 return newstr;
3047 }
3048 }
3049
3050 /* Just compares the short names (first 8 chars) */
3051 static COFF_section *
3052 findPEi386SectionCalled ( ObjectCode* oc, UChar* name, UChar* strtab )
3053 {
3054 int i;
3055 rtsBool long_name = rtsFalse;
3056 COFF_header* hdr
3057 = (COFF_header*)(oc->image);
3058 COFF_section* sectab
3059 = (COFF_section*) (
3060 ((UChar*)(oc->image))
3061 + sizeof_COFF_header + hdr->SizeOfOptionalHeader
3062 );
3063 // String is longer than 8 bytes, swap in the proper
3064 // (NULL-terminated) version, and make a note that this
3065 // is a long name.
3066 if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
3067 UInt32 strtab_offset = * (UInt32*)(name+4);
3068 name = ((UChar*)strtab) + strtab_offset;
3069 long_name = rtsTrue;
3070 }
3071 for (i = 0; i < hdr->NumberOfSections; i++) {
3072 UChar* n1;
3073 UChar* n2;
3074 COFF_section* section_i
3075 = (COFF_section*)
3076 myindex ( sizeof_COFF_section, sectab, i );
3077 n1 = (UChar*) &(section_i->Name);
3078 n2 = name;
3079 // Long section names are prefixed with a slash, see
3080 // also cstring_from_section_name
3081 if (n1[0] == '/' && long_name) {
3082 // Long name check
3083 // We don't really want to make an assumption that the string
3084 // table indexes are the same, so we'll do a proper check.
3085 int n1_strtab_offset = strtol((char*)n1+1,NULL,10);
3086 n1 = (UChar*) (((char*)strtab) + n1_strtab_offset);
3087 if (0==strcmp((const char*)n1, (const char*)n2)) {
3088 return section_i;
3089 }
3090 } else if (n1[0] != '/' && !long_name) {
3091 // Short name check
3092 if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
3093 n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
3094 n1[6]==n2[6] && n1[7]==n2[7]) {
3095 return section_i;
3096 }
3097 } else {
3098 // guaranteed to mismatch, because we never attempt to link
3099 // in an executable where the section name may be truncated
3100 }
3101 }
3102
3103 return NULL;
3104 }
3105
3106 /* See Note [mingw-w64 name decoration scheme] */
3107 #ifndef x86_64_HOST_ARCH
3108 static void
3109 zapTrailingAtSign ( UChar* sym )
3110 {
3111 # define my_isdigit(c) ((c) >= '0' && (c) <= '9')
3112 int i, j;
3113 if (sym[0] == 0) return;
3114 i = 0;
3115 while (sym[i] != 0) i++;
3116 i--;
3117 j = i;
3118 while (j > 0 && my_isdigit(sym[j])) j--;
3119 if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
3120 # undef my_isdigit
3121 }
3122 #endif
3123
3124 /* See Note [mingw-w64 name decoration scheme] */
3125 #ifndef x86_64_HOST_ARCH
3126 #define STRIP_LEADING_UNDERSCORE 1
3127 #else
3128 #define STRIP_LEADING_UNDERSCORE 0
3129 #endif
3130
3131 /*
3132 Note [mingw-w64 name decoration scheme]
3133
3134 What's going on with name decoration? Well, original code
3135 have some crufty and ad-hocish paths related mostly to very old
3136 mingw gcc/binutils/runtime combinations. Now mingw-w64 offers pretty
3137 uniform and MS-compatible decoration scheme across its tools and runtime.
3138
3139 The scheme is pretty straightforward: on 32 bit objects symbols are exported
3140 with underscore prepended (and @ + stack size suffix appended for stdcall
3141 functions), on 64 bits no underscore is prepended and no suffix is appended
3142 because we have no stdcall convention on 64 bits.
3143
3144 See #9218
3145 */
3146
3147 static void *
3148 lookupSymbolInDLLs ( UChar *lbl )
3149 {
3150 OpenedDLL* o_dll;
3151 void *sym;
3152
3153 for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
3154 /* debugBelch("look in %ls for %s\n", o_dll->name, lbl); */
3155
3156 sym = GetProcAddress(o_dll->instance, (char*)(lbl+STRIP_LEADING_UNDERSCORE));
3157 if (sym != NULL) {
3158 /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
3159 return sym;
3160 }
3161
3162 /* Ticket #2283.
3163 Long description: http://support.microsoft.com/kb/132044
3164 tl;dr:
3165 If C/C++ compiler sees __declspec(dllimport) ... foo ...
3166 it generates call *__imp_foo, and __imp_foo here has exactly
3167 the same semantics as in __imp_foo = GetProcAddress(..., "foo")
3168 */
3169 if (sym == NULL && strncmp ((const char*)lbl, "__imp_", 6) == 0) {
3170 sym = GetProcAddress(o_dll->instance, (char*)(lbl+6+STRIP_LEADING_UNDERSCORE));
3171 if (sym != NULL) {
3172 IndirectAddr* ret;
3173 ret = stgMallocBytes( sizeof(IndirectAddr), "lookupSymbolInDLLs" );
3174 ret->addr = sym;
3175 ret->next = indirects;
3176 indirects = ret;
3177 IF_DEBUG(linker,
3178 debugBelch("warning: %s from %S is linked instead of %s",
3179 (char*)(lbl+6+STRIP_LEADING_UNDERSCORE), o_dll->name, (char*)lbl));
3180 return (void*) & ret->addr;
3181 }
3182 }
3183
3184 sym = GetProcAddress(o_dll->instance, (char*)lbl);
3185 if (sym != NULL) {
3186 /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
3187 return sym;
3188 }
3189 }
3190 return NULL;
3191 }
3192
3193 static int
3194 verifyCOFFHeader (COFF_header *hdr, pathchar *fileName)
3195 {
3196 #if defined(i386_HOST_ARCH)
3197 if (hdr->Machine != 0x14c) {
3198 errorBelch("%" PATH_FMT ": Not x86 PEi386", fileName);
3199 return 0;
3200 }
3201 #elif defined(x86_64_HOST_ARCH)
3202 if (hdr->Machine != 0x8664) {
3203 errorBelch("%" PATH_FMT ": Not x86_64 PEi386", fileName);
3204 return 0;
3205 }
3206 #else
3207 errorBelch("PEi386 not supported on this arch");
3208 #endif
3209
3210 if (hdr->SizeOfOptionalHeader != 0) {
3211 errorBelch("%" PATH_FMT ": PEi386 with nonempty optional header",
3212 fileName);
3213 return 0;
3214 }
3215 if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
3216 (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
3217 (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
3218 (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
3219 errorBelch("%" PATH_FMT ": Not a PEi386 object file", fileName);
3220 return 0;
3221 }
3222 if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
3223 /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
3224 errorBelch("%" PATH_FMT ": Invalid PEi386 word size or endiannness: %d",
3225 fileName,
3226 (int)(hdr->Characteristics));
3227 return 0;
3228 }
3229 return 1;
3230 }
3231
3232 static int
3233 ocVerifyImage_PEi386 ( ObjectCode* oc )
3234 {
3235 int i;
3236 UInt32 j, noRelocs;
3237 COFF_header* hdr;
3238 COFF_section* sectab;
3239 COFF_symbol* symtab;
3240 UChar* strtab;
3241 /* debugBelch("\nLOADING %s\n", oc->fileName); */
3242 hdr = (COFF_header*)(oc->image);
3243 sectab = (COFF_section*) (
3244 ((UChar*)(oc->image))
3245 + sizeof_COFF_header + hdr->SizeOfOptionalHeader
3246 );
3247 symtab = (COFF_symbol*) (
3248 ((UChar*)(oc->image))
3249 + hdr->PointerToSymbolTable
3250 );
3251 strtab = ((UChar*)symtab)
3252 + hdr->NumberOfSymbols * sizeof_COFF_symbol;
3253
3254 if (!verifyCOFFHeader(hdr, oc->fileName)) {
3255 return 0;
3256 }
3257
3258 /* If the string table size is way crazy, this might indicate that
3259 there are more than 64k relocations, despite claims to the
3260 contrary. Hence this test. */
3261 /* debugBelch("strtab size %d\n", * (UInt32*)strtab); */
3262 #if 0
3263 if ( (*(UInt32*)strtab) > 600000 ) {
3264 /* Note that 600k has no special significance other than being
3265 big enough to handle the almost-2MB-sized lumps that
3266 constitute HSwin32*.o. */
3267 debugBelch("PEi386 object has suspiciously large string table; > 64k relocs?");
3268 return 0;
3269 }
3270 #endif
3271
3272 /* No further verification after this point; only debug printing. */
3273 i = 0;
3274 IF_DEBUG(linker, i=1);
3275 if (i == 0) return 1;
3276
3277 debugBelch( "sectab offset = %" FMT_Int "\n", ((UChar*)sectab) - ((UChar*)hdr) );
3278 debugBelch( "symtab offset = %" FMT_Int "\n", ((UChar*)symtab) - ((UChar*)hdr) );
3279 debugBelch( "strtab offset = %" FMT_Int "\n", ((UChar*)strtab) - ((UChar*)hdr) );
3280
3281 debugBelch("\n" );
3282 debugBelch( "Machine: 0x%x\n", (UInt32)(hdr->Machine) );
3283 debugBelch( "# sections: %d\n", (UInt32)(hdr->NumberOfSections) );
3284 debugBelch( "time/date: 0x%x\n", (UInt32)(hdr->TimeDateStamp) );
3285 debugBelch( "symtab offset: %d\n", (UInt32)(hdr->PointerToSymbolTable) );
3286 debugBelch( "# symbols: %d\n", (UInt32)(hdr->NumberOfSymbols) );
3287 debugBelch( "sz of opt hdr: %d\n", (UInt32)(hdr->SizeOfOptionalHeader) );
3288 debugBelch( "characteristics: 0x%x\n", (UInt32)(hdr->Characteristics) );
3289
3290 /* Print the section table. */
3291 debugBelch("\n" );
3292 for (i = 0; i < hdr->NumberOfSections; i++) {
3293 COFF_reloc* reltab;
3294 COFF_section* sectab_i
3295 = (COFF_section*)
3296 myindex ( sizeof_COFF_section, sectab, i );
3297 debugBelch(
3298 "\n"
3299 "section %d\n"
3300 " name `",
3301 i
3302 );
3303 printName ( sectab_i->Name, strtab );
3304 debugBelch(
3305 "'\n"
3306 " vsize %d\n"
3307 " vaddr %d\n"
3308 " data sz %d\n"
3309 " data off %d\n"
3310 " num rel %d\n"
3311 " off rel %d\n"
3312 " ptr raw 0x%x\n",
3313 sectab_i->VirtualSize,
3314 sectab_i->VirtualAddress,
3315 sectab_i->SizeOfRawData,
3316 sectab_i->PointerToRawData,
3317 sectab_i->NumberOfRelocations,
3318 sectab_i->PointerToRelocations,
3319 sectab_i->PointerToRawData
3320 );
3321 reltab = (COFF_reloc*) (
3322 ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
3323 );
3324
3325 if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
3326 /* If the relocation field (a short) has overflowed, the
3327 * real count can be found in the first reloc entry.
3328 *
3329 * See Section 4.1 (last para) of the PE spec (rev6.0).
3330 */
3331 COFF_reloc* rel = (COFF_reloc*)
3332 myindex ( sizeof_COFF_reloc, reltab, 0 );
3333 noRelocs = rel->VirtualAddress;
3334 j = 1;
3335 } else {
3336 noRelocs = sectab_i->NumberOfRelocations;
3337 j = 0;
3338 }
3339
3340 for (; j < noRelocs; j++) {
3341 COFF_symbol* sym;
3342 COFF_reloc* rel = (COFF_reloc*)
3343 myindex ( sizeof_COFF_reloc, reltab, j );
3344 debugBelch(
3345 " type 0x%-4x vaddr 0x%-8x name `",
3346 (UInt32)rel->Type,
3347 rel->VirtualAddress );
3348 sym = (COFF_symbol*)
3349 myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
3350 /* Hmm..mysterious looking offset - what's it for? SOF */
3351 printName ( sym->Name, strtab -10 );
3352 debugBelch("'\n" );
3353 }
3354
3355 debugBelch("\n" );
3356 }
3357 debugBelch("\n" );
3358 debugBelch("string table has size 0x%x\n", * (UInt32*)strtab );
3359 debugBelch("---START of string table---\n");
3360 for (i = 4; i < *(Int32*)strtab; i++) {
3361 if (strtab[i] == 0)
3362 debugBelch("\n"); else
3363 debugBelch("%c", strtab[i] );
3364 }
3365 debugBelch("--- END of string table---\n");
3366
3367 debugBelch("\n" );
3368 i = 0;
3369 while (1) {
3370 COFF_symbol* symtab_i;
3371 if (i >= (Int32)(hdr->NumberOfSymbols)) break;
3372 symtab_i = (COFF_symbol*)
3373 myindex ( sizeof_COFF_symbol, symtab, i );
3374 debugBelch(
3375 "symbol %d\n"
3376 " name `",
3377 i
3378 );
3379 printName ( symtab_i->Name, strtab );
3380 debugBelch(
3381 "'\n"
3382 " value 0x%x\n"
3383 " 1+sec# %d\n"
3384 " type 0x%x\n"
3385 " sclass 0x%x\n"
3386 " nAux %d\n",
3387 symtab_i->Value,
3388 (Int32)(symtab_i->SectionNumber),
3389 (UInt32)symtab_i->Type,
3390 (UInt32)symtab_i->StorageClass,
3391 (UInt32)symtab_i->NumberOfAuxSymbols
3392 );
3393 i += symtab_i->NumberOfAuxSymbols;
3394 i++;
3395 }
3396
3397 debugBelch("\n" );
3398 return 1;
3399 }
3400
3401
3402 static int
3403 ocGetNames_PEi386 ( ObjectCode* oc )
3404 {
3405 COFF_header* hdr;
3406 COFF_section* sectab;
3407 COFF_symbol* symtab;
3408 UChar* strtab;
3409
3410 UChar* sname;
3411 void* addr;
3412 int i;
3413
3414 hdr = (COFF_header*)(oc->image);
3415 sectab = (COFF_section*) (
3416 ((UChar*)(oc->image))
3417 + sizeof_COFF_header + hdr->SizeOfOptionalHeader
3418 );
3419 symtab = (COFF_symbol*) (
3420 ((UChar*)(oc->image))
3421 + hdr->PointerToSymbolTable
3422 );
3423 strtab = ((UChar*)(oc->image))
3424 + hdr->PointerToSymbolTable
3425 + hdr->NumberOfSymbols * sizeof_COFF_symbol;
3426
3427 /* Allocate space for any (local, anonymous) .bss sections. */
3428
3429 for (i = 0; i < hdr->NumberOfSections; i++) {
3430 UInt32 bss_sz;
3431 UChar* zspace;
3432 COFF_section* sectab_i
3433 = (COFF_section*)
3434 myindex ( sizeof_COFF_section, sectab, i );
3435
3436 char *secname = cstring_from_section_name(sectab_i->Name, strtab);
3437
3438 if (0 != strcmp(secname, ".bss")) {
3439 stgFree(secname);
3440 continue;
3441 }
3442
3443 stgFree(secname);
3444
3445 /* sof 10/05: the PE spec text isn't too clear regarding what
3446 * the SizeOfRawData field is supposed to hold for object
3447 * file sections containing just uninitialized data -- for executables,
3448 * it is supposed to be zero; unclear what it's supposed to be
3449 * for object files. However, VirtualSize is guaranteed to be
3450 * zero for object files, which definitely suggests that SizeOfRawData
3451 * will be non-zero (where else would the size of this .bss section be
3452 * stored?) Looking at the COFF_section info for incoming object files,
3453 * this certainly appears to be the case.
3454 *
3455 * => I suspect we've been incorrectly handling .bss sections in (relocatable)
3456 * object files up until now. This turned out to bite us with ghc-6.4.1's use
3457 * of gcc-3.4.x, which has started to emit initially-zeroed-out local 'static'
3458 * variable decls into the .bss section. (The specific function in Q which
3459 * triggered this is libraries/base/cbits/dirUtils.c:__hscore_getFolderPath())
3460 */
3461 if (sectab_i->VirtualSize == 0 && sectab_i->SizeOfRawData == 0) continue;
3462 /* This is a non-empty .bss section. Allocate zeroed space for
3463 it, and set its PointerToRawData field such that oc->image +
3464 PointerToRawData == addr_of_zeroed_space. */
3465 bss_sz = sectab_i->VirtualSize;
3466 if ( bss_sz < sectab_i->SizeOfRawData) { bss_sz = sectab_i->SizeOfRawData; }
3467 zspace = stgCallocBytes(1, bss_sz, "ocGetNames_PEi386(anonymous bss)");
3468 sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
3469 addProddableBlock(oc, zspace, bss_sz);
3470 /* debugBelch("BSS anon section at 0x%x\n", zspace); */
3471 }
3472
3473 Section *sections;
3474 sections = (Section*)stgCallocBytes(
3475 sizeof(Section),
3476 hdr->NumberOfSections + 1, /* +1 for the global BSS section see below */
3477 "ocGetNames_ELF(sections)");
3478 oc->sections = sections;
3479 oc->n_sections = hdr->NumberOfSections + 1;
3480
3481 /* Copy section information into the ObjectCode. */
3482
3483 for (i = 0; i < hdr->NumberOfSections; i++) {
3484 UChar* start;
3485 UChar* end;
3486 UInt32 sz;
3487
3488 /* By default consider all section as CODE or DATA, which means we want to load them. */
3489 SectionKind kind
3490 = SECTIONKIND_CODE_OR_RODATA;
3491 COFF_section* sectab_i
3492 = (COFF_section*)
3493 myindex ( sizeof_COFF_section, sectab, i );
3494
3495 char *secname = cstring_from_section_name(sectab_i->Name, strtab);
3496
3497 IF_DEBUG(linker, debugBelch("section name = %s\n", secname ));
3498
3499 /* The PE file section flag indicates whether the section contains code or data. */
3500 if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
3501 sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
3502 kind = SECTIONKIND_CODE_OR_RODATA;
3503
3504 /* Check next if it contains any uninitialized data */
3505 if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_UNINITIALIZED_DATA)
3506 kind = SECTIONKIND_RWDATA;
3507
3508 /* Finally check if it can be discarded. This will also ignore .debug sections */
3509 if (sectab_i->Characteristics & MYIMAGE_SCN_MEM_DISCARDABLE ||
3510 sectab_i->Characteristics & MYIMAGE_SCN_LNK_REMOVE)
3511 kind = SECTIONKIND_OTHER;
3512
3513 if (0==strcmp(".ctors", (char*)secname))
3514 kind = SECTIONKIND_INIT_ARRAY;
3515
3516 ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
3517 sz = sectab_i->SizeOfRawData;
3518 if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
3519
3520 start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
3521 end = start + sz - 1;
3522
3523 if (kind != SECTIONKIND_OTHER && end >= start) {
3524 addSection(&sections[i], kind, SECTION_NOMEM, start, sz, 0, 0, 0);
3525 addProddableBlock(oc, start, end - start + 1);
3526 }
3527
3528 stgFree(secname);
3529 }
3530
3531 /* Copy exported symbols into the ObjectCode. */
3532
3533 oc->n_symbols = hdr->NumberOfSymbols;
3534 oc->symbols = stgCallocBytes(sizeof(char*), oc->n_symbols,
3535 "ocGetNames_PEi386(oc->symbols)");
3536
3537 /* Work out the size of the global BSS section */
3538 StgWord globalBssSize = 0;
3539 for (i=0; i < (int)hdr->NumberOfSymbols; i++) {
3540 COFF_symbol* symtab_i;
3541 symtab_i = (COFF_symbol*)
3542 myindex ( sizeof_COFF_symbol, symtab, i );
3543 if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
3544 && symtab_i->Value > 0) {
3545 globalBssSize += symtab_i->Value;
3546 }
3547 i += symtab_i->NumberOfAuxSymbols;
3548 }
3549
3550 /* Allocate BSS space */
3551 void *bss = NULL;
3552 if (globalBssSize > 0) {
3553 bss = stgCallocBytes(1, globalBssSize,
3554 "ocGetNames_PEi386(non-anonymous bss)");
3555 addSection(&sections[oc->n_sections-1],
3556 SECTIONKIND_RWDATA, SECTION_MALLOC,
3557 bss, globalBssSize, 0, 0, 0);
3558 IF_DEBUG(linker, debugBelch("bss @ %p %" FMT_Word "\n", bss, globalBssSize));
3559 addProddableBlock(oc, bss, globalBssSize);
3560 } else {
3561 addSection(&sections[oc->n_sections-1],
3562 SECTIONKIND_OTHER, SECTION_NOMEM, NULL, 0, 0, 0, 0);
3563 }
3564
3565 for (i = 0; i < oc->n_symbols; i++) {
3566 COFF_symbol* symtab_i;
3567 symtab_i = (COFF_symbol*)
3568 myindex ( sizeof_COFF_symbol, symtab, i );
3569
3570 addr = NULL;
3571
3572 HsBool isWeak = HS_BOOL_FALSE;
3573 if (symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
3574 /* This symbol is global and defined, viz, exported */
3575 /* for MYIMAGE_SYMCLASS_EXTERNAL
3576 && !MYIMAGE_SYM_UNDEFINED,
3577 the address of the symbol is:
3578 address of relevant section + offset in section
3579 */
3580 COFF_section* sectabent
3581 = (COFF_section*) myindex ( sizeof_COFF_section,
3582 sectab,
3583 symtab_i->SectionNumber-1 );
3584 if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
3585 || ( symtab_i->StorageClass == MYIMAGE_SYM_CLASS_STATIC
3586 && sectabent->Characteristics & MYIMAGE_SCN_LNK_COMDAT)
3587 ) {
3588 addr = ((UChar*)(oc->image))
3589 + (sectabent->PointerToRawData
3590 + symtab_i->Value);
3591 if (sectabent->Characteristics & MYIMAGE_SCN_LNK_COMDAT) {
3592 isWeak = HS_BOOL_TRUE;
3593 }
3594 }
3595 }
3596 else
3597 if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
3598 && symtab_i->Value > 0) {
3599 /* This symbol isn't in any section at all, ie, global bss.
3600 Allocate zeroed space for it from the BSS section */
3601 addr = bss;
3602 bss = (void *)((StgWord)bss + (StgWord)symtab_i->Value);
3603 IF_DEBUG(linker, debugBelch("bss symbol @ %p %u\n", addr, symtab_i->Value));
3604 }
3605
3606 if (addr != NULL ) {
3607 sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
3608 /* debugBelch("addSymbol %p `%s \n", addr,sname); */
3609 IF_DEBUG(linker, debugBelch("addSymbol %p `%s'\n", addr,sname);)
3610 ASSERT(i >= 0 && i < oc->n_symbols);
3611 /* cstring_from_COFF_symbol_name always succeeds. */
3612 oc->symbols[i] = (char*)sname;
3613 if (! ghciInsertSymbolTable(oc->fileName, symhash, (char*)sname, addr,
3614 isWeak, oc)) {
3615 return 0;
3616 }
3617 } else {
3618 # if 0
3619 debugBelch(
3620 "IGNORING symbol %d\n"
3621 " name `",
3622 i
3623 );
3624 printName ( symtab_i->Name, strtab );
3625 debugBelch(
3626 "'\n"
3627 " value 0x%x\n"
3628 " 1+sec# %d\n"
3629 " type 0x%x\n"
3630 " sclass 0x%x\n"
3631 " nAux %d\n",
3632 symtab_i->Value,
3633 (Int32)(symtab_i->SectionNumber),
3634 (UInt32)symtab_i->Type,
3635 (UInt32)symtab_i->StorageClass,
3636 (UInt32)symtab_i->NumberOfAuxSymbols
3637 );
3638 # endif
3639 }
3640
3641 i += symtab_i->NumberOfAuxSymbols;
3642 }
3643
3644 return 1;
3645 }
3646
3647 #if defined(x86_64_HOST_ARCH)
3648
3649 /* We've already reserved a room for symbol extras in loadObj,
3650 * so simply set correct pointer here.
3651 */
3652 static int
3653 ocAllocateSymbolExtras_PEi386 ( ObjectCode* oc )
3654 {
3655 oc->symbol_extras = (SymbolExtra*)(oc->image - PEi386_IMAGE_OFFSET
3656 + ((PEi386_IMAGE_OFFSET + oc->fileSize + 0x7) & ~0x7));
3657 oc->first_symbol_extra = 0;
3658 oc->n_symbol_extras = ((COFF_header*)oc->image)->NumberOfSymbols;
3659
3660 return 1;
3661 }
3662
3663 static size_t
3664 makeSymbolExtra_PEi386( ObjectCode* oc, size_t s, char* symbol )
3665 {
3666 unsigned int curr_thunk;
3667 SymbolExtra *extra;
3668
3669 curr_thunk = oc->first_symbol_extra;
3670 if (curr_thunk >= oc->n_symbol_extras) {
3671 barf("Can't allocate thunk for %s", symbol);
3672 }
3673
3674 extra = oc->symbol_extras + curr_thunk;
3675
3676 // jmp *-14(%rip)
3677 static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
3678 extra->addr = (uint64_t)s;
3679 memcpy(extra->jumpIsland, jmp, 6);
3680
3681 oc->first_symbol_extra++;
3682
3683 return (size_t)extra->jumpIsland;
3684 }
3685
3686 #endif
3687
3688 static int
3689 ocResolve_PEi386 ( ObjectCode* oc )
3690 {
3691 COFF_header* hdr;
3692 COFF_section* sectab;
3693 COFF_symbol* symtab;
3694 UChar* strtab;
3695
3696 UInt32 A;
3697 size_t S;
3698 void * pP;
3699
3700 int i;
3701 UInt32 j, noRelocs;
3702
3703 /* ToDo: should be variable-sized? But is at least safe in the
3704 sense of buffer-overrun-proof. */
3705 UChar symbol[1000];
3706 /* debugBelch("resolving for %s\n", oc->fileName); */
3707
3708 hdr = (COFF_header*)(oc->image);
3709 sectab = (COFF_section*) (
3710 ((UChar*)(oc->image))
3711 + sizeof_COFF_header + hdr->SizeOfOptionalHeader
3712 );
3713 symtab = (COFF_symbol*) (
3714 ((UChar*)(oc->image))
3715 + hdr->PointerToSymbolTable
3716 );
3717 strtab = ((UChar*)(oc->image))
3718 + hdr->PointerToSymbolTable
3719 + hdr->NumberOfSymbols * sizeof_COFF_symbol;
3720
3721 for (i = 0; i < hdr->NumberOfSections; i++) {
3722 COFF_section* sectab_i
3723 = (COFF_section*)
3724 myindex ( sizeof_COFF_section, sectab, i );
3725 COFF_reloc* reltab
3726 = (COFF_reloc*) (
3727 ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
3728 );
3729
3730 char *secname = cstring_from_section_name(sectab_i->Name, strtab);
3731
3732 /* Ignore sections called which contain stabs debugging information. */
3733 if ( 0 == strcmp(".stab", (char*)secname)
3734 || 0 == strcmp(".stabstr", (char*)secname)
3735 || 0 == strncmp(".pdata", (char*)secname, 6)
3736 || 0 == strncmp(".xdata", (char*)secname, 6)
3737 || 0 == strncmp(".debug", (char*)secname, 6)
3738 || 0 == strcmp(".rdata$zzz", (char*)secname)) {
3739 stgFree(secname);
3740 continue;
3741 }
3742
3743 stgFree(secname);
3744
3745 if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
3746 /* If the relocation field (a short) has overflowed, the
3747 * real count can be found in the first reloc entry.
3748 *
3749 * See Section 4.1 (last para) of the PE spec (rev6.0).
3750 *
3751 * Nov2003 update: the GNU linker still doesn't correctly
3752 * handle the generation of relocatable object files with
3753 * overflown relocations. Hence the output to warn of potential
3754 * troubles.
3755 */
3756 COFF_reloc* rel = (COFF_reloc*)
3757 myindex ( sizeof_COFF_reloc, reltab, 0 );
3758 noRelocs = rel->VirtualAddress;
3759
3760 /* 10/05: we now assume (and check for) a GNU ld that is capable
3761 * of handling object files with (>2^16) of relocs.
3762 */
3763 #if 0
3764 debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
3765 noRelocs);
3766 #endif
3767 j = 1;
3768 } else {
3769 noRelocs = sectab_i->NumberOfRelocations;
3770 j = 0;
3771 }
3772
3773 for (; j < noRelocs; j++) {
3774 COFF_symbol* sym;
3775 COFF_reloc* reltab_j
3776 = (COFF_reloc*)
3777 myindex ( sizeof_COFF_reloc, reltab, j );
3778
3779 /* the location to patch */
3780 pP = (
3781 ((UChar*)(oc->image))
3782 + (sectab_i->PointerToRawData
3783 + reltab_j->VirtualAddress
3784 - sectab_i->VirtualAddress )
3785 );
3786 /* the existing contents of pP */
3787 A = *(UInt32*)pP;
3788 /* the symbol to connect to */
3789 sym = (COFF_symbol*)
3790 myindex ( sizeof_COFF_symbol,
3791 symtab, reltab_j->SymbolTableIndex );
3792 IF_DEBUG(linker,
3793 debugBelch(
3794 "reloc sec %2d num %3d: type 0x%-4x "
3795 "vaddr 0x%-8x name `",
3796 i, j,
3797 (UInt32)reltab_j->Type,
3798 reltab_j->VirtualAddress );
3799 printName ( sym->Name, strtab );
3800 debugBelch("'\n" ));
3801
3802 if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
3803 COFF_section* section_sym
3804 = findPEi386SectionCalled ( oc, sym->Name, strtab );
3805 if (!section_sym) {
3806 errorBelch("%" PATH_FMT ": can't find section named: ", oc->fileName);
3807 printName(sym->Name, strtab);
3808 errorBelch(" in %s", secname);
3809 return 0;
3810 }
3811 S = ((size_t)(oc->image))
3812 + ((size_t)(section_sym->PointerToRawData))
3813 + ((size_t)(sym->Value));
3814 } else {
3815 copyName ( sym->Name, strtab, symbol, 1000-1 );
3816 S = (size_t) lookupSymbol_( (char*)symbol );
3817 if ((void*)S != NULL) goto foundit;
3818 errorBelch("%" PATH_FMT ": unknown symbol `%s'", oc->fileName, symbol);
3819 return 0;
3820 foundit:;
3821 }
3822 /* All supported relocations write at least 4 bytes */
3823 checkProddableBlock(oc, pP, 4);
3824 switch (reltab_j->Type) {
3825 #if defined(i386_HOST_ARCH)
3826 case MYIMAGE_REL_I386_DIR32:
3827 *(UInt32 *)pP = ((UInt32)S) + A;
3828 break;
3829 case MYIMAGE_REL_I386_REL32:
3830 /* Tricky. We have to insert a displacement at
3831 pP which, when added to the PC for the _next_
3832 insn, gives the address of the target (S).
3833 Problem is to know the address of the next insn
3834 when we only know pP. We assume that this
3835 literal field is always the last in the insn,
3836 so that the address of the next insn is pP+4
3837 -- hence the constant 4.
3838 Also I don't know if A should be added, but so
3839 far it has always been zero.
3840
3841 SOF 05/2005: 'A' (old contents of *pP) have been observed
3842 to contain values other than zero (the 'wx' object file
3843 that came with wxhaskell-0.9.4; dunno how it was compiled..).
3844 So, add displacement to old value instead of asserting
3845 A to be zero. Fixes wxhaskell-related crashes, and no other
3846 ill effects have been observed.
3847
3848 Update: the reason why we're seeing these more elaborate
3849 relocations is due to a switch in how the NCG compiles SRTs
3850 and offsets to them from info tables. SRTs live in .(ro)data,
3851 while info tables live in .text, causing GAS to emit REL32/DISP32
3852 relocations with non-zero values. Adding the displacement is
3853 the right thing to do.
3854 */
3855 *(UInt32 *)pP = ((UInt32)S) + A - ((UInt32)(size_t)pP) - 4;
3856 break;
3857 #elif defined(x86_64_HOST_ARCH)
3858 case 1: /* R_X86_64_64 (ELF constant 1) - IMAGE_REL_AMD64_ADDR64 (PE constant 1) */
3859 {
3860 UInt64 A;
3861 checkProddableBlock(oc, pP, 8);
3862 A = *(UInt64*)pP;
3863 *(UInt64 *)pP = ((UInt64)S) + ((UInt64)A);
3864 break;
3865 }
3866 case 2: /* R_X86_64_32 (ELF constant 10) - IMAGE_REL_AMD64_ADDR32 (PE constant 2) */
3867 case 3: /* R_X86_64_32S (ELF constant 11) - IMAGE_REL_AMD64_ADDR32NB (PE constant 3) */
3868 case 17: /* R_X86_64_32S ELF constant, no PE mapping. See note [ELF constant in PE file] */
3869 {
3870 size_t v;
3871 v = S + ((size_t)A);
3872 if (v >> 32) {
3873 copyName ( sym->Name, strtab, symbol, 1000-1 );
3874 S = makeSymbolExtra_PEi386(oc, S, (char *)symbol);
3875 /* And retry */
3876 v = S + ((size_t)A);
3877 if (v >> 32) {
3878 barf("IMAGE_REL_AMD64_ADDR32[NB]: High bits are set in %zx for %s",
3879 v, (char *)symbol);
3880 }
3881 }
3882 *(UInt32 *)pP = (UInt32)v;
3883 break;
3884 }
3885 case 4: /* R_X86_64_PC32 (ELF constant 2) - IMAGE_REL_AMD64_REL32 (PE constant 4) */
3886 {
3887 intptr_t v;
3888 v = ((intptr_t)S) + ((intptr_t)(Int32)A) - ((intptr_t)pP) - 4;
3889 if ((v >> 32) && ((-v) >> 32)) {
3890 /* Make the trampoline then */
3891 copyName ( sym->Name, strtab, symbol, 1000-1 );
3892 S = makeSymbolExtra_PEi386(oc, S, (char *)symbol);
3893 /* And retry */
3894 v = ((intptr_t)S) + ((intptr_t)(Int32)A) - ((intptr_t)pP) - 4;
3895 if ((v >> 32) && ((-v) >> 32)) {
3896 barf("IMAGE_REL_AMD64_REL32: High bits are set in %zx for %s",
3897 v, (char *)symbol);
3898 }
3899 }
3900 *(UInt32 *)pP = (UInt32)v;
3901 break;
3902 }
3903 #endif
3904 default:
3905 debugBelch("%" PATH_FMT ": unhandled PEi386 relocation type %d",
3906 oc->fileName, reltab_j->Type);
3907 return 0;
3908 }
3909
3910 }
3911 }
3912
3913 IF_DEBUG(linker, debugBelch("completed %" PATH_FMT, oc->fileName));
3914 return 1;
3915 }
3916
3917 /*
3918 Note [ELF constant in PE file]
3919
3920 For some reason, the PE files produced by GHC contain a linux
3921 relocation constant 17 (0x11) in the object files. As far as I (Phyx-) can tell
3922 this constant doesn't seem like it's coming from GHC, or at least I could not find
3923 anything in the .s output that GHC produces which specifies the relocation type.
3924
3925 This leads me to believe that this is a bug in GAS. However because this constant is
3926 there we must deal with it. This is done by mapping it to the equivalent in behaviour PE
3927 relocation constant 0x03.
3928
3929 See #9907
3930 */
3931
3932 static int
3933 ocRunInit_PEi386 ( ObjectCode *oc )
3934 {
3935 COFF_header* hdr;
3936 COFF_section* sectab;
3937 UChar* strtab;
3938 int i;
3939
3940 hdr = (COFF_header*)(oc->image);
3941 sectab = (COFF_section*) (
3942 ((UChar*)(oc->image))
3943 + sizeof_COFF_header + hdr->SizeOfOptionalHeader
3944 );
3945 strtab = ((UChar*)(oc->image))
3946 + hdr->PointerToSymbolTable
3947 + hdr->NumberOfSymbols * sizeof_COFF_symbol;
3948
3949 int argc, envc;
3950 char **argv, **envv;
3951
3952 getProgArgv(&argc, &argv);
3953 getProgEnvv(&envc, &envv);
3954
3955 for (i = 0; i < hdr->NumberOfSections; i++) {
3956 COFF_section* sectab_i
3957 = (COFF_section*)
3958 myindex ( sizeof_COFF_section, sectab, i );
3959 char *secname