CmmLayoutStack: Add unwind information on stack fixups
[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 && lbl && 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 return NULL;
879 }
880
881 #ifdef PROFILING
882 // collect any new cost centres & CCSs
883 // that were defined during runInit
884 initProfiling2();
885 #endif
886 }
887
888 return pinfo->value;
889 }
890
891 SymbolAddr* lookupSymbol( SymbolName* lbl )
892 {
893 ACQUIRE_LOCK(&linker_mutex);
894 SymbolAddr* r = lookupSymbol_(lbl);
895 if (!r) {
896 errorBelch("^^ Could not load '%s', dependency unresolved. See top entry above.\n", lbl);
897 fflush(stderr);
898 }
899 RELEASE_LOCK(&linker_mutex);
900 return r;
901 }
902
903 /* -----------------------------------------------------------------------------
904 Create a StablePtr for a foreign export. This is normally called by
905 a C function with __attribute__((constructor)), which is generated
906 by GHC and linked into the module.
907
908 If the object code is being loaded dynamically, then we remember
909 which StablePtrs were allocated by the constructors and free them
910 again in unloadObj().
911 -------------------------------------------------------------------------- */
912
913 static ObjectCode *loading_obj = NULL;
914
915 StgStablePtr foreignExportStablePtr (StgPtr p)
916 {
917 ForeignExportStablePtr *fe_sptr;
918 StgStablePtr *sptr;
919
920 sptr = getStablePtr(p);
921
922 if (loading_obj != NULL) {
923 fe_sptr = stgMallocBytes(sizeof(ForeignExportStablePtr),
924 "foreignExportStablePtr");
925 fe_sptr->stable_ptr = sptr;
926 fe_sptr->next = loading_obj->stable_ptrs;
927 loading_obj->stable_ptrs = fe_sptr;
928 }
929
930 return sptr;
931 }
932
933
934 /* -----------------------------------------------------------------------------
935 * Debugging aid: look in GHCi's object symbol tables for symbols
936 * within DELTA bytes of the specified address, and show their names.
937 */
938 #ifdef DEBUG
939 void ghci_enquire ( SymbolAddr* addr );
940
941 void ghci_enquire(SymbolAddr* addr)
942 {
943 int i;
944 SymbolName* sym;
945 RtsSymbolInfo* a;
946 const int DELTA = 64;
947 ObjectCode* oc;
948
949 for (oc = objects; oc; oc = oc->next) {
950 for (i = 0; i < oc->n_symbols; i++) {
951 sym = oc->symbols[i];
952 if (sym == NULL) continue;
953 a = NULL;
954 if (a == NULL) {
955 ghciLookupSymbolInfo(symhash, sym, &a);
956 }
957 if (a == NULL) {
958 // debugBelch("ghci_enquire: can't find %s\n", sym);
959 }
960 else if ( a->value
961 && (char*)addr-DELTA <= (char*)a->value
962 && (char*)a->value <= (char*)addr+DELTA) {
963 debugBelch("%p + %3d == `%s'\n", addr, (int)((char*)a->value - (char*)addr), sym);
964 }
965 }
966 }
967 }
968 #endif
969
970 #if RTS_LINKER_USE_MMAP
971 //
972 // Returns NULL on failure.
973 //
974 void *
975 mmapForLinker (size_t bytes, uint32_t flags, int fd, int offset)
976 {
977 void *map_addr = NULL;
978 void *result;
979 size_t size;
980 static uint32_t fixed = 0;
981
982 IF_DEBUG(linker, debugBelch("mmapForLinker: start\n"));
983 size = roundUpToPage(bytes);
984
985 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
986 mmap_again:
987
988 if (mmap_32bit_base != 0) {
989 map_addr = mmap_32bit_base;
990 }
991 #endif
992
993 IF_DEBUG(linker,
994 debugBelch("mmapForLinker: \tprotection %#0x\n",
995 PROT_EXEC | PROT_READ | PROT_WRITE));
996 IF_DEBUG(linker,
997 debugBelch("mmapForLinker: \tflags %#0x\n",
998 MAP_PRIVATE | TRY_MAP_32BIT | fixed | flags));
999
1000 result = mmap(map_addr, size,
1001 PROT_EXEC|PROT_READ|PROT_WRITE,
1002 MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, offset);
1003
1004 if (result == MAP_FAILED) {
1005 sysErrorBelch("mmap %" FMT_Word " bytes at %p",(W_)size,map_addr);
1006 errorBelch("Try specifying an address with +RTS -xm<addr> -RTS");
1007 return NULL;
1008 }
1009
1010 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1011 if (mmap_32bit_base != 0) {
1012 if (result == map_addr) {
1013 mmap_32bit_base = (StgWord8*)map_addr + size;
1014 } else {
1015 if ((W_)result > 0x80000000) {
1016 // oops, we were given memory over 2Gb
1017 munmap(result,size);
1018 #if defined(freebsd_HOST_OS) || \
1019 defined(kfreebsdgnu_HOST_OS) || \
1020 defined(dragonfly_HOST_OS)
1021 // Some platforms require MAP_FIXED. This is normally
1022 // a bad idea, because MAP_FIXED will overwrite
1023 // existing mappings.
1024 fixed = MAP_FIXED;
1025 goto mmap_again;
1026 #else
1027 errorBelch("loadObj: failed to mmap() memory below 2Gb; "
1028 "asked for %lu bytes at %p. "
1029 "Try specifying an address with +RTS -xm<addr> -RTS",
1030 size, map_addr);
1031 return NULL;
1032 #endif
1033 } else {
1034 // hmm, we were given memory somewhere else, but it's
1035 // still under 2Gb so we can use it. Next time, ask
1036 // for memory right after the place we just got some
1037 mmap_32bit_base = (StgWord8*)result + size;
1038 }
1039 }
1040 } else {
1041 if ((W_)result > 0x80000000) {
1042 // oops, we were given memory over 2Gb
1043 // ... try allocating memory somewhere else?;
1044 debugTrace(DEBUG_linker,
1045 "MAP_32BIT didn't work; gave us %lu bytes at 0x%p",
1046 bytes, result);
1047 munmap(result, size);
1048
1049 // Set a base address and try again... (guess: 1Gb)
1050 mmap_32bit_base = (void*)0x40000000;
1051 goto mmap_again;
1052 }
1053 }
1054 #endif
1055
1056 IF_DEBUG(linker,
1057 debugBelch("mmapForLinker: mapped %" FMT_Word
1058 " bytes starting at %p\n", (W_)size, result));
1059 IF_DEBUG(linker,
1060 debugBelch("mmapForLinker: done\n"));
1061
1062 return result;
1063 }
1064 #endif
1065
1066 /*
1067 * Remove symbols from the symbol table, and free oc->symbols.
1068 * This operation is idempotent.
1069 */
1070 static void removeOcSymbols (ObjectCode *oc)
1071 {
1072 if (oc->symbols == NULL) return;
1073
1074 // Remove all the mappings for the symbols within this object..
1075 int i;
1076 for (i = 0; i < oc->n_symbols; i++) {
1077 if (oc->symbols[i] != NULL) {
1078 ghciRemoveSymbolTable(symhash, oc->symbols[i], oc);
1079 }
1080 }
1081
1082 stgFree(oc->symbols);
1083 oc->symbols = NULL;
1084 }
1085
1086 /*
1087 * Release StablePtrs and free oc->stable_ptrs.
1088 * This operation is idempotent.
1089 */
1090 static void freeOcStablePtrs (ObjectCode *oc)
1091 {
1092 // Release any StablePtrs that were created when this
1093 // object module was initialized.
1094 ForeignExportStablePtr *fe_ptr, *next;
1095
1096 for (fe_ptr = oc->stable_ptrs; fe_ptr != NULL; fe_ptr = next) {
1097 next = fe_ptr->next;
1098 freeStablePtr(fe_ptr->stable_ptr);
1099 stgFree(fe_ptr);
1100 }
1101 oc->stable_ptrs = NULL;
1102 }
1103
1104 static void
1105 freePreloadObjectFile (ObjectCode *oc)
1106 {
1107 #if defined(mingw32_HOST_OS)
1108 freePreloadObjectFile_PEi386(oc);
1109 #else
1110
1111 if (RTS_LINKER_USE_MMAP && oc->imageMapped) {
1112 munmap(oc->image, oc->fileSize);
1113 }
1114 else {
1115 stgFree(oc->image);
1116 }
1117
1118 #endif
1119
1120 oc->image = NULL;
1121 oc->fileSize = 0;
1122 }
1123
1124 /*
1125 * freeObjectCode() releases all the pieces of an ObjectCode. It is called by
1126 * the GC when a previously unloaded ObjectCode has been determined to be
1127 * unused, and when an error occurs during loadObj().
1128 */
1129 void freeObjectCode (ObjectCode *oc)
1130 {
1131 freePreloadObjectFile(oc);
1132
1133 if (oc->symbols != NULL) {
1134 stgFree(oc->symbols);
1135 oc->symbols = NULL;
1136 }
1137
1138 if (oc->extraInfos != NULL) {
1139 freeHashTable(oc->extraInfos, NULL);
1140 oc->extraInfos = NULL;
1141 }
1142
1143 if (oc->sections != NULL) {
1144 int i;
1145 for (i=0; i < oc->n_sections; i++) {
1146 if (oc->sections[i].start != NULL) {
1147 switch(oc->sections[i].alloc){
1148 #if RTS_LINKER_USE_MMAP
1149 case SECTION_MMAP:
1150 munmap(oc->sections[i].mapped_start,
1151 oc->sections[i].mapped_size);
1152 break;
1153 case SECTION_M32:
1154 m32_free(oc->sections[i].start,
1155 oc->sections[i].size);
1156 break;
1157 #endif
1158 case SECTION_MALLOC:
1159 stgFree(oc->sections[i].start);
1160 break;
1161 default:
1162 break;
1163 }
1164 }
1165 }
1166 stgFree(oc->sections);
1167 }
1168
1169 freeProddableBlocks(oc);
1170
1171 /* Free symbol_extras. On x86_64 Windows, symbol_extras are allocated
1172 * alongside the image, so we don't need to free. */
1173 #if NEED_SYMBOL_EXTRAS && (!defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS))
1174 if (RTS_LINKER_USE_MMAP) {
1175 if (!USE_CONTIGUOUS_MMAP && oc->symbol_extras != NULL) {
1176 m32_free(oc->symbol_extras,
1177 sizeof(SymbolExtra) * oc->n_symbol_extras);
1178 }
1179 }
1180 else {
1181 stgFree(oc->symbol_extras);
1182 }
1183 #endif
1184
1185 stgFree(oc->fileName);
1186 stgFree(oc->archiveMemberName);
1187
1188 stgFree(oc);
1189 }
1190
1191 /* -----------------------------------------------------------------------------
1192 * Sets the initial status of a fresh ObjectCode
1193 */
1194 static void setOcInitialStatus(ObjectCode* oc) {
1195 if (oc->archiveMemberName == NULL) {
1196 oc->status = OBJECT_NEEDED;
1197 } else {
1198 oc->status = OBJECT_LOADED;
1199 }
1200 }
1201
1202 ObjectCode*
1203 mkOc( pathchar *path, char *image, int imageSize,
1204 bool mapped, char *archiveMemberName, int misalignment ) {
1205 ObjectCode* oc;
1206
1207 IF_DEBUG(linker, debugBelch("mkOc: start\n"));
1208 oc = stgMallocBytes(sizeof(ObjectCode), "mkOc(oc)");
1209
1210 # if defined(OBJFORMAT_ELF)
1211 oc->formatName = "ELF";
1212 # elif defined(OBJFORMAT_PEi386)
1213 oc->formatName = "PEi386";
1214 # elif defined(OBJFORMAT_MACHO)
1215 oc->formatName = "Mach-O";
1216 # else
1217 stgFree(oc);
1218 barf("loadObj: not implemented on this platform");
1219 # endif
1220
1221 oc->image = image;
1222 oc->fileName = pathdup(path);
1223
1224 if (archiveMemberName) {
1225 oc->archiveMemberName = stgMallocBytes( strlen(archiveMemberName)+1, "loadObj" );
1226 strcpy(oc->archiveMemberName, archiveMemberName);
1227 } else {
1228 oc->archiveMemberName = NULL;
1229 }
1230
1231 setOcInitialStatus( oc );
1232
1233 oc->fileSize = imageSize;
1234 oc->symbols = NULL;
1235 oc->n_sections = 0;
1236 oc->sections = NULL;
1237 oc->proddables = NULL;
1238 oc->stable_ptrs = NULL;
1239 #if NEED_SYMBOL_EXTRAS
1240 oc->symbol_extras = NULL;
1241 #endif
1242 oc->imageMapped = mapped;
1243
1244 oc->misalignment = misalignment;
1245 oc->extraInfos = NULL;
1246
1247 /* chain it onto the list of objects */
1248 oc->next = NULL;
1249
1250 IF_DEBUG(linker, debugBelch("mkOc: done\n"));
1251 return oc;
1252 }
1253
1254 /* -----------------------------------------------------------------------------
1255 * Check if an object or archive is already loaded.
1256 *
1257 * Returns: 1 if the path is already loaded, 0 otherwise.
1258 */
1259 HsInt
1260 isAlreadyLoaded( pathchar *path )
1261 {
1262 ObjectCode *o;
1263 for (o = objects; o; o = o->next) {
1264 if (0 == pathcmp(o->fileName, path)) {
1265 return 1; /* already loaded */
1266 }
1267 }
1268 return 0; /* not loaded yet */
1269 }
1270
1271 //
1272 // Load the object file into memory. This will not be its final resting place,
1273 // as on 64-bit platforms we need to map its segments into the low 2Gb of the
1274 // address space, properly aligned.
1275 //
1276 static ObjectCode *
1277 preloadObjectFile (pathchar *path)
1278 {
1279 int fileSize;
1280 struct_stat st;
1281 int r;
1282 void *image;
1283 ObjectCode *oc;
1284 int misalignment = 0;
1285
1286 r = pathstat(path, &st);
1287 if (r == -1) {
1288 errorBelch("loadObj: %" PATH_FMT ": file doesn't exist", path);
1289 return NULL;
1290 }
1291
1292 fileSize = st.st_size;
1293
1294 #if RTS_LINKER_USE_MMAP
1295 int fd;
1296
1297 /* On many architectures malloc'd memory isn't executable, so we need to use
1298 * mmap. */
1299
1300 #if defined(openbsd_HOST_OS)
1301 fd = open(path, O_RDONLY, S_IRUSR);
1302 #else
1303 fd = open(path, O_RDONLY);
1304 #endif
1305 if (fd == -1) {
1306 errorBelch("loadObj: can't open %s", path);
1307 return NULL;
1308 }
1309
1310 image = mmap(NULL, fileSize, PROT_READ|PROT_WRITE|PROT_EXEC,
1311 MAP_PRIVATE, fd, 0);
1312 // not 32-bit yet, we'll remap later
1313 close(fd);
1314
1315 #else /* !RTS_LINKER_USE_MMAP */
1316 FILE *f;
1317
1318 /* load the image into memory */
1319 /* coverity[toctou] */
1320 f = pathopen(path, WSTR("rb"));
1321 if (!f) {
1322 errorBelch("loadObj: can't preload `%" PATH_FMT "'", path);
1323 return NULL;
1324 }
1325
1326 # if defined(mingw32_HOST_OS)
1327
1328 // TODO: We would like to use allocateExec here, but allocateExec
1329 // cannot currently allocate blocks large enough.
1330 image = allocateImageAndTrampolines(path, "itself", f, fileSize,
1331 HS_BOOL_FALSE);
1332 if (image == NULL) {
1333 fclose(f);
1334 return NULL;
1335 }
1336
1337 # elif defined(darwin_HOST_OS)
1338
1339 // In a Mach-O .o file, all sections can and will be misaligned
1340 // if the total size of the headers is not a multiple of the
1341 // desired alignment. This is fine for .o files that only serve
1342 // as input for the static linker, but it's not fine for us,
1343 // as SSE (used by gcc for floating point) and Altivec require
1344 // 16-byte alignment.
1345 // We calculate the correct alignment from the header before
1346 // reading the file, and then we misalign image on purpose so
1347 // that the actual sections end up aligned again.
1348 misalignment = machoGetMisalignment(f);
1349 image = stgMallocBytes(fileSize + misalignment, "loadObj(image)");
1350 image += misalignment;
1351
1352 # else /* !defined(mingw32_HOST_OS) */
1353
1354 image = stgMallocBytes(fileSize, "loadObj(image)");
1355
1356 #endif
1357
1358 int n;
1359 n = fread ( image, 1, fileSize, f );
1360 fclose(f);
1361 if (n != fileSize) {
1362 errorBelch("loadObj: error whilst reading `%" PATH_FMT "'", path);
1363 stgFree(image);
1364 return NULL;
1365 }
1366
1367 #endif /* RTS_LINKER_USE_MMAP */
1368
1369 oc = mkOc(path, image, fileSize, true, NULL, misalignment);
1370
1371 return oc;
1372 }
1373
1374 /* -----------------------------------------------------------------------------
1375 * Load an obj (populate the global symbol table, but don't resolve yet)
1376 *
1377 * Returns: 1 if ok, 0 on error.
1378 */
1379 static HsInt loadObj_ (pathchar *path)
1380 {
1381 ObjectCode* oc;
1382 IF_DEBUG(linker, debugBelch("loadObj %" PATH_FMT "\n", path));
1383
1384 /* debugBelch("loadObj %s\n", path ); */
1385
1386 /* Check that we haven't already loaded this object.
1387 Ignore requests to load multiple times */
1388
1389 if (isAlreadyLoaded(path)) {
1390 IF_DEBUG(linker,
1391 debugBelch("ignoring repeated load of %" PATH_FMT "\n", path));
1392 return 1; /* success */
1393 }
1394
1395 oc = preloadObjectFile(path);
1396 if (oc == NULL) return 0;
1397
1398 if (! loadOc(oc)) {
1399 // failed; free everything we've allocated
1400 removeOcSymbols(oc);
1401 // no need to freeOcStablePtrs, they aren't created until resolveObjs()
1402 freeObjectCode(oc);
1403 return 0;
1404 }
1405
1406 oc->next = objects;
1407 objects = oc;
1408 return 1;
1409 }
1410
1411 HsInt loadObj (pathchar *path)
1412 {
1413 ACQUIRE_LOCK(&linker_mutex);
1414 HsInt r = loadObj_(path);
1415 RELEASE_LOCK(&linker_mutex);
1416 return r;
1417 }
1418
1419 HsInt loadOc (ObjectCode* oc)
1420 {
1421 int r;
1422
1423 IF_DEBUG(linker, debugBelch("loadOc: start\n"));
1424
1425 /* verify the in-memory image */
1426 # if defined(OBJFORMAT_ELF)
1427 r = ocVerifyImage_ELF ( oc );
1428 # elif defined(OBJFORMAT_PEi386)
1429 r = ocVerifyImage_PEi386 ( oc );
1430 # elif defined(OBJFORMAT_MACHO)
1431 r = ocVerifyImage_MachO ( oc );
1432 # else
1433 barf("loadObj: no verify method");
1434 # endif
1435 if (!r) {
1436 IF_DEBUG(linker, debugBelch("loadOc: ocVerifyImage_* failed\n"));
1437 return r;
1438 }
1439
1440 #if NEED_SYMBOL_EXTRAS
1441 # if defined(OBJFORMAT_MACHO)
1442 r = ocAllocateSymbolExtras_MachO ( oc );
1443 if (!r) {
1444 IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_MachO failed\n"));
1445 return r;
1446 }
1447 # elif defined(OBJFORMAT_ELF)
1448 r = ocAllocateSymbolExtras_ELF ( oc );
1449 if (!r) {
1450 IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_ELF failed\n"));
1451 return r;
1452 }
1453 # elif defined(OBJFORMAT_PEi386)
1454 ocAllocateSymbolExtras_PEi386 ( oc );
1455 # endif
1456 #endif
1457
1458 /* build the symbol list for this image */
1459 # if defined(OBJFORMAT_ELF)
1460 r = ocGetNames_ELF ( oc );
1461 # elif defined(OBJFORMAT_PEi386)
1462 r = ocGetNames_PEi386 ( oc );
1463 # elif defined(OBJFORMAT_MACHO)
1464 r = ocGetNames_MachO ( oc );
1465 # else
1466 barf("loadObj: no getNames method");
1467 # endif
1468 if (!r) {
1469 IF_DEBUG(linker, debugBelch("loadOc: ocGetNames_* failed\n"));
1470 return r;
1471 }
1472
1473 /* loaded, but not resolved yet, ensure the OC is in a consistent state */
1474 setOcInitialStatus( oc );
1475 IF_DEBUG(linker, debugBelch("loadOc: done.\n"));
1476
1477 return 1;
1478 }
1479
1480 /* -----------------------------------------------------------------------------
1481 * try to load and initialize an ObjectCode into memory
1482 *
1483 * Returns: 1 if ok, 0 on error.
1484 */
1485 int ocTryLoad (ObjectCode* oc) {
1486 int r;
1487
1488 if (oc->status != OBJECT_NEEDED) {
1489 return 1;
1490 }
1491
1492 /* Check for duplicate symbols by looking into `symhash`.
1493 Duplicate symbols are any symbols which exist
1494 in different ObjectCodes that have both been loaded, or
1495 are to be loaded by this call.
1496
1497 This call is intended to have no side-effects when a non-duplicate
1498 symbol is re-inserted.
1499
1500 We set the Address to NULL since that is not used to distinguish
1501 symbols. Duplicate symbols are distinguished by name and oc.
1502 */
1503 int x;
1504 SymbolName* symbol;
1505 for (x = 0; x < oc->n_symbols; x++) {
1506 symbol = oc->symbols[x];
1507 if ( symbol
1508 && !ghciInsertSymbolTable(oc->fileName, symhash, symbol, NULL, isSymbolWeak(oc, symbol), oc)) {
1509 return 0;
1510 }
1511 }
1512
1513 # if defined(OBJFORMAT_ELF)
1514 r = ocResolve_ELF ( oc );
1515 # elif defined(OBJFORMAT_PEi386)
1516 r = ocResolve_PEi386 ( oc );
1517 # elif defined(OBJFORMAT_MACHO)
1518 r = ocResolve_MachO ( oc );
1519 # else
1520 barf("ocTryLoad: not implemented on this platform");
1521 # endif
1522 if (!r) { return r; }
1523
1524 // run init/init_array/ctors/mod_init_func
1525
1526 loading_obj = oc; // tells foreignExportStablePtr what to do
1527 #if defined(OBJFORMAT_ELF)
1528 r = ocRunInit_ELF ( oc );
1529 #elif defined(OBJFORMAT_PEi386)
1530 r = ocRunInit_PEi386 ( oc );
1531 #elif defined(OBJFORMAT_MACHO)
1532 r = ocRunInit_MachO ( oc );
1533 #else
1534 barf("ocTryLoad: initializers not implemented on this platform");
1535 #endif
1536 loading_obj = NULL;
1537
1538 if (!r) { return r; }
1539
1540 oc->status = OBJECT_RESOLVED;
1541
1542 return 1;
1543 }
1544
1545 /* -----------------------------------------------------------------------------
1546 * resolve all the currently unlinked objects in memory
1547 *
1548 * Returns: 1 if ok, 0 on error.
1549 */
1550 static HsInt resolveObjs_ (void)
1551 {
1552 ObjectCode *oc;
1553 int r;
1554
1555 IF_DEBUG(linker, debugBelch("resolveObjs: start\n"));
1556
1557 for (oc = objects; oc; oc = oc->next) {
1558 r = ocTryLoad(oc);
1559 if (!r)
1560 {
1561 return r;
1562 }
1563 }
1564
1565 #ifdef PROFILING
1566 // collect any new cost centres & CCSs that were defined during runInit
1567 initProfiling2();
1568 #endif
1569
1570 IF_DEBUG(linker, debugBelch("resolveObjs: done\n"));
1571 return 1;
1572 }
1573
1574 HsInt resolveObjs (void)
1575 {
1576 ACQUIRE_LOCK(&linker_mutex);
1577 HsInt r = resolveObjs_();
1578 RELEASE_LOCK(&linker_mutex);
1579 return r;
1580 }
1581
1582 /* -----------------------------------------------------------------------------
1583 * delete an object from the pool
1584 */
1585 static HsInt unloadObj_ (pathchar *path, bool just_purge)
1586 {
1587 ObjectCode *oc, *prev, *next;
1588 HsBool unloadedAnyObj = HS_BOOL_FALSE;
1589
1590 ASSERT(symhash != NULL);
1591 ASSERT(objects != NULL);
1592
1593 IF_DEBUG(linker, debugBelch("unloadObj: %" PATH_FMT "\n", path));
1594
1595 prev = NULL;
1596 for (oc = objects; oc; oc = next) {
1597 next = oc->next; // oc might be freed
1598
1599 if (!pathcmp(oc->fileName,path)) {
1600
1601 // these are both idempotent, so in just_purge mode we can
1602 // later call unloadObj() to really unload the object.
1603 removeOcSymbols(oc);
1604 freeOcStablePtrs(oc);
1605
1606 if (!just_purge) {
1607 if (prev == NULL) {
1608 objects = oc->next;
1609 } else {
1610 prev->next = oc->next;
1611 }
1612 ACQUIRE_LOCK(&linker_unloaded_mutex);
1613 oc->next = unloaded_objects;
1614 unloaded_objects = oc;
1615 oc->status = OBJECT_UNLOADED;
1616 RELEASE_LOCK(&linker_unloaded_mutex);
1617 // We do not own oc any more; it can be released at any time by
1618 // the GC in checkUnload().
1619 } else {
1620 prev = oc;
1621 }
1622
1623 /* This could be a member of an archive so continue
1624 * unloading other members. */
1625 unloadedAnyObj = HS_BOOL_TRUE;
1626 } else {
1627 prev = oc;
1628 }
1629 }
1630
1631 if (unloadedAnyObj) {
1632 return 1;
1633 }
1634 else {
1635 errorBelch("unloadObj: can't find `%" PATH_FMT "' to unload", path);
1636 return 0;
1637 }
1638 }
1639
1640 HsInt unloadObj (pathchar *path)
1641 {
1642 ACQUIRE_LOCK(&linker_mutex);
1643 HsInt r = unloadObj_(path, false);
1644 RELEASE_LOCK(&linker_mutex);
1645 return r;
1646 }
1647
1648 HsInt purgeObj (pathchar *path)
1649 {
1650 ACQUIRE_LOCK(&linker_mutex);
1651 HsInt r = unloadObj_(path, true);
1652 RELEASE_LOCK(&linker_mutex);
1653 return r;
1654 }
1655
1656 /* -----------------------------------------------------------------------------
1657 * Sanity checking. For each ObjectCode, maintain a list of address ranges
1658 * which may be prodded during relocation, and abort if we try and write
1659 * outside any of these.
1660 */
1661 void
1662 addProddableBlock ( ObjectCode* oc, void* start, int size )
1663 {
1664 ProddableBlock* pb
1665 = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
1666
1667 IF_DEBUG(linker, debugBelch("addProddableBlock: %p %p %d\n", oc, start, size));
1668 ASSERT(size > 0);
1669 pb->start = start;
1670 pb->size = size;
1671 pb->next = oc->proddables;
1672 oc->proddables = pb;
1673 }
1674
1675 void
1676 checkProddableBlock (ObjectCode *oc, void *addr, size_t size )
1677 {
1678 ProddableBlock* pb;
1679
1680 for (pb = oc->proddables; pb != NULL; pb = pb->next) {
1681 char* s = (char*)(pb->start);
1682 char* e = s + pb->size;
1683 char* a = (char*)addr;
1684 if (a >= s && (a+size) <= e) return;
1685 }
1686 barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr);
1687 }
1688
1689 void freeProddableBlocks (ObjectCode *oc)
1690 {
1691 ProddableBlock *pb, *next;
1692
1693 for (pb = oc->proddables; pb != NULL; pb = next) {
1694 next = pb->next;
1695 stgFree(pb);
1696 }
1697 oc->proddables = NULL;
1698 }
1699
1700 /* -----------------------------------------------------------------------------
1701 * Section management.
1702 */
1703 void
1704 addSection (Section *s, SectionKind kind, SectionAlloc alloc,
1705 void* start, StgWord size, StgWord mapped_offset,
1706 void* mapped_start, StgWord mapped_size)
1707 {
1708 s->start = start; /* actual start of section in memory */
1709 s->size = size; /* actual size of section in memory */
1710 s->kind = kind;
1711 s->alloc = alloc;
1712 s->mapped_offset = mapped_offset; /* offset from the image of mapped_start */
1713
1714 s->mapped_start = mapped_start; /* start of mmap() block */
1715 s->mapped_size = mapped_size; /* size of mmap() block */
1716
1717 IF_DEBUG(linker,
1718 debugBelch("addSection: %p-%p (size %" FMT_Word "), kind %d\n",
1719 start, (void*)((StgWord)start + size),
1720 size, kind ));
1721 }
1722