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