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