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