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