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