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