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