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