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