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