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