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