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