Testsuite: Skip failing tests on PowerPC 64-bit
[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 "RtsSymbolInfo.h"
28 #include "Profiling.h"
29 #include "sm/OSMem.h"
30 #include "linker/M32Alloc.h"
31 #include "linker/CacheFlush.h"
32 #include "linker/SymbolExtras.h"
33 #include "PathUtils.h"
34
35 #if !defined(mingw32_HOST_OS)
36 #include "posix/Signals.h"
37 #endif
38
39 // get protos for is*()
40 #include <ctype.h>
41
42 #ifdef HAVE_SYS_TYPES_H
43 #include <sys/types.h>
44 #endif
45
46 #include <inttypes.h>
47 #include <stdlib.h>
48 #include <string.h>
49 #include <stdio.h>
50 #include <assert.h>
51
52 #ifdef HAVE_SYS_STAT_H
53 #include <sys/stat.h>
54 #endif
55
56 #if defined(HAVE_DLFCN_H)
57 #include <dlfcn.h>
58 #endif
59
60 #if defined(OBJFORMAT_ELF)
61 # include "linker/Elf.h"
62 # include <regex.h> // regex is already used by dlopen() so this is OK
63 // to use here without requiring an additional lib
64 #elif defined(OBJFORMAT_PEi386)
65 # include "linker/PEi386.h"
66 # include <windows.h>
67 #elif defined(OBJFORMAT_MACHO)
68 # include "linker/MachO.h"
69 # include <regex.h>
70 # include <mach/machine.h>
71 # include <mach-o/fat.h>
72 #endif
73
74 #if defined(x86_64_HOST_ARCH) && defined(darwin_HOST_OS)
75 #define ALWAYS_PIC
76 #endif
77
78 #if defined(dragonfly_HOST_OS)
79 #include <sys/tls.h>
80 #endif
81 /*
82 Note [runtime-linker-support]
83 -----------------------------
84 When adding support for a new platform to the runtime linker please
85 update `$TOP/configure.ac` under heading `Does target have runtime
86 linker support?`.
87 */
88 /* `symhash` is a Hash table mapping symbol names to RtsSymbolInfo.
89 This hashtable will contain information on all symbols
90 that we know of, however the .o they are in may not be loaded.
91
92 Until the ObjectCode the symbol belongs to is actually
93 loaded this symbol may be replaced. So do not rely on
94 addresses of unloaded symbols.
95
96 Note [runtime-linker-phases]
97 --------------------------------------
98 Broadly the behavior of the runtime linker can be
99 split into the following four phases:
100
101 - Indexing (e.g. ocVerifyImage and ocGetNames)
102 - Initialization (e.g. ocResolve and ocRunInit)
103 - Resolve (e.g. resolveObjs())
104 - Lookup (e.g. lookupSymbol)
105
106 This is to enable lazy loading of symbols. Eager loading is problematic
107 as it means that all symbols must be available, even those which we will
108 never use. This is especially painful on Windows, where the number of
109 libraries required to link things like mingwex grows to be quite high.
110
111 We proceed through these stages as follows,
112
113 * During Indexing we verify and open the ObjectCode and
114 perform a quick scan/indexing of the ObjectCode. All the work
115 required to actually load the ObjectCode is done.
116
117 All symbols from the ObjectCode are also inserted into
118 `symhash`, where possible duplicates are handled via the semantics
119 described in `ghciInsertSymbolTable`.
120
121 This phase will produce ObjectCode with status `OBJECT_LOADED` or `OBJECT_NEEDED`
122 depending on whether they are an archive member or not.
123
124 * During initialization we load ObjectCode, perform relocations, execute
125 static constructors etc. This phase may trigger other ObjectCodes to
126 be loaded because of the calls to lookupSymbol.
127
128 This phase will produce ObjectCode with status `OBJECT_NEEDED` if the
129 previous status was `OBJECT_LOADED`.
130
131 * During resolve we attempt to resolve all the symbols needed for the
132 initial link. This essentially means, that for any ObjectCode given
133 directly to the command-line we perform lookupSymbols on the required
134 symbols. lookupSymbols may trigger the loading of additional ObjectCode
135 if required.
136
137 This phase will produce ObjectCode with status `OBJECT_RESOLVED` if
138 the previous status was `OBJECT_NEEDED`.
139
140 * lookupSymbols is used to lookup any symbols required, both during initial
141 link and during statement and expression compilations in the REPL.
142 Declaration of e.g. a foreign import, will eventually call lookupSymbol
143 which will either fail (symbol unknown) or succeed (and possibly trigger a
144 load).
145
146 This phase may transition an ObjectCode from `OBJECT_LOADED` to `OBJECT_RESOLVED`
147
148 When a new scope is introduced (e.g. a new module imported) GHCi does a full re-link
149 by calling unloadObj and starting over.
150 When a new declaration or statement is performed ultimately lookupSymbol is called
151 without doing a re-link.
152
153 The goal of these different phases is to allow the linker to be able to perform
154 "lazy loading" of ObjectCode. The reason for this is that we want to only link
155 in symbols that are actually required for the link. This reduces:
156
157 1) Dependency chains, if A.o required a .o in libB but A.o isn't required to link
158 then we don't need to load libB. This means the dependency chain for libraries
159 such as mingw32 and mingwex can be broken down.
160
161 2) The number of duplicate symbols, since now only symbols that are
162 true duplicates will display the error.
163 */
164 /*Str*/HashTable *symhash;
165
166 /* List of currently loaded objects */
167 ObjectCode *objects = NULL; /* initially empty */
168
169 /* List of objects that have been unloaded via unloadObj(), but are waiting
170 to be actually freed via checkUnload() */
171 ObjectCode *unloaded_objects = NULL; /* initially empty */
172
173 #ifdef THREADED_RTS
174 /* This protects all the Linker's global state except unloaded_objects */
175 Mutex linker_mutex;
176 /*
177 * This protects unloaded_objects. We have a separate mutex for this, because
178 * the GC needs to access unloaded_objects in checkUnload, while the linker only
179 * needs to access unloaded_objects in unloadObj(), so this allows most linker
180 * operations proceed concurrently with the GC.
181 */
182 Mutex linker_unloaded_mutex;
183 #endif
184
185 /* Generic wrapper function to try and Resolve and RunInit oc files */
186 int ocTryLoad( ObjectCode* oc );
187
188 /* Link objects into the lower 2Gb on x86_64. GHC assumes the
189 * small memory model on this architecture (see gcc docs,
190 * -mcmodel=small).
191 *
192 * MAP_32BIT not available on OpenBSD/amd64
193 */
194 #if defined(x86_64_HOST_ARCH) && defined(MAP_32BIT)
195 #define TRY_MAP_32BIT MAP_32BIT
196 #else
197 #define TRY_MAP_32BIT 0
198 #endif
199
200 /*
201 * Due to the small memory model (see above), on x86_64 we have to map
202 * all our non-PIC object files into the low 2Gb of the address space
203 * (why 2Gb and not 4Gb? Because all addresses must be reachable
204 * using a 32-bit signed PC-relative offset). On Linux we can do this
205 * using the MAP_32BIT flag to mmap(), however on other OSs
206 * (e.g. *BSD, see #2063, and also on Linux inside Xen, see #2512), we
207 * can't do this. So on these systems, we have to pick a base address
208 * in the low 2Gb of the address space and try to allocate memory from
209 * there.
210 *
211 * We pick a default address based on the OS, but also make this
212 * configurable via an RTS flag (+RTS -xm)
213 */
214 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
215
216 #if defined(MAP_32BIT)
217 // Try to use MAP_32BIT
218 #define MMAP_32BIT_BASE_DEFAULT 0
219 #else
220 // A guess: 1Gb.
221 #define MMAP_32BIT_BASE_DEFAULT 0x40000000
222 #endif
223
224 static void *mmap_32bit_base = (void *)MMAP_32BIT_BASE_DEFAULT;
225 #endif
226
227 static void ghciRemoveSymbolTable(HashTable *table, const SymbolName* key,
228 ObjectCode *owner)
229 {
230 RtsSymbolInfo *pinfo = lookupStrHashTable(table, key);
231 if (!pinfo || owner != pinfo->owner) return;
232 removeStrHashTable(table, key, NULL);
233 stgFree(pinfo);
234 }
235
236 /* -----------------------------------------------------------------------------
237 * Insert symbols into hash tables, checking for duplicates.
238 *
239 * Returns: 0 on failure, nonzero on success
240 */
241 /*
242 Note [weak-symbols-support]
243 -------------------------------------
244 While ghciInsertSymbolTable does implement extensive
245 logic for weak symbol support, weak symbols are not currently
246 fully supported by the RTS. This code is mostly here for COMDAT
247 support which uses the weak symbols support.
248
249 Linking weak symbols defined purely in C code with other C code
250 should also work, probably. Observing weak symbols in Haskell
251 won't.
252
253 Some test have been written for weak symbols but have been disabled
254 mostly because it's unsure how the weak symbols support should look.
255 See Trac #11223
256 */
257 int ghciInsertSymbolTable(
258 pathchar* obj_name,
259 HashTable *table,
260 const SymbolName* key,
261 SymbolAddr* data,
262 HsBool weak,
263 ObjectCode *owner)
264 {
265 RtsSymbolInfo *pinfo = lookupStrHashTable(table, key);
266 if (!pinfo) /* new entry */
267 {
268 pinfo = stgMallocBytes(sizeof (*pinfo), "ghciInsertToSymbolTable");
269 pinfo->value = data;
270 pinfo->owner = owner;
271 pinfo->weak = weak;
272 insertStrHashTable(table, key, pinfo);
273 return 1;
274 }
275 else if (weak && data && pinfo->weak && !pinfo->value)
276 {
277 /* The existing symbol is weak with a zero value; replace it with the new symbol. */
278 pinfo->value = data;
279 pinfo->owner = owner;
280 return 1;
281 }
282 else if (weak)
283 {
284 return 1; /* weak symbol, because the symbol is weak, data = 0 and we
285 already know of another copy throw this one away.
286
287 or both weak symbols have a nonzero value. Keep the existing one.
288
289 This also preserves the semantics of linking against
290 the first symbol we find. */
291 }
292 else if (pinfo->weak && !weak) /* weak symbol is in the table */
293 {
294 /* override the weak definition with the non-weak one */
295 pinfo->value = data;
296 pinfo->owner = owner;
297 pinfo->weak = HS_BOOL_FALSE;
298 return 1;
299 }
300 else if ( pinfo->owner
301 && pinfo->owner->status != OBJECT_RESOLVED
302 && pinfo->owner->status != OBJECT_NEEDED)
303 {
304 /* If the other symbol hasn't been loaded or will be loaded and we want to
305 explicitly load the new one, we can just swap it out and load the one
306 that has been requested. If not, just keep the first one encountered.
307
308 Because the `symHash' table consists symbols we've also not loaded but
309 found during the initial scan this is safe to do. If however the existing
310 symbol has been loaded then it means we have a duplicate.
311
312 This is essentially emulating the behavior of a linker wherein it will always
313 link in object files that are .o file arguments, but only take object files
314 from archives as needed. */
315 if (owner && (owner->status == OBJECT_NEEDED || owner->status == OBJECT_RESOLVED)) {
316 pinfo->value = data;
317 pinfo->owner = owner;
318 pinfo->weak = weak;
319 }
320
321 return 1;
322 }
323 else if (pinfo->owner == owner)
324 {
325 /* If it's the same symbol, ignore. This makes ghciInsertSymbolTable idempotent */
326 return 1;
327 }
328 else if (owner && owner->status == OBJECT_LOADED)
329 {
330 /* If the duplicate symbol is just in state OBJECT_LOADED it means we're in discovery of an
331 member. It's not a real duplicate yet. If the Oc Becomes OBJECT_NEEDED then ocTryLoad will
332 call this function again to trigger the duplicate error. */
333 return 1;
334 }
335
336 pathchar* archiveName = NULL;
337 debugBelch(
338 "GHC runtime linker: fatal error: I found a duplicate definition for symbol\n"
339 " %s\n"
340 "whilst processing object file\n"
341 " %" PATH_FMT "\n"
342 "The symbol was previously defined in\n"
343 " %" PATH_FMT "\n"
344 "This could be caused by:\n"
345 " * Loading two different object files which export the same symbol\n"
346 " * Specifying the same object file twice on the GHCi command line\n"
347 " * An incorrect `package.conf' entry, causing some object to be\n"
348 " loaded twice.\n",
349 (char*)key,
350 obj_name,
351 pinfo->owner == NULL ? WSTR("(GHCi built-in symbols)") :
352 pinfo->owner->archiveMemberName ? archiveName = mkPath(pinfo->owner->archiveMemberName)
353 : pinfo->owner->fileName
354 );
355
356 if (archiveName)
357 {
358 stgFree(archiveName);
359 archiveName = NULL;
360 }
361 return 0;
362 }
363
364 /* -----------------------------------------------------------------------------
365 * Looks up symbols into hash tables.
366 *
367 * Returns: 0 on failure and result is not set,
368 * nonzero on success and result set to nonzero pointer
369 */
370 HsBool ghciLookupSymbolInfo(HashTable *table,
371 const SymbolName* key, RtsSymbolInfo **result)
372 {
373 RtsSymbolInfo *pinfo = lookupStrHashTable(table, key);
374 if (!pinfo) {
375 *result = NULL;
376 return HS_BOOL_FALSE;
377 }
378 if (pinfo->weak)
379 IF_DEBUG(linker, debugBelch("lookupSymbolInfo: promoting %s\n", key));
380 /* Once it's looked up, it can no longer be overridden */
381 pinfo->weak = HS_BOOL_FALSE;
382
383 *result = pinfo;
384 return HS_BOOL_TRUE;
385 }
386
387 /* -----------------------------------------------------------------------------
388 * initialize the object linker
389 */
390
391
392 static int linker_init_done = 0 ;
393
394 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
395 static void *dl_prog_handle;
396 static regex_t re_invalid;
397 static regex_t re_realso;
398 #ifdef THREADED_RTS
399 static Mutex dl_mutex; // mutex to protect dlopen/dlerror critical section
400 #endif
401 #endif
402
403 void initLinker (void)
404 {
405 // default to retaining CAFs for backwards compatibility. Most
406 // users will want initLinker_(0): otherwise unloadObj() will not
407 // be able to unload object files when they contain CAFs.
408 initLinker_(1);
409 }
410
411 void
412 initLinker_ (int retain_cafs)
413 {
414 RtsSymbolVal *sym;
415 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
416 int compileResult;
417 #endif
418
419 IF_DEBUG(linker, debugBelch("initLinker: start\n"));
420
421 /* Make initLinker idempotent, so we can call it
422 before every relevant operation; that means we
423 don't need to initialise the linker separately */
424 if (linker_init_done == 1) {
425 IF_DEBUG(linker, debugBelch("initLinker: idempotent return\n"));
426 return;
427 } else {
428 linker_init_done = 1;
429 }
430
431 objects = NULL;
432 unloaded_objects = NULL;
433
434 #if defined(THREADED_RTS)
435 initMutex(&linker_mutex);
436 initMutex(&linker_unloaded_mutex);
437 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
438 initMutex(&dl_mutex);
439 #endif
440 #endif
441
442 symhash = allocStrHashTable();
443
444 /* populate the symbol table with stuff from the RTS */
445 for (sym = rtsSyms; sym->lbl != NULL; sym++) {
446 if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"),
447 symhash, sym->lbl, sym->addr, HS_BOOL_FALSE, NULL)) {
448 barf("ghciInsertSymbolTable failed");
449 }
450 IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
451 }
452 # if defined(OBJFORMAT_MACHO) && defined(powerpc_HOST_ARCH)
453 machoInitSymbolsWithoutUnderscore();
454 # endif
455 /* GCC defines a special symbol __dso_handle which is resolved to NULL if
456 referenced from a statically linked module. We need to mimic this, but
457 we cannot use NULL because we use it to mean nonexistent symbols. So we
458 use an arbitrary (hopefully unique) address here.
459 */
460 if (! ghciInsertSymbolTable(WSTR("(GHCi special symbols)"),
461 symhash, "__dso_handle", (void *)0x12345687, HS_BOOL_FALSE, NULL)) {
462 barf("ghciInsertSymbolTable failed");
463 }
464
465 // Redirect newCAF to newRetainedCAF if retain_cafs is true.
466 if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"), symhash,
467 MAYBE_LEADING_UNDERSCORE_STR("newCAF"),
468 retain_cafs ? newRetainedCAF : newGCdCAF,
469 HS_BOOL_FALSE, NULL)) {
470 barf("ghciInsertSymbolTable failed");
471 }
472
473 # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
474 # if defined(RTLD_DEFAULT)
475 dl_prog_handle = RTLD_DEFAULT;
476 # else
477 dl_prog_handle = dlopen(NULL, RTLD_LAZY);
478 # endif /* RTLD_DEFAULT */
479
480 compileResult = regcomp(&re_invalid,
481 "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)",
482 REG_EXTENDED);
483 if (compileResult != 0) {
484 barf("Compiling re_invalid failed");
485 }
486 compileResult = regcomp(&re_realso,
487 "(GROUP|INPUT) *\\( *([^ )]+)",
488 REG_EXTENDED);
489 if (compileResult != 0) {
490 barf("Compiling re_realso failed");
491 }
492 # endif
493
494 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
495 if (RtsFlags.MiscFlags.linkerMemBase != 0) {
496 // User-override for mmap_32bit_base
497 mmap_32bit_base = (void*)RtsFlags.MiscFlags.linkerMemBase;
498 }
499 #endif
500
501 if (RTS_LINKER_USE_MMAP)
502 m32_allocator_init();
503
504 #if defined(OBJFORMAT_PEi386)
505 initLinker_PEi386();
506 #endif
507
508 IF_DEBUG(linker, debugBelch("initLinker: done\n"));
509 return;
510 }
511
512 void
513 exitLinker( void ) {
514 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
515 if (linker_init_done == 1) {
516 regfree(&re_invalid);
517 regfree(&re_realso);
518 #ifdef THREADED_RTS
519 closeMutex(&dl_mutex);
520 #endif
521 }
522 #endif
523 if (linker_init_done == 1) {
524 freeHashTable(symhash, free);
525 }
526 #ifdef THREADED_RTS
527 closeMutex(&linker_mutex);
528 #endif
529 }
530
531 /* -----------------------------------------------------------------------------
532 * Loading DLL or .so dynamic libraries
533 * -----------------------------------------------------------------------------
534 *
535 * Add a DLL from which symbols may be found. In the ELF case, just
536 * do RTLD_GLOBAL-style add, so no further messing around needs to
537 * happen in order that symbols in the loaded .so are findable --
538 * lookupSymbol() will subsequently see them by dlsym on the program's
539 * dl-handle. Returns NULL if success, otherwise ptr to an err msg.
540 *
541 * In the PEi386 case, open the DLLs and put handles to them in a
542 * linked list. When looking for a symbol, try all handles in the
543 * list. This means that we need to load even DLLs that are guaranteed
544 * to be in the ghc.exe image already, just so we can get a handle
545 * to give to loadSymbol, so that we can find the symbols. For such
546 * libraries, the LoadLibrary call should be a no-op except for returning
547 * the handle.
548 *
549 */
550
551 # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
552
553 /* Suppose in ghci we load a temporary SO for a module containing
554 f = 1
555 and then modify the module, recompile, and load another temporary
556 SO with
557 f = 2
558 Then as we don't unload the first SO, dlsym will find the
559 f = 1
560 symbol whereas we want the
561 f = 2
562 symbol. We therefore need to keep our own SO handle list, and
563 try SOs in the right order. */
564
565 typedef
566 struct _OpenedSO {
567 struct _OpenedSO* next;
568 void *handle;
569 }
570 OpenedSO;
571
572 /* A list thereof. */
573 static OpenedSO* openedSOs = NULL;
574
575 static const char *
576 internal_dlopen(const char *dll_name)
577 {
578 OpenedSO* o_so;
579 void *hdl;
580 const char *errmsg;
581 char *errmsg_copy;
582
583 // omitted: RTLD_NOW
584 // see http://www.haskell.org/pipermail/cvs-ghc/2007-September/038570.html
585 IF_DEBUG(linker,
586 debugBelch("internal_dlopen: dll_name = '%s'\n", dll_name));
587
588 //-------------- Begin critical section ------------------
589 // This critical section is necessary because dlerror() is not
590 // required to be reentrant (see POSIX -- IEEE Std 1003.1-2008)
591 // Also, the error message returned must be copied to preserve it
592 // (see POSIX also)
593
594 ACQUIRE_LOCK(&dl_mutex);
595 hdl = dlopen(dll_name, RTLD_LAZY|RTLD_LOCAL); /* see Note [RTLD_LOCAL] */
596
597 errmsg = NULL;
598 if (hdl == NULL) {
599 /* dlopen failed; return a ptr to the error msg. */
600 errmsg = dlerror();
601 if (errmsg == NULL) errmsg = "addDLL: unknown error";
602 errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL");
603 strcpy(errmsg_copy, errmsg);
604 errmsg = errmsg_copy;
605 } else {
606 o_so = stgMallocBytes(sizeof(OpenedSO), "addDLL");
607 o_so->handle = hdl;
608 o_so->next = openedSOs;
609 openedSOs = o_so;
610 }
611
612 RELEASE_LOCK(&dl_mutex);
613 //--------------- End critical section -------------------
614
615 return errmsg;
616 }
617
618 /*
619 Note [RTLD_LOCAL]
620
621 In GHCi we want to be able to override previous .so's with newly
622 loaded .so's when we recompile something. This further implies that
623 when we look up a symbol in internal_dlsym() we have to iterate
624 through the loaded libraries (in order from most recently loaded to
625 oldest) looking up the symbol in each one until we find it.
626
627 However, this can cause problems for some symbols that are copied
628 by the linker into the executable image at runtime - see #8935 for a
629 lengthy discussion. To solve that problem we need to look up
630 symbols in the main executable *first*, before attempting to look
631 them up in the loaded .so's. But in order to make that work, we
632 have to always call dlopen with RTLD_LOCAL, so that the loaded
633 libraries don't populate the global symbol table.
634 */
635
636 static void *
637 internal_dlsym(const char *symbol) {
638 OpenedSO* o_so;
639 void *v;
640
641 // We acquire dl_mutex as concurrent dl* calls may alter dlerror
642 ACQUIRE_LOCK(&dl_mutex);
643 dlerror();
644 // look in program first
645 v = dlsym(dl_prog_handle, symbol);
646 if (dlerror() == NULL) {
647 RELEASE_LOCK(&dl_mutex);
648 return v;
649 }
650
651 for (o_so = openedSOs; o_so != NULL; o_so = o_so->next) {
652 v = dlsym(o_so->handle, symbol);
653 if (dlerror() == NULL) {
654 RELEASE_LOCK(&dl_mutex);
655 return v;
656 }
657 }
658 RELEASE_LOCK(&dl_mutex);
659 return v;
660 }
661 # endif
662
663 const char *
664 addDLL( pathchar *dll_name )
665 {
666 # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
667 /* ------------------- ELF DLL loader ------------------- */
668
669 #define NMATCH 5
670 regmatch_t match[NMATCH];
671 const char *errmsg;
672 FILE* fp;
673 size_t match_length;
674 #define MAXLINE 1000
675 char line[MAXLINE];
676 int result;
677
678 IF_DEBUG(linker, debugBelch("addDLL: dll_name = '%s'\n", dll_name));
679 errmsg = internal_dlopen(dll_name);
680
681 if (errmsg == NULL) {
682 return NULL;
683 }
684
685 // GHC Trac ticket #2615
686 // On some systems (e.g., Gentoo Linux) dynamic files (e.g. libc.so)
687 // contain linker scripts rather than ELF-format object code. This
688 // code handles the situation by recognizing the real object code
689 // file name given in the linker script.
690 //
691 // If an "invalid ELF header" error occurs, it is assumed that the
692 // .so file contains a linker script instead of ELF object code.
693 // In this case, the code looks for the GROUP ( ... ) linker
694 // directive. If one is found, the first file name inside the
695 // parentheses is treated as the name of a dynamic library and the
696 // code attempts to dlopen that file. If this is also unsuccessful,
697 // an error message is returned.
698
699 // see if the error message is due to an invalid ELF header
700 IF_DEBUG(linker, debugBelch("errmsg = '%s'\n", errmsg));
701 result = regexec(&re_invalid, errmsg, (size_t) NMATCH, match, 0);
702 IF_DEBUG(linker, debugBelch("result = %i\n", result));
703 if (result == 0) {
704 // success -- try to read the named file as a linker script
705 match_length = (size_t) stg_min((match[1].rm_eo - match[1].rm_so),
706 MAXLINE-1);
707 strncpy(line, (errmsg+(match[1].rm_so)),match_length);
708 line[match_length] = '\0'; // make sure string is null-terminated
709 IF_DEBUG(linker, debugBelch ("file name = '%s'\n", line));
710 if ((fp = fopen(line, "r")) == NULL) {
711 return errmsg; // return original error if open fails
712 }
713 // try to find a GROUP or INPUT ( ... ) command
714 while (fgets(line, MAXLINE, fp) != NULL) {
715 IF_DEBUG(linker, debugBelch("input line = %s", line));
716 if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) {
717 // success -- try to dlopen the first named file
718 IF_DEBUG(linker, debugBelch("match%s\n",""));
719 line[match[2].rm_eo] = '\0';
720 stgFree((void*)errmsg); // Free old message before creating new one
721 errmsg = internal_dlopen(line+match[2].rm_so);
722 break;
723 }
724 // if control reaches here, no GROUP or INPUT ( ... ) directive
725 // was found and the original error message is returned to the
726 // caller
727 }
728 fclose(fp);
729 }
730 return errmsg;
731
732 # elif defined(OBJFORMAT_PEi386)
733 return addDLL_PEi386(dll_name);
734
735 # else
736 barf("addDLL: not implemented on this platform");
737 # endif
738 }
739
740 /* -----------------------------------------------------------------------------
741 * Searches the system directories to determine if there is a system DLL that
742 * satisfies the given name. This prevent GHCi from linking against a static
743 * library if a DLL is available.
744 *
745 * Returns: NULL on failure or no DLL found, else the full path to the DLL
746 * that can be loaded.
747 */
748 pathchar* findSystemLibrary(pathchar* dll_name)
749 {
750 IF_DEBUG(linker, debugBelch("\nfindSystemLibrary: dll_name = `%" PATH_FMT "'\n", dll_name));
751
752 #if defined(OBJFORMAT_PEi386)
753 return findSystemLibrary_PEi386(dll_name);
754 #else
755 (void)(dll_name); // Function not implemented for other platforms.
756 return NULL;
757 #endif
758 }
759
760 /* -----------------------------------------------------------------------------
761 * Emits a warning determining that the system is missing a required security
762 * update that we need to get access to the proper APIs
763 */
764 void warnMissingKBLibraryPaths( void )
765 {
766 static HsBool missing_update_warn = HS_BOOL_FALSE;
767 if (!missing_update_warn) {
768 debugBelch("Warning: If linking fails, consider installing KB2533623.\n");
769 missing_update_warn = HS_BOOL_TRUE;
770 }
771 }
772
773 /* -----------------------------------------------------------------------------
774 * appends a directory to the process DLL Load path so LoadLibrary can find it
775 *
776 * Returns: NULL on failure, or pointer to be passed to removeLibrarySearchPath to
777 * restore the search path to what it was before this call.
778 */
779 HsPtr addLibrarySearchPath(pathchar* dll_path)
780 {
781 IF_DEBUG(linker, debugBelch("\naddLibrarySearchPath: dll_path = `%" PATH_FMT "'\n", dll_path));
782
783 #if defined(OBJFORMAT_PEi386)
784 return addLibrarySearchPath_PEi386(dll_path);
785 #else
786 (void)(dll_path); // Function not implemented for other platforms.
787 return NULL;
788 #endif
789 }
790
791 /* -----------------------------------------------------------------------------
792 * removes a directory from the process DLL Load path
793 *
794 * Returns: HS_BOOL_TRUE on success, otherwise HS_BOOL_FALSE
795 */
796 HsBool removeLibrarySearchPath(HsPtr dll_path_index)
797 {
798 IF_DEBUG(linker, debugBelch("\nremoveLibrarySearchPath: ptr = `%p'\n", dll_path_index));
799
800 #if defined(OBJFORMAT_PEi386)
801 return removeLibrarySearchPath_PEi386(dll_path_index);
802 #else
803 (void)(dll_path_index); // Function not implemented for other platforms.
804 return HS_BOOL_FALSE;
805 #endif
806 }
807
808 /* -----------------------------------------------------------------------------
809 * insert a symbol in the hash table
810 *
811 * Returns: 0 on failure, nozero on success
812 */
813 HsInt insertSymbol(pathchar* obj_name, SymbolName* key, SymbolAddr* data)
814 {
815 return ghciInsertSymbolTable(obj_name, symhash, key, data, HS_BOOL_FALSE, NULL);
816 }
817
818 /* -----------------------------------------------------------------------------
819 * lookup a symbol in the hash table
820 */
821 #if defined(OBJFORMAT_PEi386)
822 SymbolAddr* lookupSymbol_ (SymbolName* lbl)
823 {
824 return lookupSymbol_PEi386(lbl);
825 }
826
827 #else
828
829 SymbolAddr* lookupSymbol_ (SymbolName* lbl)
830 {
831 IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s\n", lbl));
832
833 ASSERT(symhash != NULL);
834 RtsSymbolInfo *pinfo;
835
836 if (!ghciLookupSymbolInfo(symhash, lbl, &pinfo)) {
837 IF_DEBUG(linker, debugBelch("lookupSymbol: symbol not found\n"));
838
839 # if defined(OBJFORMAT_ELF)
840 return internal_dlsym(lbl);
841 # elif defined(OBJFORMAT_MACHO)
842
843 /* HACK: On OS X, all symbols are prefixed with an underscore.
844 However, dlsym wants us to omit the leading underscore from the
845 symbol name -- the dlsym routine puts it back on before searching
846 for the symbol. For now, we simply strip it off here (and ONLY
847 here).
848 */
849 IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s with dlsym\n", lbl));
850 ASSERT(lbl[0] == '_');
851 return internal_dlsym(lbl + 1);
852
853 # else
854 ASSERT(2+2 == 5);
855 return NULL;
856 # endif
857 } else {
858 return loadSymbol(lbl, pinfo);
859 }
860 }
861 #endif /* OBJFORMAT_PEi386 */
862
863 /*
864 * Load and relocate the object code for a symbol as necessary.
865 * Symbol name only used for diagnostics output.
866 */
867 SymbolAddr* loadSymbol(SymbolName *lbl, RtsSymbolInfo *pinfo) {
868 IF_DEBUG(linker, debugBelch("lookupSymbol: value of %s is %p\n", lbl, pinfo->value));
869 ObjectCode* oc = pinfo->owner;
870
871 /* Symbol can be found during linking, but hasn't been relocated. Do so now.
872 See Note [runtime-linker-phases] */
873 if (oc && oc->status == OBJECT_LOADED) {
874 oc->status = OBJECT_NEEDED;
875 IF_DEBUG(linker, debugBelch("lookupSymbol: on-demand loading symbol '%s'\n", lbl));
876 int r = ocTryLoad(oc);
877 if (!r) {
878 errorBelch("Could not on-demand load symbol '%s'\n", lbl);
879 return NULL;
880 }
881
882 #ifdef PROFILING
883 // collect any new cost centres & CCSs
884 // that were defined during runInit
885 initProfiling2();
886 #endif
887 }
888
889 return pinfo->value;
890 }
891
892 SymbolAddr* lookupSymbol( SymbolName* lbl )
893 {
894 ACQUIRE_LOCK(&linker_mutex);
895 SymbolAddr* r = lookupSymbol_(lbl);
896 RELEASE_LOCK(&linker_mutex);
897 return r;
898 }
899
900 /* -----------------------------------------------------------------------------
901 Create a StablePtr for a foreign export. This is normally called by
902 a C function with __attribute__((constructor)), which is generated
903 by GHC and linked into the module.
904
905 If the object code is being loaded dynamically, then we remember
906 which StablePtrs were allocated by the constructors and free them
907 again in unloadObj().
908 -------------------------------------------------------------------------- */
909
910 static ObjectCode *loading_obj = NULL;
911
912 StgStablePtr foreignExportStablePtr (StgPtr p)
913 {
914 ForeignExportStablePtr *fe_sptr;
915 StgStablePtr *sptr;
916
917 sptr = getStablePtr(p);
918
919 if (loading_obj != NULL) {
920 fe_sptr = stgMallocBytes(sizeof(ForeignExportStablePtr),
921 "foreignExportStablePtr");
922 fe_sptr->stable_ptr = sptr;
923 fe_sptr->next = loading_obj->stable_ptrs;
924 loading_obj->stable_ptrs = fe_sptr;
925 }
926
927 return sptr;
928 }
929
930
931 /* -----------------------------------------------------------------------------
932 * Debugging aid: look in GHCi's object symbol tables for symbols
933 * within DELTA bytes of the specified address, and show their names.
934 */
935 #ifdef DEBUG
936 void ghci_enquire ( SymbolAddr* addr );
937
938 void ghci_enquire(SymbolAddr* addr)
939 {
940 int i;
941 SymbolName* sym;
942 RtsSymbolInfo* a;
943 const int DELTA = 64;
944 ObjectCode* oc;
945
946 for (oc = objects; oc; oc = oc->next) {
947 for (i = 0; i < oc->n_symbols; i++) {
948 sym = oc->symbols[i];
949 if (sym == NULL) continue;
950 a = NULL;
951 if (a == NULL) {
952 ghciLookupSymbolInfo(symhash, sym, &a);
953 }
954 if (a == NULL) {
955 // debugBelch("ghci_enquire: can't find %s\n", sym);
956 }
957 else if ( a->value
958 && (char*)addr-DELTA <= (char*)a->value
959 && (char*)a->value <= (char*)addr+DELTA) {
960 debugBelch("%p + %3d == `%s'\n", addr, (int)((char*)a->value - (char*)addr), sym);
961 }
962 }
963 }
964 }
965 #endif
966
967 #if RTS_LINKER_USE_MMAP
968 //
969 // Returns NULL on failure.
970 //
971 void *
972 mmapForLinker (size_t bytes, uint32_t flags, int fd, int offset)
973 {
974 void *map_addr = NULL;
975 void *result;
976 size_t size;
977 static uint32_t fixed = 0;
978
979 IF_DEBUG(linker, debugBelch("mmapForLinker: start\n"));
980 size = roundUpToPage(bytes);
981
982 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
983 mmap_again:
984
985 if (mmap_32bit_base != 0) {
986 map_addr = mmap_32bit_base;
987 }
988 #endif
989
990 IF_DEBUG(linker,
991 debugBelch("mmapForLinker: \tprotection %#0x\n",
992 PROT_EXEC | PROT_READ | PROT_WRITE));
993 IF_DEBUG(linker,
994 debugBelch("mmapForLinker: \tflags %#0x\n",
995 MAP_PRIVATE | TRY_MAP_32BIT | fixed | flags));
996
997 result = mmap(map_addr, size,
998 PROT_EXEC|PROT_READ|PROT_WRITE,
999 MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, offset);
1000
1001 if (result == MAP_FAILED) {
1002 sysErrorBelch("mmap %" FMT_Word " bytes at %p",(W_)size,map_addr);
1003 errorBelch("Try specifying an address with +RTS -xm<addr> -RTS");
1004 return NULL;
1005 }
1006
1007 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1008 if (mmap_32bit_base != 0) {
1009 if (result == map_addr) {
1010 mmap_32bit_base = (StgWord8*)map_addr + size;
1011 } else {
1012 if ((W_)result > 0x80000000) {
1013 // oops, we were given memory over 2Gb
1014 munmap(result,size);
1015 #if defined(freebsd_HOST_OS) || \
1016 defined(kfreebsdgnu_HOST_OS) || \
1017 defined(dragonfly_HOST_OS)
1018 // Some platforms require MAP_FIXED. This is normally
1019 // a bad idea, because MAP_FIXED will overwrite
1020 // existing mappings.
1021 fixed = MAP_FIXED;
1022 goto mmap_again;
1023 #else
1024 errorBelch("loadObj: failed to mmap() memory below 2Gb; "
1025 "asked for %lu bytes at %p. "
1026 "Try specifying an address with +RTS -xm<addr> -RTS",
1027 size, map_addr);
1028 return NULL;
1029 #endif
1030 } else {
1031 // hmm, we were given memory somewhere else, but it's
1032 // still under 2Gb so we can use it. Next time, ask
1033 // for memory right after the place we just got some
1034 mmap_32bit_base = (StgWord8*)result + size;
1035 }
1036 }
1037 } else {
1038 if ((W_)result > 0x80000000) {
1039 // oops, we were given memory over 2Gb
1040 // ... try allocating memory somewhere else?;
1041 debugTrace(DEBUG_linker,
1042 "MAP_32BIT didn't work; gave us %lu bytes at 0x%p",
1043 bytes, result);
1044 munmap(result, size);
1045
1046 // Set a base address and try again... (guess: 1Gb)
1047 mmap_32bit_base = (void*)0x40000000;
1048 goto mmap_again;
1049 }
1050 }
1051 #endif
1052
1053 IF_DEBUG(linker,
1054 debugBelch("mmapForLinker: mapped %" FMT_Word
1055 " bytes starting at %p\n", (W_)size, result));
1056 IF_DEBUG(linker,
1057 debugBelch("mmapForLinker: done\n"));
1058
1059 return result;
1060 }
1061 #endif
1062
1063 /*
1064 * Remove symbols from the symbol table, and free oc->symbols.
1065 * This operation is idempotent.
1066 */
1067 static void removeOcSymbols (ObjectCode *oc)
1068 {
1069 if (oc->symbols == NULL) return;
1070
1071 // Remove all the mappings for the symbols within this object..
1072 int i;
1073 for (i = 0; i < oc->n_symbols; i++) {
1074 if (oc->symbols[i] != NULL) {
1075 ghciRemoveSymbolTable(symhash, oc->symbols[i], oc);
1076 }
1077 }
1078
1079 stgFree(oc->symbols);
1080 oc->symbols = NULL;
1081 }
1082
1083 /*
1084 * Release StablePtrs and free oc->stable_ptrs.
1085 * This operation is idempotent.
1086 */
1087 static void freeOcStablePtrs (ObjectCode *oc)
1088 {
1089 // Release any StablePtrs that were created when this
1090 // object module was initialized.
1091 ForeignExportStablePtr *fe_ptr, *next;
1092
1093 for (fe_ptr = oc->stable_ptrs; fe_ptr != NULL; fe_ptr = next) {
1094 next = fe_ptr->next;
1095 freeStablePtr(fe_ptr->stable_ptr);
1096 stgFree(fe_ptr);
1097 }
1098 oc->stable_ptrs = NULL;
1099 }
1100
1101 static void
1102 freePreloadObjectFile (ObjectCode *oc)
1103 {
1104 #if defined(mingw32_HOST_OS)
1105 freePreloadObjectFile_PEi386(oc);
1106 #else
1107
1108 if (RTS_LINKER_USE_MMAP && oc->imageMapped) {
1109 munmap(oc->image, oc->fileSize);
1110 }
1111 else {
1112 stgFree(oc->image);
1113 }
1114
1115 #endif
1116
1117 oc->image = NULL;
1118 oc->fileSize = 0;
1119 }
1120
1121 /*
1122 * freeObjectCode() releases all the pieces of an ObjectCode. It is called by
1123 * the GC when a previously unloaded ObjectCode has been determined to be
1124 * unused, and when an error occurs during loadObj().
1125 */
1126 void freeObjectCode (ObjectCode *oc)
1127 {
1128 freePreloadObjectFile(oc);
1129
1130 if (oc->symbols != NULL) {
1131 stgFree(oc->symbols);
1132 oc->symbols = NULL;
1133 }
1134
1135 if (oc->extraInfos != NULL) {
1136 freeHashTable(oc->extraInfos, NULL);
1137 oc->extraInfos = NULL;
1138 }
1139
1140 if (oc->sections != NULL) {
1141 int i;
1142 for (i=0; i < oc->n_sections; i++) {
1143 if (oc->sections[i].start != NULL) {
1144 switch(oc->sections[i].alloc){
1145 #if RTS_LINKER_USE_MMAP
1146 case SECTION_MMAP:
1147 munmap(oc->sections[i].mapped_start,
1148 oc->sections[i].mapped_size);
1149 break;
1150 case SECTION_M32:
1151 m32_free(oc->sections[i].start,
1152 oc->sections[i].size);
1153 break;
1154 #endif
1155 case SECTION_MALLOC:
1156 stgFree(oc->sections[i].start);
1157 break;
1158 default:
1159 break;
1160 }
1161 }
1162 }
1163 stgFree(oc->sections);
1164 }
1165
1166 freeProddableBlocks(oc);
1167
1168 /* Free symbol_extras. On x86_64 Windows, symbol_extras are allocated
1169 * alongside the image, so we don't need to free. */
1170 #if NEED_SYMBOL_EXTRAS && (!defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS))
1171 if (RTS_LINKER_USE_MMAP) {
1172 if (!USE_CONTIGUOUS_MMAP && oc->symbol_extras != NULL) {
1173 m32_free(oc->symbol_extras,
1174 sizeof(SymbolExtra) * oc->n_symbol_extras);
1175 }
1176 }
1177 else {
1178 stgFree(oc->symbol_extras);
1179 }
1180 #endif
1181
1182 stgFree(oc->fileName);
1183 stgFree(oc->archiveMemberName);
1184
1185 stgFree(oc);
1186 }
1187
1188 /* -----------------------------------------------------------------------------
1189 * Sets the initial status of a fresh ObjectCode
1190 */
1191 static void setOcInitialStatus(ObjectCode* oc) {
1192 if (oc->archiveMemberName == NULL) {
1193 oc->status = OBJECT_NEEDED;
1194 } else {
1195 oc->status = OBJECT_LOADED;
1196 }
1197 }
1198
1199 ObjectCode*
1200 mkOc( pathchar *path, char *image, int imageSize,
1201 bool mapped, char *archiveMemberName, int misalignment ) {
1202 ObjectCode* oc;
1203
1204 IF_DEBUG(linker, debugBelch("mkOc: start\n"));
1205 oc = stgMallocBytes(sizeof(ObjectCode), "mkOc(oc)");
1206
1207 # if defined(OBJFORMAT_ELF)
1208 oc->formatName = "ELF";
1209 # elif defined(OBJFORMAT_PEi386)
1210 oc->formatName = "PEi386";
1211 # elif defined(OBJFORMAT_MACHO)
1212 oc->formatName = "Mach-O";
1213 # else
1214 stgFree(oc);
1215 barf("loadObj: not implemented on this platform");
1216 # endif
1217
1218 oc->image = image;
1219 oc->fileName = pathdup(path);
1220
1221 if (archiveMemberName) {
1222 oc->archiveMemberName = stgMallocBytes( strlen(archiveMemberName)+1, "loadObj" );
1223 strcpy(oc->archiveMemberName, archiveMemberName);
1224 } else {
1225 oc->archiveMemberName = NULL;
1226 }
1227
1228 setOcInitialStatus( oc );
1229
1230 oc->fileSize = imageSize;
1231 oc->symbols = NULL;
1232 oc->n_sections = 0;
1233 oc->sections = NULL;
1234 oc->proddables = NULL;
1235 oc->stable_ptrs = NULL;
1236 #if NEED_SYMBOL_EXTRAS
1237 oc->symbol_extras = NULL;
1238 #endif
1239 oc->imageMapped = mapped;
1240
1241 oc->misalignment = misalignment;
1242 oc->extraInfos = NULL;
1243
1244 /* chain it onto the list of objects */
1245 oc->next = NULL;
1246
1247 IF_DEBUG(linker, debugBelch("mkOc: done\n"));
1248 return oc;
1249 }
1250
1251 /* -----------------------------------------------------------------------------
1252 * Check if an object or archive is already loaded.
1253 *
1254 * Returns: 1 if the path is already loaded, 0 otherwise.
1255 */
1256 HsInt
1257 isAlreadyLoaded( pathchar *path )
1258 {
1259 ObjectCode *o;
1260 for (o = objects; o; o = o->next) {
1261 if (0 == pathcmp(o->fileName, path)) {
1262 return 1; /* already loaded */
1263 }
1264 }
1265 return 0; /* not loaded yet */
1266 }
1267
1268 //
1269 // Load the object file into memory. This will not be its final resting place,
1270 // as on 64-bit platforms we need to map its segments into the low 2Gb of the
1271 // address space, properly aligned.
1272 //
1273 static ObjectCode *
1274 preloadObjectFile (pathchar *path)
1275 {
1276 int fileSize;
1277 struct_stat st;
1278 int r;
1279 void *image;
1280 ObjectCode *oc;
1281 int misalignment = 0;
1282
1283 r = pathstat(path, &st);
1284 if (r == -1) {
1285 errorBelch("loadObj: %" PATH_FMT ": file doesn't exist", path);
1286 return NULL;
1287 }
1288
1289 fileSize = st.st_size;
1290
1291 #if RTS_LINKER_USE_MMAP
1292 int fd;
1293
1294 /* On many architectures malloc'd memory isn't executable, so we need to use
1295 * mmap. */
1296
1297 #if defined(openbsd_HOST_OS)
1298 fd = open(path, O_RDONLY, S_IRUSR);
1299 #else
1300 fd = open(path, O_RDONLY);
1301 #endif
1302 if (fd == -1) {
1303 errorBelch("loadObj: can't open %s", path);
1304 return NULL;
1305 }
1306
1307 image = mmap(NULL, fileSize, PROT_READ|PROT_WRITE|PROT_EXEC,
1308 MAP_PRIVATE, fd, 0);
1309 // not 32-bit yet, we'll remap later
1310 close(fd);
1311
1312 #else /* !RTS_LINKER_USE_MMAP */
1313 FILE *f;
1314
1315 /* load the image into memory */
1316 /* coverity[toctou] */
1317 f = pathopen(path, WSTR("rb"));
1318 if (!f) {
1319 errorBelch("loadObj: can't preload `%" PATH_FMT "'", path);
1320 return NULL;
1321 }
1322
1323 # if defined(mingw32_HOST_OS)
1324
1325 // TODO: We would like to use allocateExec here, but allocateExec
1326 // cannot currently allocate blocks large enough.
1327 image = allocateImageAndTrampolines(path, "itself", f, fileSize,
1328 HS_BOOL_FALSE);
1329 if (image == NULL) {
1330 fclose(f);
1331 return NULL;
1332 }
1333
1334 # elif defined(darwin_HOST_OS)
1335
1336 // In a Mach-O .o file, all sections can and will be misaligned
1337 // if the total size of the headers is not a multiple of the
1338 // desired alignment. This is fine for .o files that only serve
1339 // as input for the static linker, but it's not fine for us,
1340 // as SSE (used by gcc for floating point) and Altivec require
1341 // 16-byte alignment.
1342 // We calculate the correct alignment from the header before
1343 // reading the file, and then we misalign image on purpose so
1344 // that the actual sections end up aligned again.
1345 misalignment = machoGetMisalignment(f);
1346 image = stgMallocBytes(fileSize + misalignment, "loadObj(image)");
1347 image += misalignment;
1348
1349 # else /* !defined(mingw32_HOST_OS) */
1350
1351 image = stgMallocBytes(fileSize, "loadObj(image)");
1352
1353 #endif
1354
1355 int n;
1356 n = fread ( image, 1, fileSize, f );
1357 fclose(f);
1358 if (n != fileSize) {
1359 errorBelch("loadObj: error whilst reading `%" PATH_FMT "'", path);
1360 stgFree(image);
1361 return NULL;
1362 }
1363
1364 #endif /* RTS_LINKER_USE_MMAP */
1365
1366 oc = mkOc(path, image, fileSize, true, NULL, misalignment);
1367
1368 return oc;
1369 }
1370
1371 /* -----------------------------------------------------------------------------
1372 * Load an obj (populate the global symbol table, but don't resolve yet)
1373 *
1374 * Returns: 1 if ok, 0 on error.
1375 */
1376 static HsInt loadObj_ (pathchar *path)
1377 {
1378 ObjectCode* oc;
1379 IF_DEBUG(linker, debugBelch("loadObj %" PATH_FMT "\n", path));
1380
1381 /* debugBelch("loadObj %s\n", path ); */
1382
1383 /* Check that we haven't already loaded this object.
1384 Ignore requests to load multiple times */
1385
1386 if (isAlreadyLoaded(path)) {
1387 IF_DEBUG(linker,
1388 debugBelch("ignoring repeated load of %" PATH_FMT "\n", path));
1389 return 1; /* success */
1390 }
1391
1392 oc = preloadObjectFile(path);
1393 if (oc == NULL) return 0;
1394
1395 if (! loadOc(oc)) {
1396 // failed; free everything we've allocated
1397 removeOcSymbols(oc);
1398 // no need to freeOcStablePtrs, they aren't created until resolveObjs()
1399 freeObjectCode(oc);
1400 return 0;
1401 }
1402
1403 oc->next = objects;
1404 objects = oc;
1405 return 1;
1406 }
1407
1408 HsInt loadObj (pathchar *path)
1409 {
1410 ACQUIRE_LOCK(&linker_mutex);
1411 HsInt r = loadObj_(path);
1412 RELEASE_LOCK(&linker_mutex);
1413 return r;
1414 }
1415
1416 HsInt loadOc (ObjectCode* oc)
1417 {
1418 int r;
1419
1420 IF_DEBUG(linker, debugBelch("loadOc: start\n"));
1421
1422 /* verify the in-memory image */
1423 # if defined(OBJFORMAT_ELF)
1424 r = ocVerifyImage_ELF ( oc );
1425 # elif defined(OBJFORMAT_PEi386)
1426 r = ocVerifyImage_PEi386 ( oc );
1427 # elif defined(OBJFORMAT_MACHO)
1428 r = ocVerifyImage_MachO ( oc );
1429 # else
1430 barf("loadObj: no verify method");
1431 # endif
1432 if (!r) {
1433 IF_DEBUG(linker, debugBelch("loadOc: ocVerifyImage_* failed\n"));
1434 return r;
1435 }
1436
1437 #if NEED_SYMBOL_EXTRAS
1438 # if defined(OBJFORMAT_MACHO)
1439 r = ocAllocateSymbolExtras_MachO ( oc );
1440 if (!r) {
1441 IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_MachO failed\n"));
1442 return r;
1443 }
1444 # elif defined(OBJFORMAT_ELF)
1445 r = ocAllocateSymbolExtras_ELF ( oc );
1446 if (!r) {
1447 IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_ELF failed\n"));
1448 return r;
1449 }
1450 # elif defined(OBJFORMAT_PEi386)
1451 ocAllocateSymbolExtras_PEi386 ( oc );
1452 # endif
1453 #endif
1454
1455 /* build the symbol list for this image */
1456 # if defined(OBJFORMAT_ELF)
1457 r = ocGetNames_ELF ( oc );
1458 # elif defined(OBJFORMAT_PEi386)
1459 r = ocGetNames_PEi386 ( oc );
1460 # elif defined(OBJFORMAT_MACHO)
1461 r = ocGetNames_MachO ( oc );
1462 # else
1463 barf("loadObj: no getNames method");
1464 # endif
1465 if (!r) {
1466 IF_DEBUG(linker, debugBelch("loadOc: ocGetNames_* failed\n"));
1467 return r;
1468 }
1469
1470 /* loaded, but not resolved yet, ensure the OC is in a consistent state */
1471 setOcInitialStatus( oc );
1472 IF_DEBUG(linker, debugBelch("loadOc: done.\n"));
1473
1474 return 1;
1475 }
1476
1477 /* -----------------------------------------------------------------------------
1478 * try to load and initialize an ObjectCode into memory
1479 *
1480 * Returns: 1 if ok, 0 on error.
1481 */
1482 int ocTryLoad (ObjectCode* oc) {
1483 int r;
1484
1485 if (oc->status != OBJECT_NEEDED) {
1486 return 1;
1487 }
1488
1489 /* Check for duplicate symbols by looking into `symhash`.
1490 Duplicate symbols are any symbols which exist
1491 in different ObjectCodes that have both been loaded, or
1492 are to be loaded by this call.
1493
1494 This call is intended to have no side-effects when a non-duplicate
1495 symbol is re-inserted.
1496
1497 We set the Address to NULL since that is not used to distinguish
1498 symbols. Duplicate symbols are distinguished by name and oc.
1499 */
1500 int x;
1501 SymbolName* symbol;
1502 for (x = 0; x < oc->n_symbols; x++) {
1503 symbol = oc->symbols[x];
1504 if ( symbol
1505 && !ghciInsertSymbolTable(oc->fileName, symhash, symbol, NULL, isSymbolWeak(oc, symbol), oc)) {
1506 return 0;
1507 }
1508 }
1509
1510 # if defined(OBJFORMAT_ELF)
1511 r = ocResolve_ELF ( oc );
1512 # elif defined(OBJFORMAT_PEi386)
1513 r = ocResolve_PEi386 ( oc );
1514 # elif defined(OBJFORMAT_MACHO)
1515 r = ocResolve_MachO ( oc );
1516 # else
1517 barf("ocTryLoad: not implemented on this platform");
1518 # endif
1519 if (!r) { return r; }
1520
1521 // run init/init_array/ctors/mod_init_func
1522
1523 loading_obj = oc; // tells foreignExportStablePtr what to do
1524 #if defined(OBJFORMAT_ELF)
1525 r = ocRunInit_ELF ( oc );
1526 #elif defined(OBJFORMAT_PEi386)
1527 r = ocRunInit_PEi386 ( oc );
1528 #elif defined(OBJFORMAT_MACHO)
1529 r = ocRunInit_MachO ( oc );
1530 #else
1531 barf("ocTryLoad: initializers not implemented on this platform");
1532 #endif
1533 loading_obj = NULL;
1534
1535 if (!r) { return r; }
1536
1537 oc->status = OBJECT_RESOLVED;
1538
1539 return 1;
1540 }
1541
1542 /* -----------------------------------------------------------------------------
1543 * resolve all the currently unlinked objects in memory
1544 *
1545 * Returns: 1 if ok, 0 on error.
1546 */
1547 static HsInt resolveObjs_ (void)
1548 {
1549 ObjectCode *oc;
1550 int r;
1551
1552 IF_DEBUG(linker, debugBelch("resolveObjs: start\n"));
1553
1554 for (oc = objects; oc; oc = oc->next) {
1555 r = ocTryLoad(oc);
1556 if (!r)
1557 {
1558 return r;
1559 }
1560 }
1561
1562 #ifdef PROFILING
1563 // collect any new cost centres & CCSs that were defined during runInit
1564 initProfiling2();
1565 #endif
1566
1567 IF_DEBUG(linker, debugBelch("resolveObjs: done\n"));
1568 return 1;
1569 }
1570
1571 HsInt resolveObjs (void)
1572 {
1573 ACQUIRE_LOCK(&linker_mutex);
1574 HsInt r = resolveObjs_();
1575 RELEASE_LOCK(&linker_mutex);
1576 return r;
1577 }
1578
1579 /* -----------------------------------------------------------------------------
1580 * delete an object from the pool
1581 */
1582 static HsInt unloadObj_ (pathchar *path, bool just_purge)
1583 {
1584 ObjectCode *oc, *prev, *next;
1585 HsBool unloadedAnyObj = HS_BOOL_FALSE;
1586
1587 ASSERT(symhash != NULL);
1588 ASSERT(objects != NULL);
1589
1590 IF_DEBUG(linker, debugBelch("unloadObj: %" PATH_FMT "\n", path));
1591
1592 prev = NULL;
1593 for (oc = objects; oc; oc = next) {
1594 next = oc->next; // oc might be freed
1595
1596 if (!pathcmp(oc->fileName,path)) {
1597
1598 // these are both idempotent, so in just_purge mode we can
1599 // later call unloadObj() to really unload the object.
1600 removeOcSymbols(oc);
1601 freeOcStablePtrs(oc);
1602
1603 if (!just_purge) {
1604 if (prev == NULL) {
1605 objects = oc->next;
1606 } else {
1607 prev->next = oc->next;
1608 }
1609 ACQUIRE_LOCK(&linker_unloaded_mutex);
1610 oc->next = unloaded_objects;
1611 unloaded_objects = oc;
1612 oc->status = OBJECT_UNLOADED;
1613 RELEASE_LOCK(&linker_unloaded_mutex);
1614 // We do not own oc any more; it can be released at any time by
1615 // the GC in checkUnload().
1616 } else {
1617 prev = oc;
1618 }
1619
1620 /* This could be a member of an archive so continue
1621 * unloading other members. */
1622 unloadedAnyObj = HS_BOOL_TRUE;
1623 } else {
1624 prev = oc;
1625 }
1626 }
1627
1628 if (unloadedAnyObj) {
1629 return 1;
1630 }
1631 else {
1632 errorBelch("unloadObj: can't find `%" PATH_FMT "' to unload", path);
1633 return 0;
1634 }
1635 }
1636
1637 HsInt unloadObj (pathchar *path)
1638 {
1639 ACQUIRE_LOCK(&linker_mutex);
1640 HsInt r = unloadObj_(path, false);
1641 RELEASE_LOCK(&linker_mutex);
1642 return r;
1643 }
1644
1645 HsInt purgeObj (pathchar *path)
1646 {
1647 ACQUIRE_LOCK(&linker_mutex);
1648 HsInt r = unloadObj_(path, true);
1649 RELEASE_LOCK(&linker_mutex);
1650 return r;
1651 }
1652
1653 /* -----------------------------------------------------------------------------
1654 * Sanity checking. For each ObjectCode, maintain a list of address ranges
1655 * which may be prodded during relocation, and abort if we try and write
1656 * outside any of these.
1657 */
1658 void
1659 addProddableBlock ( ObjectCode* oc, void* start, int size )
1660 {
1661 ProddableBlock* pb
1662 = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
1663
1664 IF_DEBUG(linker, debugBelch("addProddableBlock: %p %p %d\n", oc, start, size));
1665 ASSERT(size > 0);
1666 pb->start = start;
1667 pb->size = size;
1668 pb->next = oc->proddables;
1669 oc->proddables = pb;
1670 }
1671
1672 void
1673 checkProddableBlock (ObjectCode *oc, void *addr, size_t size )
1674 {
1675 ProddableBlock* pb;
1676
1677 for (pb = oc->proddables; pb != NULL; pb = pb->next) {
1678 char* s = (char*)(pb->start);
1679 char* e = s + pb->size;
1680 char* a = (char*)addr;
1681 if (a >= s && (a+size) <= e) return;
1682 }
1683 barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr);
1684 }
1685
1686 void freeProddableBlocks (ObjectCode *oc)
1687 {
1688 ProddableBlock *pb, *next;
1689
1690 for (pb = oc->proddables; pb != NULL; pb = next) {
1691 next = pb->next;
1692 stgFree(pb);
1693 }
1694 oc->proddables = NULL;
1695 }
1696
1697 /* -----------------------------------------------------------------------------
1698 * Section management.
1699 */
1700 void
1701 addSection (Section *s, SectionKind kind, SectionAlloc alloc,
1702 void* start, StgWord size, StgWord mapped_offset,
1703 void* mapped_start, StgWord mapped_size)
1704 {
1705 s->start = start; /* actual start of section in memory */
1706 s->size = size; /* actual size of section in memory */
1707 s->kind = kind;
1708 s->alloc = alloc;
1709 s->mapped_offset = mapped_offset; /* offset from the image of mapped_start */
1710
1711 s->mapped_start = mapped_start; /* start of mmap() block */
1712 s->mapped_size = mapped_size; /* size of mmap() block */
1713
1714 IF_DEBUG(linker,
1715 debugBelch("addSection: %p-%p (size %" FMT_Word "), kind %d\n",
1716 start, (void*)((StgWord)start + size),
1717 size, kind ));
1718 }
1719