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