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