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