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