rts/Linker.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 2000-2004
   4  *
   5  * RTS Object Linker
   6  *
   7  * ---------------------------------------------------------------------------*/
   8
   9 #if 0
  10 #include "PosixSource.h"
  11 #endif
  12
  13 /* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h> and
  14    MREMAP_MAYMOVE from <sys/mman.h>.
  15  */
  16 #ifdef __linux__
  17 #define _GNU_SOURCE
  18 #endif
  19
  20 #include "Rts.h"
  21 #include "RtsFlags.h"
  22 #include "HsFFI.h"
  23 #include "Hash.h"
  24 #include "Linker.h"
  25 #include "LinkerInternals.h"
  26 #include "RtsUtils.h"
  27 #include "Schedule.h"
  28 #include "Sparks.h"
  29 #include "RtsGlobals.h"
  30 #include "Timer.h"
  31 #include "Trace.h"
  32
  33 #ifdef HAVE_SYS_TYPES_H
  34 #include <sys/types.h>
  35 #endif
  36
  37 #include <stdlib.h>
  38 #include <string.h>
  39
  40 #ifdef HAVE_SYS_STAT_H
  41 #include <sys/stat.h>
  42 #endif
  43
  44 #if defined(HAVE_DLFCN_H)
  45 #include <dlfcn.h>
  46 #endif
  47
  48 #if defined(cygwin32_HOST_OS)
  49 #ifdef HAVE_DIRENT_H
  50 #include <dirent.h>
  51 #endif
  52
  53 #ifdef HAVE_SYS_TIME_H
  54 #include <sys/time.h>
  55 #endif
  56 #include <regex.h>
  57 #include <sys/fcntl.h>
  58 #include <sys/termios.h>
  59 #include <sys/utime.h>
  60 #include <sys/utsname.h>
  61 #include <sys/wait.h>
  62 #endif
  63
  64 #if defined(ia64_HOST_ARCH) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS)
  65 #define USE_MMAP
  66 #include <fcntl.h>
  67 #include <sys/mman.h>
  68
  69 #if defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS)
  70 #ifdef HAVE_UNISTD_H
  71 #include <unistd.h>
  72 #endif
  73 #endif
  74
  75 #endif
  76
  77 #if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) || defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS)
  78 #  define OBJFORMAT_ELF
  79 #elif defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
  80 #  define OBJFORMAT_PEi386
  81 #  include <windows.h>
  82 #  include <math.h>
  83 #elif defined(darwin_HOST_OS)
  84 #  define OBJFORMAT_MACHO
  85 #  include <mach-o/loader.h>
  86 #  include <mach-o/nlist.h>
  87 #  include <mach-o/reloc.h>
  88 #if !defined(HAVE_DLFCN_H)
  89 #  include <mach-o/dyld.h>
  90 #endif
  91 #if defined(powerpc_HOST_ARCH)
  92 #  include <mach-o/ppc/reloc.h>
  93 #endif
  94 #if defined(x86_64_HOST_ARCH)
  95 #  include <mach-o/x86_64/reloc.h>
  96 #endif
  97 #endif
  98
  99 /* Hash table mapping symbol names to Symbol */
 100 static /*Str*/HashTable *symhash;
 101
 102 /* Hash table mapping symbol names to StgStablePtr */
 103 static /*Str*/HashTable *stablehash;
 104
 105 /* List of currently loaded objects */
 106 ObjectCode *objects = NULL;     /* initially empty */
 107
 108 #if defined(OBJFORMAT_ELF)
 109 static int ocVerifyImage_ELF    ( ObjectCode* oc );
 110 static int ocGetNames_ELF       ( ObjectCode* oc );
 111 static int ocResolve_ELF        ( ObjectCode* oc );
 112 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
 113 static int ocAllocateSymbolExtras_ELF ( ObjectCode* oc );
 114 #endif
 115 #elif defined(OBJFORMAT_PEi386)
 116 static int ocVerifyImage_PEi386 ( ObjectCode* oc );
 117 static int ocGetNames_PEi386    ( ObjectCode* oc );
 118 static int ocResolve_PEi386     ( ObjectCode* oc );
 119 static void *lookupSymbolInDLLs ( unsigned char *lbl );
 120 static void zapTrailingAtSign   ( unsigned char *sym );
 121 #elif defined(OBJFORMAT_MACHO)
 122 static int ocVerifyImage_MachO    ( ObjectCode* oc );
 123 static int ocGetNames_MachO       ( ObjectCode* oc );
 124 static int ocResolve_MachO        ( ObjectCode* oc );
 125
 126 static int machoGetMisalignment( FILE * );
 127 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
 128 static int ocAllocateSymbolExtras_MachO ( ObjectCode* oc );
 129 #endif
 130 #ifdef powerpc_HOST_ARCH
 131 static void machoInitSymbolsWithoutUnderscore( void );
 132 #endif
 133 #endif
 134
 135 /* on x86_64 we have a problem with relocating symbol references in
 136  * code that was compiled without -fPIC.  By default, the small memory
 137  * model is used, which assumes that symbol references can fit in a
 138  * 32-bit slot.  The system dynamic linker makes this work for
 139  * references to shared libraries by either (a) allocating a jump
 140  * table slot for code references, or (b) moving the symbol at load
 141  * time (and copying its contents, if necessary) for data references.
 142  *
 143  * We unfortunately can't tell whether symbol references are to code
 144  * or data.  So for now we assume they are code (the vast majority
 145  * are), and allocate jump-table slots.  Unfortunately this will
 146  * SILENTLY generate crashing code for data references.  This hack is
 147  * enabled by X86_64_ELF_NONPIC_HACK.
 148  *
 149  * One workaround is to use shared Haskell libraries.  This is
 150  * coming.  Another workaround is to keep the static libraries but
 151  * compile them with -fPIC, because that will generate PIC references
 152  * to data which can be relocated.  The PIC code is still too green to
 153  * do this systematically, though.
 154  *
 155  * See bug #781
 156  * See thread http://www.haskell.org/pipermail/cvs-ghc/2007-September/038458.html
 157  *
 158  * Naming Scheme for Symbol Macros
 159  *
 160  * SymI_*: symbol is internal to the RTS. It resides in an object
 161  *         file/library that is statically.
 162  * SymE_*: symbol is external to the RTS library. It might be linked
 163  *         dynamically.
 164  *
 165  * Sym*_HasProto  : the symbol prototype is imported in an include file
 166  *                  or defined explicitly
 167  * Sym*_NeedsProto: the symbol is undefined and we add a dummy
 168  *                  default proto extern void sym(void);
 169  */
 170 #define X86_64_ELF_NONPIC_HACK 1
 171
 172 /* Link objects into the lower 2Gb on x86_64.  GHC assumes the
 173  * small memory model on this architecture (see gcc docs,
 174  * -mcmodel=small).
 175  *
 176  * MAP_32BIT not available on OpenBSD/amd64
 177  */
 178 #if defined(x86_64_HOST_ARCH) && defined(MAP_32BIT)
 179 #define TRY_MAP_32BIT MAP_32BIT
 180 #else
 181 #define TRY_MAP_32BIT 0
 182 #endif
 183
 184 /*
 185  * Due to the small memory model (see above), on x86_64 we have to map
 186  * all our non-PIC object files into the low 2Gb of the address space
 187  * (why 2Gb and not 4Gb?  Because all addresses must be reachable
 188  * using a 32-bit signed PC-relative offset). On Linux we can do this
 189  * using the MAP_32BIT flag to mmap(), however on other OSs
 190  * (e.g. *BSD, see #2063, and also on Linux inside Xen, see #2512), we
 191  * can't do this.  So on these systems, we have to pick a base address
 192  * in the low 2Gb of the address space and try to allocate memory from
 193  * there.
 194  *
 195  * We pick a default address based on the OS, but also make this
 196  * configurable via an RTS flag (+RTS -xm)
 197  */
 198 #if defined(x86_64_HOST_ARCH)
 199
 200 #if defined(MAP_32BIT)
 201 // Try to use MAP_32BIT
 202 #define MMAP_32BIT_BASE_DEFAULT 0
 203 #else
 204 // A guess: 1Gb.
 205 #define MMAP_32BIT_BASE_DEFAULT 0x40000000
 206 #endif
 207
 208 static void *mmap_32bit_base = (void *)MMAP_32BIT_BASE_DEFAULT;
 209 #endif
 210
 211 /* MAP_ANONYMOUS is MAP_ANON on some systems, e.g. OpenBSD */
 212 #if !defined(MAP_ANONYMOUS) && defined(MAP_ANON)
 213 #define MAP_ANONYMOUS MAP_ANON
 214 #endif
 215
 216 /* -----------------------------------------------------------------------------
 217  * Built-in symbols from the RTS
 218  */
 219
 220 typedef struct _RtsSymbolVal {
 221     char   *lbl;
 222     void   *addr;
 223 } RtsSymbolVal;
 224
 225 #define Maybe_Stable_Names      SymI_HasProto(mkWeakzh_fast)                    \
 226                                 SymI_HasProto(mkWeakForeignEnvzh_fast)          \
 227                                 SymI_HasProto(makeStableNamezh_fast)            \
 228                                 SymI_HasProto(finalizzeWeakzh_fast)
 229
 230 #if !defined (mingw32_HOST_OS)
 231 #define RTS_POSIX_ONLY_SYMBOLS                  \
 232       SymI_HasProto(shutdownHaskellAndSignal)   \
 233       SymI_NeedsProto(lockFile)                 \
 234       SymI_NeedsProto(unlockFile)               \
 235       SymI_HasProto(signal_handlers)            \
 236       SymI_HasProto(stg_sig_install)            \
 237       SymI_NeedsProto(nocldstop)
 238 #endif
 239
 240 #if defined (cygwin32_HOST_OS)
 241 #define RTS_MINGW_ONLY_SYMBOLS /**/
 242 /* Don't have the ability to read import libs / archives, so
 243  * we have to stupidly list a lot of what libcygwin.a
 244  * exports; sigh.
 245  */
 246 #define RTS_CYGWIN_ONLY_SYMBOLS                          \
 247       SymI_HasProto(regfree)                             \
 248       SymI_HasProto(regexec)                             \
 249       SymI_HasProto(regerror)                            \
 250       SymI_HasProto(regcomp)                             \
 251       SymI_HasProto(__errno)                             \
 252       SymI_HasProto(access)                              \
 253       SymI_HasProto(chmod)                               \
 254       SymI_HasProto(chdir)                               \
 255       SymI_HasProto(close)                               \
 256       SymI_HasProto(creat)                               \
 257       SymI_HasProto(dup)                                 \
 258       SymI_HasProto(dup2)                                \
 259       SymI_HasProto(fstat)                               \
 260       SymI_HasProto(fcntl)                               \
 261       SymI_HasProto(getcwd)                              \
 262       SymI_HasProto(getenv)                              \
 263       SymI_HasProto(lseek)                               \
 264       SymI_HasProto(open)                                \
 265       SymI_HasProto(fpathconf)                           \
 266       SymI_HasProto(pathconf)                            \
 267       SymI_HasProto(stat)                                \
 268       SymI_HasProto(pow)                                 \
 269       SymI_HasProto(tanh)                                \
 270       SymI_HasProto(cosh)                                \
 271       SymI_HasProto(sinh)                                \
 272       SymI_HasProto(atan)                                \
 273       SymI_HasProto(acos)                                \
 274       SymI_HasProto(asin)                                \
 275       SymI_HasProto(tan)                                 \
 276       SymI_HasProto(cos)                                 \
 277       SymI_HasProto(sin)                                 \
 278       SymI_HasProto(exp)                                 \
 279       SymI_HasProto(log)                                 \
 280       SymI_HasProto(sqrt)                                \
 281       SymI_HasProto(localtime_r)                         \
 282       SymI_HasProto(gmtime_r)                            \
 283       SymI_HasProto(mktime)                              \
 284       SymI_NeedsProto(_imp___tzname)                     \
 285       SymI_HasProto(gettimeofday)                        \
 286       SymI_HasProto(timezone)                            \
 287       SymI_HasProto(tcgetattr)                           \
 288       SymI_HasProto(tcsetattr)                           \
 289       SymI_HasProto(memcpy)                              \
 290       SymI_HasProto(memmove)                             \
 291       SymI_HasProto(realloc)                             \
 292       SymI_HasProto(malloc)                              \
 293       SymI_HasProto(free)                                \
 294       SymI_HasProto(fork)                                \
 295       SymI_HasProto(lstat)                               \
 296       SymI_HasProto(isatty)                              \
 297       SymI_HasProto(mkdir)                               \
 298       SymI_HasProto(opendir)                             \
 299       SymI_HasProto(readdir)                             \
 300       SymI_HasProto(rewinddir)                           \
 301       SymI_HasProto(closedir)                            \
 302       SymI_HasProto(link)                                \
 303       SymI_HasProto(mkfifo)                              \
 304       SymI_HasProto(pipe)                                \
 305       SymI_HasProto(read)                                \
 306       SymI_HasProto(rename)                              \
 307       SymI_HasProto(rmdir)                               \
 308       SymI_HasProto(select)                              \
 309       SymI_HasProto(system)                              \
 310       SymI_HasProto(write)                               \
 311       SymI_HasProto(strcmp)                              \
 312       SymI_HasProto(strcpy)                              \
 313       SymI_HasProto(strncpy)                             \
 314       SymI_HasProto(strerror)                            \
 315       SymI_HasProto(sigaddset)                           \
 316       SymI_HasProto(sigemptyset)                         \
 317       SymI_HasProto(sigprocmask)                         \
 318       SymI_HasProto(umask)                               \
 319       SymI_HasProto(uname)                               \
 320       SymI_HasProto(unlink)                              \
 321       SymI_HasProto(utime)                               \
 322       SymI_HasProto(waitpid)
 323
 324 #elif !defined(mingw32_HOST_OS)
 325 #define RTS_MINGW_ONLY_SYMBOLS /**/
 326 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
 327 #else /* defined(mingw32_HOST_OS) */
 328 #define RTS_POSIX_ONLY_SYMBOLS  /**/
 329 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
 330
 331 /* Extra syms gen'ed by mingw-2's gcc-3.2: */
 332 #if __GNUC__>=3
 333 #define RTS_MINGW_EXTRA_SYMS                    \
 334       SymI_NeedsProto(_imp____mb_cur_max)       \
 335       SymI_NeedsProto(_imp___pctype)
 336 #else
 337 #define RTS_MINGW_EXTRA_SYMS
 338 #endif
 339
 340 #if HAVE_GETTIMEOFDAY
 341 #define RTS_MINGW_GETTIMEOFDAY_SYM SymI_NeedsProto(gettimeofday)
 342 #else
 343 #define RTS_MINGW_GETTIMEOFDAY_SYM /**/
 344 #endif
 345
 346 /* These are statically linked from the mingw libraries into the ghc
 347    executable, so we have to employ this hack. */
 348 #define RTS_MINGW_ONLY_SYMBOLS                           \
 349       SymI_HasProto(asyncReadzh_fast)                    \
 350       SymI_HasProto(asyncWritezh_fast)                   \
 351       SymI_HasProto(asyncDoProczh_fast)                  \
 352       SymI_HasProto(memset)                              \
 353       SymI_HasProto(inet_ntoa)                           \
 354       SymI_HasProto(inet_addr)                           \
 355       SymI_HasProto(htonl)                               \
 356       SymI_HasProto(recvfrom)                            \
 357       SymI_HasProto(listen)                              \
 358       SymI_HasProto(bind)                                \
 359       SymI_HasProto(shutdown)                            \
 360       SymI_HasProto(connect)                             \
 361       SymI_HasProto(htons)                               \
 362       SymI_HasProto(ntohs)                               \
 363       SymI_HasProto(getservbyname)                       \
 364       SymI_HasProto(getservbyport)                       \
 365       SymI_HasProto(getprotobynumber)                    \
 366       SymI_HasProto(getprotobyname)                      \
 367       SymI_HasProto(gethostbyname)                       \
 368       SymI_HasProto(gethostbyaddr)                       \
 369       SymI_HasProto(gethostname)                         \
 370       SymI_HasProto(strcpy)                              \
 371       SymI_HasProto(strncpy)                             \
 372       SymI_HasProto(abort)                               \
 373       SymI_NeedsProto(_alloca)                           \
 374       SymI_NeedsProto(isxdigit)                          \
 375       SymI_NeedsProto(isupper)                           \
 376       SymI_NeedsProto(ispunct)                           \
 377       SymI_NeedsProto(islower)                           \
 378       SymI_NeedsProto(isspace)                           \
 379       SymI_NeedsProto(isprint)                           \
 380       SymI_NeedsProto(isdigit)                           \
 381       SymI_NeedsProto(iscntrl)                           \
 382       SymI_NeedsProto(isalpha)                           \
 383       SymI_NeedsProto(isalnum)                           \
 384       SymI_HasProto(strcmp)                              \
 385       SymI_HasProto(memmove)                             \
 386       SymI_HasProto(realloc)                             \
 387       SymI_HasProto(malloc)                              \
 388       SymI_HasProto(pow)                                 \
 389       SymI_HasProto(tanh)                                \
 390       SymI_HasProto(cosh)                                \
 391       SymI_HasProto(sinh)                                \
 392       SymI_HasProto(atan)                                \
 393       SymI_HasProto(acos)                                \
 394       SymI_HasProto(asin)                                \
 395       SymI_HasProto(tan)                                 \
 396       SymI_HasProto(cos)                                 \
 397       SymI_HasProto(sin)                                 \
 398       SymI_HasProto(exp)                                 \
 399       SymI_HasProto(log)                                 \
 400       SymI_HasProto(sqrt)                                \
 401       SymI_HasProto(powf)                                \
 402       SymI_HasProto(tanhf)                               \
 403       SymI_HasProto(coshf)                               \
 404       SymI_HasProto(sinhf)                               \
 405       SymI_HasProto(atanf)                               \
 406       SymI_HasProto(acosf)                               \
 407       SymI_HasProto(asinf)                               \
 408       SymI_HasProto(tanf)                                \
 409       SymI_HasProto(cosf)                                \
 410       SymI_HasProto(sinf)                                \
 411       SymI_HasProto(expf)                                \
 412       SymI_HasProto(logf)                                \
 413       SymI_HasProto(sqrtf)                               \
 414       SymI_HasProto(memcpy)                              \
 415       SymI_HasProto(rts_InstallConsoleEvent)             \
 416       SymI_HasProto(rts_ConsoleHandlerDone)              \
 417       SymI_NeedsProto(mktime)                            \
 418       SymI_NeedsProto(_imp___timezone)                   \
 419       SymI_NeedsProto(_imp___tzname)                     \
 420       SymI_NeedsProto(_imp__tzname)                      \
 421       SymI_NeedsProto(_imp___iob)                        \
 422       SymI_NeedsProto(_imp___osver)                      \
 423       SymI_NeedsProto(localtime)                         \
 424       SymI_NeedsProto(gmtime)                            \
 425       SymI_NeedsProto(opendir)                           \
 426       SymI_NeedsProto(readdir)                           \
 427       SymI_NeedsProto(rewinddir)                         \
 428       RTS_MINGW_EXTRA_SYMS                               \
 429       RTS_MINGW_GETTIMEOFDAY_SYM                         \
 430       SymI_NeedsProto(closedir)
 431 #endif
 432
 433 #if defined(darwin_TARGET_OS) && HAVE_PRINTF_LDBLSTUB
 434 #define RTS_DARWIN_ONLY_SYMBOLS                             \
 435      SymI_NeedsProto(asprintf$LDBLStub)                     \
 436      SymI_NeedsProto(err$LDBLStub)                          \
 437      SymI_NeedsProto(errc$LDBLStub)                         \
 438      SymI_NeedsProto(errx$LDBLStub)                         \
 439      SymI_NeedsProto(fprintf$LDBLStub)                      \
 440      SymI_NeedsProto(fscanf$LDBLStub)                       \
 441      SymI_NeedsProto(fwprintf$LDBLStub)                     \
 442      SymI_NeedsProto(fwscanf$LDBLStub)                      \
 443      SymI_NeedsProto(printf$LDBLStub)                       \
 444      SymI_NeedsProto(scanf$LDBLStub)                        \
 445      SymI_NeedsProto(snprintf$LDBLStub)                     \
 446      SymI_NeedsProto(sprintf$LDBLStub)                      \
 447      SymI_NeedsProto(sscanf$LDBLStub)                       \
 448      SymI_NeedsProto(strtold$LDBLStub)                      \
 449      SymI_NeedsProto(swprintf$LDBLStub)                     \
 450      SymI_NeedsProto(swscanf$LDBLStub)                      \
 451      SymI_NeedsProto(syslog$LDBLStub)                       \
 452      SymI_NeedsProto(vasprintf$LDBLStub)                    \
 453      SymI_NeedsProto(verr$LDBLStub)                         \
 454      SymI_NeedsProto(verrc$LDBLStub)                        \
 455      SymI_NeedsProto(verrx$LDBLStub)                        \
 456      SymI_NeedsProto(vfprintf$LDBLStub)                     \
 457      SymI_NeedsProto(vfscanf$LDBLStub)                      \
 458      SymI_NeedsProto(vfwprintf$LDBLStub)                    \
 459      SymI_NeedsProto(vfwscanf$LDBLStub)                     \
 460      SymI_NeedsProto(vprintf$LDBLStub)                      \
 461      SymI_NeedsProto(vscanf$LDBLStub)                       \
 462      SymI_NeedsProto(vsnprintf$LDBLStub)                    \
 463      SymI_NeedsProto(vsprintf$LDBLStub)                     \
 464      SymI_NeedsProto(vsscanf$LDBLStub)                      \
 465      SymI_NeedsProto(vswprintf$LDBLStub)                    \
 466      SymI_NeedsProto(vswscanf$LDBLStub)                     \
 467      SymI_NeedsProto(vsyslog$LDBLStub)                      \
 468      SymI_NeedsProto(vwarn$LDBLStub)                        \
 469      SymI_NeedsProto(vwarnc$LDBLStub)                       \
 470      SymI_NeedsProto(vwarnx$LDBLStub)                       \
 471      SymI_NeedsProto(vwprintf$LDBLStub)                     \
 472      SymI_NeedsProto(vwscanf$LDBLStub)                      \
 473      SymI_NeedsProto(warn$LDBLStub)                         \
 474      SymI_NeedsProto(warnc$LDBLStub)                        \
 475      SymI_NeedsProto(warnx$LDBLStub)                        \
 476      SymI_NeedsProto(wcstold$LDBLStub)                      \
 477      SymI_NeedsProto(wprintf$LDBLStub)                      \
 478      SymI_NeedsProto(wscanf$LDBLStub)
 479 #else
 480 #define RTS_DARWIN_ONLY_SYMBOLS
 481 #endif
 482
 483 #ifndef SMP
 484 # define MAIN_CAP_SYM SymI_HasProto(MainCapability)
 485 #else
 486 # define MAIN_CAP_SYM
 487 #endif
 488
 489 #if !defined(mingw32_HOST_OS)
 490 #define RTS_USER_SIGNALS_SYMBOLS \
 491    SymI_HasProto(setIOManagerPipe) \
 492    SymI_NeedsProto(blockUserSignals) \
 493    SymI_NeedsProto(unblockUserSignals)
 494 #else
 495 #define RTS_USER_SIGNALS_SYMBOLS     \
 496    SymI_HasProto(sendIOManagerEvent) \
 497    SymI_HasProto(readIOManagerEvent) \
 498    SymI_HasProto(getIOManagerEvent)  \
 499    SymI_HasProto(console_handler)
 500 #endif
 501
 502 #define RTS_LIBFFI_SYMBOLS                                  \
 503      SymE_NeedsProto(ffi_prep_cif)                          \
 504      SymE_NeedsProto(ffi_call)                              \
 505      SymE_NeedsProto(ffi_type_void)                         \
 506      SymE_NeedsProto(ffi_type_float)                        \
 507      SymE_NeedsProto(ffi_type_double)                       \
 508      SymE_NeedsProto(ffi_type_sint64)                       \
 509      SymE_NeedsProto(ffi_type_uint64)                       \
 510      SymE_NeedsProto(ffi_type_sint32)                       \
 511      SymE_NeedsProto(ffi_type_uint32)                       \
 512      SymE_NeedsProto(ffi_type_sint16)                       \
 513      SymE_NeedsProto(ffi_type_uint16)                       \
 514      SymE_NeedsProto(ffi_type_sint8)                        \
 515      SymE_NeedsProto(ffi_type_uint8)                        \
 516      SymE_NeedsProto(ffi_type_pointer)
 517
 518 #ifdef TABLES_NEXT_TO_CODE
 519 #define RTS_RET_SYMBOLS /* nothing */
 520 #else
 521 #define RTS_RET_SYMBOLS                                 \
 522       SymI_HasProto(stg_enter_ret)                      \
 523       SymI_HasProto(stg_gc_fun_ret)                     \
 524       SymI_HasProto(stg_ap_v_ret)                       \
 525       SymI_HasProto(stg_ap_f_ret)                       \
 526       SymI_HasProto(stg_ap_d_ret)                       \
 527       SymI_HasProto(stg_ap_l_ret)                       \
 528       SymI_HasProto(stg_ap_n_ret)                       \
 529       SymI_HasProto(stg_ap_p_ret)                       \
 530       SymI_HasProto(stg_ap_pv_ret)                      \
 531       SymI_HasProto(stg_ap_pp_ret)                      \
 532       SymI_HasProto(stg_ap_ppv_ret)                     \
 533       SymI_HasProto(stg_ap_ppp_ret)                     \
 534       SymI_HasProto(stg_ap_pppv_ret)                    \
 535       SymI_HasProto(stg_ap_pppp_ret)                    \
 536       SymI_HasProto(stg_ap_ppppp_ret)                   \
 537       SymI_HasProto(stg_ap_pppppp_ret)
 538 #endif
 539
 540 #define RTS_SYMBOLS                                     \
 541       Maybe_Stable_Names                                \
 542       SymI_HasProto(StgReturn)                          \
 543       SymI_HasProto(stg_enter_info)                     \
 544       SymI_HasProto(stg_gc_void_info)                   \
 545       SymI_HasProto(__stg_gc_enter_1)                   \
 546       SymI_HasProto(stg_gc_noregs)                      \
 547       SymI_HasProto(stg_gc_unpt_r1_info)                \
 548       SymI_HasProto(stg_gc_unpt_r1)                     \
 549       SymI_HasProto(stg_gc_unbx_r1_info)                \
 550       SymI_HasProto(stg_gc_unbx_r1)                     \
 551       SymI_HasProto(stg_gc_f1_info)                     \
 552       SymI_HasProto(stg_gc_f1)                          \
 553       SymI_HasProto(stg_gc_d1_info)                     \
 554       SymI_HasProto(stg_gc_d1)                          \
 555       SymI_HasProto(stg_gc_l1_info)                     \
 556       SymI_HasProto(stg_gc_l1)                          \
 557       SymI_HasProto(__stg_gc_fun)                       \
 558       SymI_HasProto(stg_gc_fun_info)                    \
 559       SymI_HasProto(stg_gc_gen)                         \
 560       SymI_HasProto(stg_gc_gen_info)                    \
 561       SymI_HasProto(stg_gc_gen_hp)                      \
 562       SymI_HasProto(stg_gc_ut)                          \
 563       SymI_HasProto(stg_gen_yield)                      \
 564       SymI_HasProto(stg_yield_noregs)                   \
 565       SymI_HasProto(stg_yield_to_interpreter)           \
 566       SymI_HasProto(stg_gen_block)                      \
 567       SymI_HasProto(stg_block_noregs)                   \
 568       SymI_HasProto(stg_block_1)                        \
 569       SymI_HasProto(stg_block_takemvar)                 \
 570       SymI_HasProto(stg_block_putmvar)                  \
 571       MAIN_CAP_SYM                                      \
 572       SymI_HasProto(MallocFailHook)                     \
 573       SymI_HasProto(OnExitHook)                         \
 574       SymI_HasProto(OutOfHeapHook)                      \
 575       SymI_HasProto(StackOverflowHook)                  \
 576       SymI_HasProto(addDLL)                             \
 577       SymI_HasProto(__int_encodeDouble)                 \
 578       SymI_HasProto(__word_encodeDouble)                \
 579       SymI_HasProto(__2Int_encodeDouble)                \
 580       SymI_HasProto(__int_encodeFloat)                  \
 581       SymI_HasProto(__word_encodeFloat)                 \
 582       SymI_HasProto(atomicallyzh_fast)                  \
 583       SymI_HasProto(barf)                               \
 584       SymI_HasProto(debugBelch)                         \
 585       SymI_HasProto(errorBelch)                         \
 586       SymI_HasProto(sysErrorBelch)                      \
 587       SymI_HasProto(asyncExceptionsBlockedzh_fast)      \
 588       SymI_HasProto(blockAsyncExceptionszh_fast)        \
 589       SymI_HasProto(catchzh_fast)                       \
 590       SymI_HasProto(catchRetryzh_fast)                  \
 591       SymI_HasProto(catchSTMzh_fast)                    \
 592       SymI_HasProto(checkzh_fast)                       \
 593       SymI_HasProto(closure_flags)                      \
 594       SymI_HasProto(cmp_thread)                         \
 595       SymI_HasProto(createAdjustor)                     \
 596       SymI_HasProto(decodeDoublezu2Intzh_fast)          \
 597       SymI_HasProto(decodeFloatzuIntzh_fast)            \
 598       SymI_HasProto(defaultsHook)                       \
 599       SymI_HasProto(delayzh_fast)                       \
 600       SymI_HasProto(deRefWeakzh_fast)                   \
 601       SymI_HasProto(deRefStablePtrzh_fast)              \
 602       SymI_HasProto(dirty_MUT_VAR)                      \
 603       SymI_HasProto(forkzh_fast)                        \
 604       SymI_HasProto(forkOnzh_fast)                      \
 605       SymI_HasProto(forkProcess)                        \
 606       SymI_HasProto(forkOS_createThread)                \
 607       SymI_HasProto(freeHaskellFunctionPtr)             \
 608       SymI_HasProto(freeStablePtr)                      \
 609       SymI_HasProto(getOrSetTypeableStore)              \
 610       SymI_HasProto(getOrSetSignalHandlerStore)         \
 611       SymI_HasProto(genSymZh)                           \
 612       SymI_HasProto(genericRaise)                       \
 613       SymI_HasProto(getProgArgv)                        \
 614       SymI_HasProto(getFullProgArgv)                    \
 615       SymI_HasProto(getStablePtr)                       \
 616       SymI_HasProto(hs_init)                            \
 617       SymI_HasProto(hs_exit)                            \
 618       SymI_HasProto(hs_set_argv)                        \
 619       SymI_HasProto(hs_add_root)                        \
 620       SymI_HasProto(hs_perform_gc)                      \
 621       SymI_HasProto(hs_free_stable_ptr)                 \
 622       SymI_HasProto(hs_free_fun_ptr)                    \
 623       SymI_HasProto(hs_hpc_rootModule)                  \
 624       SymI_HasProto(hs_hpc_module)                      \
 625       SymI_HasProto(initLinker)                         \
 626       SymI_HasProto(unpackClosurezh_fast)               \
 627       SymI_HasProto(getApStackValzh_fast)               \
 628       SymI_HasProto(getSparkzh_fast)                    \
 629       SymI_HasProto(isCurrentThreadBoundzh_fast)        \
 630       SymI_HasProto(isDoubleDenormalized)               \
 631       SymI_HasProto(isDoubleInfinite)                   \
 632       SymI_HasProto(isDoubleNaN)                        \
 633       SymI_HasProto(isDoubleNegativeZero)               \
 634       SymI_HasProto(isEmptyMVarzh_fast)                 \
 635       SymI_HasProto(isFloatDenormalized)                \
 636       SymI_HasProto(isFloatInfinite)                    \
 637       SymI_HasProto(isFloatNaN)                         \
 638       SymI_HasProto(isFloatNegativeZero)                \
 639       SymI_HasProto(killThreadzh_fast)                  \
 640       SymI_HasProto(loadObj)                            \
 641       SymI_HasProto(insertStableSymbol)                 \
 642       SymI_HasProto(insertSymbol)                       \
 643       SymI_HasProto(lookupSymbol)                       \
 644       SymI_HasProto(makeStablePtrzh_fast)               \
 645       SymI_HasProto(mkApUpd0zh_fast)                    \
 646       SymI_HasProto(myThreadIdzh_fast)                  \
 647       SymI_HasProto(labelThreadzh_fast)                 \
 648       SymI_HasProto(newArrayzh_fast)                    \
 649       SymI_HasProto(newBCOzh_fast)                      \
 650       SymI_HasProto(newByteArrayzh_fast)                \
 651       SymI_HasProto_redirect(newCAF, newDynCAF)         \
 652       SymI_HasProto(newMVarzh_fast)                     \
 653       SymI_HasProto(newMutVarzh_fast)                   \
 654       SymI_HasProto(newTVarzh_fast)                     \
 655       SymI_HasProto(noDuplicatezh_fast)                 \
 656       SymI_HasProto(atomicModifyMutVarzh_fast)          \
 657       SymI_HasProto(newPinnedByteArrayzh_fast)          \
 658       SymI_HasProto(newAlignedPinnedByteArrayzh_fast)   \
 659       SymI_HasProto(newSpark)                           \
 660       SymI_HasProto(performGC)                          \
 661       SymI_HasProto(performMajorGC)                     \
 662       SymI_HasProto(prog_argc)                          \
 663       SymI_HasProto(prog_argv)                          \
 664       SymI_HasProto(putMVarzh_fast)                     \
 665       SymI_HasProto(raisezh_fast)                       \
 666       SymI_HasProto(raiseIOzh_fast)                     \
 667       SymI_HasProto(readTVarzh_fast)                    \
 668       SymI_HasProto(readTVarIOzh_fast)                  \
 669       SymI_HasProto(resetNonBlockingFd)                 \
 670       SymI_HasProto(resumeThread)                       \
 671       SymI_HasProto(resolveObjs)                        \
 672       SymI_HasProto(retryzh_fast)                       \
 673       SymI_HasProto(rts_apply)                          \
 674       SymI_HasProto(rts_checkSchedStatus)               \
 675       SymI_HasProto(rts_eval)                           \
 676       SymI_HasProto(rts_evalIO)                         \
 677       SymI_HasProto(rts_evalLazyIO)                     \
 678       SymI_HasProto(rts_evalStableIO)                   \
 679       SymI_HasProto(rts_eval_)                          \
 680       SymI_HasProto(rts_getBool)                        \
 681       SymI_HasProto(rts_getChar)                        \
 682       SymI_HasProto(rts_getDouble)                      \
 683       SymI_HasProto(rts_getFloat)                       \
 684       SymI_HasProto(rts_getInt)                         \
 685       SymI_HasProto(rts_getInt8)                        \
 686       SymI_HasProto(rts_getInt16)                       \
 687       SymI_HasProto(rts_getInt32)                       \
 688       SymI_HasProto(rts_getInt64)                       \
 689       SymI_HasProto(rts_getPtr)                         \
 690       SymI_HasProto(rts_getFunPtr)                      \
 691       SymI_HasProto(rts_getStablePtr)                   \
 692       SymI_HasProto(rts_getThreadId)                    \
 693       SymI_HasProto(rts_getWord)                        \
 694       SymI_HasProto(rts_getWord8)                       \
 695       SymI_HasProto(rts_getWord16)                      \
 696       SymI_HasProto(rts_getWord32)                      \
 697       SymI_HasProto(rts_getWord64)                      \
 698       SymI_HasProto(rts_lock)                           \
 699       SymI_HasProto(rts_mkBool)                         \
 700       SymI_HasProto(rts_mkChar)                         \
 701       SymI_HasProto(rts_mkDouble)                       \
 702       SymI_HasProto(rts_mkFloat)                        \
 703       SymI_HasProto(rts_mkInt)                          \
 704       SymI_HasProto(rts_mkInt8)                         \
 705       SymI_HasProto(rts_mkInt16)                        \
 706       SymI_HasProto(rts_mkInt32)                        \
 707       SymI_HasProto(rts_mkInt64)                        \
 708       SymI_HasProto(rts_mkPtr)                          \
 709       SymI_HasProto(rts_mkFunPtr)                       \
 710       SymI_HasProto(rts_mkStablePtr)                    \
 711       SymI_HasProto(rts_mkString)                       \
 712       SymI_HasProto(rts_mkWord)                         \
 713       SymI_HasProto(rts_mkWord8)                        \
 714       SymI_HasProto(rts_mkWord16)                       \
 715       SymI_HasProto(rts_mkWord32)                       \
 716       SymI_HasProto(rts_mkWord64)                       \
 717       SymI_HasProto(rts_unlock)                         \
 718       SymI_HasProto(rts_unsafeGetMyCapability)          \
 719       SymI_HasProto(rtsSupportsBoundThreads)            \
 720       SymI_HasProto(__hscore_get_saved_termios)         \
 721       SymI_HasProto(__hscore_set_saved_termios)         \
 722       SymI_HasProto(setProgArgv)                        \
 723       SymI_HasProto(startupHaskell)                     \
 724       SymI_HasProto(shutdownHaskell)                    \
 725       SymI_HasProto(shutdownHaskellAndExit)             \
 726       SymI_HasProto(stable_ptr_table)                   \
 727       SymI_HasProto(stackOverflow)                      \
 728       SymI_HasProto(stg_CAF_BLACKHOLE_info)             \
 729       SymI_HasProto(__stg_EAGER_BLACKHOLE_info)         \
 730       SymI_HasProto(awakenBlockedQueue)                 \
 731       SymI_HasProto(startTimer)                         \
 732       SymI_HasProto(stg_CHARLIKE_closure)               \
 733       SymI_HasProto(stg_MVAR_CLEAN_info)                \
 734       SymI_HasProto(stg_MVAR_DIRTY_info)                \
 735       SymI_HasProto(stg_IND_STATIC_info)                \
 736       SymI_HasProto(stg_INTLIKE_closure)                \
 737       SymI_HasProto(stg_ARR_WORDS_info)                 \
 738       SymI_HasProto(stg_MUT_ARR_PTRS_DIRTY_info)        \
 739       SymI_HasProto(stg_MUT_ARR_PTRS_FROZEN_info)       \
 740       SymI_HasProto(stg_MUT_ARR_PTRS_FROZEN0_info)      \
 741       SymI_HasProto(stg_WEAK_info)                      \
 742       SymI_HasProto(stg_ap_v_info)                      \
 743       SymI_HasProto(stg_ap_f_info)                      \
 744       SymI_HasProto(stg_ap_d_info)                      \
 745       SymI_HasProto(stg_ap_l_info)                      \
 746       SymI_HasProto(stg_ap_n_info)                      \
 747       SymI_HasProto(stg_ap_p_info)                      \
 748       SymI_HasProto(stg_ap_pv_info)                     \
 749       SymI_HasProto(stg_ap_pp_info)                     \
 750       SymI_HasProto(stg_ap_ppv_info)                    \
 751       SymI_HasProto(stg_ap_ppp_info)                    \
 752       SymI_HasProto(stg_ap_pppv_info)                   \
 753       SymI_HasProto(stg_ap_pppp_info)                   \
 754       SymI_HasProto(stg_ap_ppppp_info)                  \
 755       SymI_HasProto(stg_ap_pppppp_info)                 \
 756       SymI_HasProto(stg_ap_0_fast)                      \
 757       SymI_HasProto(stg_ap_v_fast)                      \
 758       SymI_HasProto(stg_ap_f_fast)                      \
 759       SymI_HasProto(stg_ap_d_fast)                      \
 760       SymI_HasProto(stg_ap_l_fast)                      \
 761       SymI_HasProto(stg_ap_n_fast)                      \
 762       SymI_HasProto(stg_ap_p_fast)                      \
 763       SymI_HasProto(stg_ap_pv_fast)                     \
 764       SymI_HasProto(stg_ap_pp_fast)                     \
 765       SymI_HasProto(stg_ap_ppv_fast)                    \
 766       SymI_HasProto(stg_ap_ppp_fast)                    \
 767       SymI_HasProto(stg_ap_pppv_fast)                   \
 768       SymI_HasProto(stg_ap_pppp_fast)                   \
 769       SymI_HasProto(stg_ap_ppppp_fast)                  \
 770       SymI_HasProto(stg_ap_pppppp_fast)                 \
 771       SymI_HasProto(stg_ap_1_upd_info)                  \
 772       SymI_HasProto(stg_ap_2_upd_info)                  \
 773       SymI_HasProto(stg_ap_3_upd_info)                  \
 774       SymI_HasProto(stg_ap_4_upd_info)                  \
 775       SymI_HasProto(stg_ap_5_upd_info)                  \
 776       SymI_HasProto(stg_ap_6_upd_info)                  \
 777       SymI_HasProto(stg_ap_7_upd_info)                  \
 778       SymI_HasProto(stg_exit)                           \
 779       SymI_HasProto(stg_sel_0_upd_info)                 \
 780       SymI_HasProto(stg_sel_10_upd_info)                \
 781       SymI_HasProto(stg_sel_11_upd_info)                \
 782       SymI_HasProto(stg_sel_12_upd_info)                \
 783       SymI_HasProto(stg_sel_13_upd_info)                \
 784       SymI_HasProto(stg_sel_14_upd_info)                \
 785       SymI_HasProto(stg_sel_15_upd_info)                \
 786       SymI_HasProto(stg_sel_1_upd_info)                 \
 787       SymI_HasProto(stg_sel_2_upd_info)                 \
 788       SymI_HasProto(stg_sel_3_upd_info)                 \
 789       SymI_HasProto(stg_sel_4_upd_info)                 \
 790       SymI_HasProto(stg_sel_5_upd_info)                 \
 791       SymI_HasProto(stg_sel_6_upd_info)                 \
 792       SymI_HasProto(stg_sel_7_upd_info)                 \
 793       SymI_HasProto(stg_sel_8_upd_info)                 \
 794       SymI_HasProto(stg_sel_9_upd_info)                 \
 795       SymI_HasProto(stg_upd_frame_info)                 \
 796       SymI_HasProto(suspendThread)                      \
 797       SymI_HasProto(takeMVarzh_fast)                    \
 798       SymI_HasProto(threadStatuszh_fast)                \
 799       SymI_HasProto(tryPutMVarzh_fast)                  \
 800       SymI_HasProto(tryTakeMVarzh_fast)                 \
 801       SymI_HasProto(unblockAsyncExceptionszh_fast)      \
 802       SymI_HasProto(unloadObj)                          \
 803       SymI_HasProto(unsafeThawArrayzh_fast)             \
 804       SymI_HasProto(waitReadzh_fast)                    \
 805       SymI_HasProto(waitWritezh_fast)                   \
 806       SymI_HasProto(writeTVarzh_fast)                   \
 807       SymI_HasProto(yieldzh_fast)                       \
 808       SymI_NeedsProto(stg_interp_constr_entry)          \
 809       SymI_HasProto(alloc_blocks)                       \
 810       SymI_HasProto(alloc_blocks_lim)                   \
 811       SymI_HasProto(allocateLocal)                      \
 812       SymI_HasProto(allocateExec)                       \
 813       SymI_HasProto(freeExec)                           \
 814       SymI_HasProto(getAllocations)                     \
 815       SymI_HasProto(revertCAFs)                         \
 816       SymI_HasProto(RtsFlags)                           \
 817       SymI_NeedsProto(rts_breakpoint_io_action)         \
 818       SymI_NeedsProto(rts_stop_next_breakpoint)         \
 819       SymI_NeedsProto(rts_stop_on_exception)            \
 820       SymI_HasProto(stopTimer)                          \
 821       SymI_HasProto(n_capabilities)                     \
 822       SymI_HasProto(traceCcszh_fast)                    \
 823       RTS_USER_SIGNALS_SYMBOLS
 824
 825
 826 // 64-bit support functions in libgcc.a
 827 #if defined(__GNUC__) && SIZEOF_VOID_P <= 4
 828 #define RTS_LIBGCC_SYMBOLS                             \
 829       SymI_NeedsProto(__divdi3)                        \
 830       SymI_NeedsProto(__udivdi3)                       \
 831       SymI_NeedsProto(__moddi3)                        \
 832       SymI_NeedsProto(__umoddi3)                       \
 833       SymI_NeedsProto(__muldi3)                        \
 834       SymI_NeedsProto(__ashldi3)                       \
 835       SymI_NeedsProto(__ashrdi3)                       \
 836       SymI_NeedsProto(__lshrdi3)                       \
 837       SymI_NeedsProto(__eprintf)
 838 #elif defined(ia64_HOST_ARCH)
 839 #define RTS_LIBGCC_SYMBOLS                              \
 840       SymI_NeedsProto(__divdi3)                         \
 841       SymI_NeedsProto(__udivdi3)                        \
 842       SymI_NeedsProto(__moddi3)                         \
 843       SymI_NeedsProto(__umoddi3)                        \
 844       SymI_NeedsProto(__divsf3)                         \
 845       SymI_NeedsProto(__divdf3)
 846 #else
 847 #define RTS_LIBGCC_SYMBOLS
 848 #endif
 849
 850 #if defined(darwin_HOST_OS) && defined(powerpc_HOST_ARCH)
 851       // Symbols that don't have a leading underscore
 852       // on Mac OS X. They have to receive special treatment,
 853       // see machoInitSymbolsWithoutUnderscore()
 854 #define RTS_MACHO_NOUNDERLINE_SYMBOLS           \
 855       SymI_NeedsProto(saveFP)                           \
 856       SymI_NeedsProto(restFP)
 857 #endif
 858
 859 /* entirely bogus claims about types of these symbols */
 860 #define SymI_NeedsProto(vvv)  extern void vvv(void);
 861 #if defined(__PIC__) && defined(mingw32_TARGET_OS)
 862 #define SymE_HasProto(vvv)    SymE_HasProto(vvv);
 863 #define SymE_NeedsProto(vvv)    extern void _imp__ ## vvv (void);
 864 #else
 865 #define SymE_NeedsProto(vvv)  SymI_NeedsProto(vvv);
 866 #define SymE_HasProto(vvv)    SymI_HasProto(vvv)
 867 #endif
 868 #define SymI_HasProto(vvv) /**/
 869 #define SymI_HasProto_redirect(vvv,xxx) /**/
 870 RTS_SYMBOLS
 871 RTS_RET_SYMBOLS
 872 RTS_POSIX_ONLY_SYMBOLS
 873 RTS_MINGW_ONLY_SYMBOLS
 874 RTS_CYGWIN_ONLY_SYMBOLS
 875 RTS_DARWIN_ONLY_SYMBOLS
 876 RTS_LIBGCC_SYMBOLS
 877 RTS_LIBFFI_SYMBOLS
 878 #undef SymI_NeedsProto
 879 #undef SymI_HasProto
 880 #undef SymI_HasProto_redirect
 881 #undef SymE_HasProto
 882 #undef SymE_NeedsProto
 883
 884 #ifdef LEADING_UNDERSCORE
 885 #define MAYBE_LEADING_UNDERSCORE_STR(s) ("_" s)
 886 #else
 887 #define MAYBE_LEADING_UNDERSCORE_STR(s) (s)
 888 #endif
 889
 890 #define SymI_HasProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
 891                     (void*)(&(vvv)) },
 892 #define SymE_HasProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
 893             (void*)DLL_IMPORT_DATA_REF(vvv) },
 894
 895 #define SymI_NeedsProto(vvv) SymI_HasProto(vvv)
 896 #define SymE_NeedsProto(vvv) SymE_HasProto(vvv)
 897
 898 // SymI_HasProto_redirect allows us to redirect references to one symbol to
 899 // another symbol.  See newCAF/newDynCAF for an example.
 900 #define SymI_HasProto_redirect(vvv,xxx) \
 901     { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
 902       (void*)(&(xxx)) },
 903
 904 static RtsSymbolVal rtsSyms[] = {
 905       RTS_SYMBOLS
 906       RTS_RET_SYMBOLS
 907       RTS_POSIX_ONLY_SYMBOLS
 908       RTS_MINGW_ONLY_SYMBOLS
 909       RTS_CYGWIN_ONLY_SYMBOLS
 910       RTS_DARWIN_ONLY_SYMBOLS
 911       RTS_LIBGCC_SYMBOLS
 912       RTS_LIBFFI_SYMBOLS
 913 #if defined(darwin_HOST_OS) && defined(i386_HOST_ARCH)
 914       // dyld stub code contains references to this,
 915       // but it should never be called because we treat
 916       // lazy pointers as nonlazy.
 917       { "dyld_stub_binding_helper", (void*)0xDEADBEEF },
 918 #endif
 919       { 0, 0 } /* sentinel */
 920 };
 921
 922
 923
 924 /* -----------------------------------------------------------------------------
 925  * Insert symbols into hash tables, checking for duplicates.
 926  */
 927
 928 static void ghciInsertStrHashTable ( char* obj_name,
 929                                      HashTable *table,
 930                                      char* key,
 931                                      void *data
 932                                    )
 933 {
 934    if (lookupHashTable(table, (StgWord)key) == NULL)
 935    {
 936       insertStrHashTable(table, (StgWord)key, data);
 937       return;
 938    }
 939    debugBelch(
 940       "\n\n"
 941       "GHCi runtime linker: fatal error: I found a duplicate definition for symbol\n"
 942       "   %s\n"
 943       "whilst processing object file\n"
 944       "   %s\n"
 945       "This could be caused by:\n"
 946       "   * Loading two different object files which export the same symbol\n"
 947       "   * Specifying the same object file twice on the GHCi command line\n"
 948       "   * An incorrect `package.conf' entry, causing some object to be\n"
 949       "     loaded twice.\n"
 950       "GHCi cannot safely continue in this situation.  Exiting now.  Sorry.\n"
 951       "\n",
 952       (char*)key,
 953       obj_name
 954    );
 955    exit(1);
 956 }
 957 /* -----------------------------------------------------------------------------
 958  * initialize the object linker
 959  */
 960
 961
 962 static int linker_init_done = 0 ;
 963
 964 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 965 static void *dl_prog_handle;
 966 #endif
 967
 968 void
 969 initLinker( void )
 970 {
 971     RtsSymbolVal *sym;
 972
 973     /* Make initLinker idempotent, so we can call it
 974        before evey relevant operation; that means we
 975        don't need to initialise the linker separately */
 976     if (linker_init_done == 1) { return; } else {
 977       linker_init_done = 1;
 978     }
 979
 980     stablehash = allocStrHashTable();
 981     symhash = allocStrHashTable();
 982
 983     /* populate the symbol table with stuff from the RTS */
 984     for (sym = rtsSyms; sym->lbl != NULL; sym++) {
 985         ghciInsertStrHashTable("(GHCi built-in symbols)",
 986                                symhash, sym->lbl, sym->addr);
 987     }
 988 #   if defined(OBJFORMAT_MACHO) && defined(powerpc_HOST_ARCH)
 989     machoInitSymbolsWithoutUnderscore();
 990 #   endif
 991
 992 #   if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 993 #   if defined(RTLD_DEFAULT)
 994     dl_prog_handle = RTLD_DEFAULT;
 995 #   else
 996     dl_prog_handle = dlopen(NULL, RTLD_LAZY);
 997 #   endif /* RTLD_DEFAULT */
 998 #   endif
 999
1000 #if defined(x86_64_HOST_ARCH)
1001     if (RtsFlags.MiscFlags.linkerMemBase != 0) {
1002         // User-override for mmap_32bit_base
1003         mmap_32bit_base = (void*)RtsFlags.MiscFlags.linkerMemBase;
1004     }
1005 #endif
1006
1007 #if defined(mingw32_HOST_OS)
1008     /*
1009      * These two libraries cause problems when added to the static link,
1010      * but are necessary for resolving symbols in GHCi, hence we load
1011      * them manually here.
1012      */
1013     addDLL("msvcrt");
1014     addDLL("kernel32");
1015 #endif
1016 }
1017
1018 /* -----------------------------------------------------------------------------
1019  *                  Loading DLL or .so dynamic libraries
1020  * -----------------------------------------------------------------------------
1021  *
1022  * Add a DLL from which symbols may be found.  In the ELF case, just
1023  * do RTLD_GLOBAL-style add, so no further messing around needs to
1024  * happen in order that symbols in the loaded .so are findable --
1025  * lookupSymbol() will subsequently see them by dlsym on the program's
1026  * dl-handle.  Returns NULL if success, otherwise ptr to an err msg.
1027  *
1028  * In the PEi386 case, open the DLLs and put handles to them in a
1029  * linked list.  When looking for a symbol, try all handles in the
1030  * list.  This means that we need to load even DLLs that are guaranteed
1031  * to be in the ghc.exe image already, just so we can get a handle
1032  * to give to loadSymbol, so that we can find the symbols.  For such
1033  * libraries, the LoadLibrary call should be a no-op except for returning
1034  * the handle.
1035  *
1036  */
1037
1038 #if defined(OBJFORMAT_PEi386)
1039 /* A record for storing handles into DLLs. */
1040
1041 typedef
1042    struct _OpenedDLL {
1043       char*              name;
1044       struct _OpenedDLL* next;
1045       HINSTANCE instance;
1046    }
1047    OpenedDLL;
1048
1049 /* A list thereof. */
1050 static OpenedDLL* opened_dlls = NULL;
1051 #endif
1052
1053 const char *
1054 addDLL( char *dll_name )
1055 {
1056 #  if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1057    /* ------------------- ELF DLL loader ------------------- */
1058    void *hdl;
1059    const char *errmsg;
1060
1061    initLinker();
1062
1063    // omitted: RTLD_NOW
1064    // see http://www.haskell.org/pipermail/cvs-ghc/2007-September/038570.html
1065    hdl= dlopen(dll_name, RTLD_LAZY | RTLD_GLOBAL);
1066
1067    if (hdl == NULL) {
1068       /* dlopen failed; return a ptr to the error msg. */
1069       errmsg = dlerror();
1070       if (errmsg == NULL) errmsg = "addDLL: unknown error";
1071       return errmsg;
1072    } else {
1073       return NULL;
1074    }
1075    /*NOTREACHED*/
1076
1077 #  elif defined(OBJFORMAT_PEi386)
1078    /* ------------------- Win32 DLL loader ------------------- */
1079
1080    char*      buf;
1081    OpenedDLL* o_dll;
1082    HINSTANCE  instance;
1083
1084    initLinker();
1085
1086    /* debugBelch("\naddDLL; dll_name = `%s'\n", dll_name); */
1087
1088    /* See if we've already got it, and ignore if so. */
1089    for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
1090       if (0 == strcmp(o_dll->name, dll_name))
1091          return NULL;
1092    }
1093
1094    /* The file name has no suffix (yet) so that we can try
1095       both foo.dll and foo.drv
1096
1097       The documentation for LoadLibrary says:
1098         If no file name extension is specified in the lpFileName
1099         parameter, the default library extension .dll is
1100         appended. However, the file name string can include a trailing
1101         point character (.) to indicate that the module name has no
1102         extension. */
1103
1104    buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
1105    sprintf(buf, "%s.DLL", dll_name);
1106    instance = LoadLibrary(buf);
1107    if (instance == NULL) {
1108        if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
1109        // KAA: allow loading of drivers (like winspool.drv)
1110        sprintf(buf, "%s.DRV", dll_name);
1111        instance = LoadLibrary(buf);
1112        if (instance == NULL) {
1113            if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
1114            // #1883: allow loading of unix-style libfoo.dll DLLs
1115            sprintf(buf, "lib%s.DLL", dll_name);
1116            instance = LoadLibrary(buf);
1117            if (instance == NULL) {
1118                goto error;
1119            }
1120        }
1121    }
1122    stgFree(buf);
1123
1124    /* Add this DLL to the list of DLLs in which to search for symbols. */
1125    o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
1126    o_dll->name     = stgMallocBytes(1+strlen(dll_name), "addDLL");
1127    strcpy(o_dll->name, dll_name);
1128    o_dll->instance = instance;
1129    o_dll->next     = opened_dlls;
1130    opened_dlls     = o_dll;
1131
1132    return NULL;
1133
1134 error:
1135    stgFree(buf);
1136    sysErrorBelch(dll_name);
1137
1138    /* LoadLibrary failed; return a ptr to the error msg. */
1139    return "addDLL: could not load DLL";
1140
1141 #  else
1142    barf("addDLL: not implemented on this platform");
1143 #  endif
1144 }
1145
1146 /* -----------------------------------------------------------------------------
1147  * insert a stable symbol in the hash table
1148  */
1149
1150 void
1151 insertStableSymbol(char* obj_name, char* key, StgPtr p)
1152 {
1153   ghciInsertStrHashTable(obj_name, stablehash, key, getStablePtr(p));
1154 }
1155
1156
1157 /* -----------------------------------------------------------------------------
1158  * insert a symbol in the hash table
1159  */
1160 void
1161 insertSymbol(char* obj_name, char* key, void* data)
1162 {
1163   ghciInsertStrHashTable(obj_name, symhash, key, data);
1164 }
1165
1166 /* -----------------------------------------------------------------------------
1167  * lookup a symbol in the hash table
1168  */
1169 void *
1170 lookupSymbol( char *lbl )
1171 {
1172     void *val;
1173     initLinker() ;
1174     ASSERT(symhash != NULL);
1175     val = lookupStrHashTable(symhash, lbl);
1176
1177     if (val == NULL) {
1178 #       if defined(OBJFORMAT_ELF)
1179         return dlsym(dl_prog_handle, lbl);
1180 #       elif defined(OBJFORMAT_MACHO)
1181 #       if HAVE_DLFCN_H
1182         /* On OS X 10.3 and later, we use dlsym instead of the old legacy
1183            interface.
1184
1185            HACK: On OS X, global symbols are prefixed with an underscore.
1186                  However, dlsym wants us to omit the leading underscore from the
1187                  symbol name. For now, we simply strip it off here (and ONLY
1188                  here).
1189         */
1190         ASSERT(lbl[0] == '_');
1191         return dlsym(dl_prog_handle, lbl+1);
1192 #       else
1193         if(NSIsSymbolNameDefined(lbl)) {
1194             NSSymbol symbol = NSLookupAndBindSymbol(lbl);
1195             return NSAddressOfSymbol(symbol);
1196         } else {
1197             return NULL;
1198         }
1199 #       endif /* HAVE_DLFCN_H */
1200 #       elif defined(OBJFORMAT_PEi386)
1201         void* sym;
1202
1203         sym = lookupSymbolInDLLs(lbl);
1204         if (sym != NULL) { return sym; };
1205
1206         // Also try looking up the symbol without the @N suffix.  Some
1207         // DLLs have the suffixes on their symbols, some don't.
1208         zapTrailingAtSign ( lbl );
1209         sym = lookupSymbolInDLLs(lbl);
1210         if (sym != NULL) { return sym; };
1211         return NULL;
1212
1213 #       else
1214         ASSERT(2+2 == 5);
1215         return NULL;
1216 #       endif
1217     } else {
1218         return val;
1219     }
1220 }
1221
1222 /* -----------------------------------------------------------------------------
1223  * Debugging aid: look in GHCi's object symbol tables for symbols
1224  * within DELTA bytes of the specified address, and show their names.
1225  */
1226 #ifdef DEBUG
1227 void ghci_enquire ( char* addr );
1228
1229 void ghci_enquire ( char* addr )
1230 {
1231    int   i;
1232    char* sym;
1233    char* a;
1234    const int DELTA = 64;
1235    ObjectCode* oc;
1236
1237    initLinker();
1238
1239    for (oc = objects; oc; oc = oc->next) {
1240       for (i = 0; i < oc->n_symbols; i++) {
1241          sym = oc->symbols[i];
1242          if (sym == NULL) continue;
1243          a = NULL;
1244          if (a == NULL) {
1245             a = lookupStrHashTable(symhash, sym);
1246          }
1247          if (a == NULL) {
1248              // debugBelch("ghci_enquire: can't find %s\n", sym);
1249          }
1250          else if (addr-DELTA <= a && a <= addr+DELTA) {
1251             debugBelch("%p + %3d  ==  `%s'\n", addr, (int)(a - addr), sym);
1252          }
1253       }
1254    }
1255 }
1256 #endif
1257
1258 #ifdef ia64_HOST_ARCH
1259 static unsigned int PLTSize(void);
1260 #endif
1261
1262 #ifdef USE_MMAP
1263 #define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))
1264
1265 static void *
1266 mmapForLinker (size_t bytes, nat flags, int fd)
1267 {
1268    void *map_addr = NULL;
1269    void *result;
1270    int pagesize, size;
1271    static nat fixed = 0;
1272
1273    pagesize = getpagesize();
1274    size = ROUND_UP(bytes, pagesize);
1275
1276 #if defined(x86_64_HOST_ARCH)
1277 mmap_again:
1278
1279    if (mmap_32bit_base != 0) {
1280        map_addr = mmap_32bit_base;
1281    }
1282 #endif
1283
1284    result = mmap(map_addr, size, PROT_EXEC|PROT_READ|PROT_WRITE,
1285                     MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, 0);
1286
1287    if (result == MAP_FAILED) {
1288        sysErrorBelch("mmap %lu bytes at %p",(lnat)size,map_addr);
1289        errorBelch("Try specifying an address with +RTS -xm<addr> -RTS");
1290        stg_exit(EXIT_FAILURE);
1291    }
1292
1293 #if defined(x86_64_HOST_ARCH)
1294    if (mmap_32bit_base != 0) {
1295        if (result == map_addr) {
1296            mmap_32bit_base = map_addr + size;
1297        } else {
1298            if ((W_)result > 0x80000000) {
1299                // oops, we were given memory over 2Gb
1300 #if defined(freebsd_HOST_OS)
1301                // Some platforms require MAP_FIXED.  This is normally
1302                // a bad idea, because MAP_FIXED will overwrite
1303                // existing mappings.
1304                munmap(result,size);
1305                fixed = MAP_FIXED;
1306                goto mmap_again;
1307 #else
1308                barf("loadObj: failed to mmap() memory below 2Gb; asked for %lu bytes at %p.  Try specifying an address with +RTS -xm<addr> -RTS", size, map_addr, result);
1309 #endif
1310            } else {
1311                // hmm, we were given memory somewhere else, but it's
1312                // still under 2Gb so we can use it.  Next time, ask
1313                // for memory right after the place we just got some
1314                mmap_32bit_base = (void*)result + size;
1315            }
1316        }
1317    } else {
1318        if ((W_)result > 0x80000000) {
1319            // oops, we were given memory over 2Gb
1320            // ... try allocating memory somewhere else?;
1321            debugTrace(DEBUG_linker,"MAP_32BIT didn't work; gave us %lu bytes at 0x%p", bytes, result);
1322            munmap(result, size);
1323
1324            // Set a base address and try again... (guess: 1Gb)
1325            mmap_32bit_base = (void*)0x40000000;
1326            goto mmap_again;
1327        }
1328    }
1329 #endif
1330
1331    return result;
1332 }
1333 #endif // USE_MMAP
1334
1335 /* -----------------------------------------------------------------------------
1336  * Load an obj (populate the global symbol table, but don't resolve yet)
1337  *
1338  * Returns: 1 if ok, 0 on error.
1339  */
1340 HsInt
1341 loadObj( char *path )
1342 {
1343    ObjectCode* oc;
1344    struct stat st;
1345    int r;
1346 #ifdef USE_MMAP
1347    int fd;
1348 #else
1349    FILE *f;
1350 #endif
1351    initLinker();
1352
1353    /* debugBelch("loadObj %s\n", path ); */
1354
1355    /* Check that we haven't already loaded this object.
1356       Ignore requests to load multiple times */
1357    {
1358        ObjectCode *o;
1359        int is_dup = 0;
1360        for (o = objects; o; o = o->next) {
1361           if (0 == strcmp(o->fileName, path)) {
1362              is_dup = 1;
1363              break; /* don't need to search further */
1364           }
1365        }
1366        if (is_dup) {
1367           IF_DEBUG(linker, debugBelch(
1368             "GHCi runtime linker: warning: looks like you're trying to load the\n"
1369             "same object file twice:\n"
1370             "   %s\n"
1371             "GHCi will ignore this, but be warned.\n"
1372             , path));
1373           return 1; /* success */
1374        }
1375    }
1376
1377    oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)");
1378
1379 #  if defined(OBJFORMAT_ELF)
1380    oc->formatName = "ELF";
1381 #  elif defined(OBJFORMAT_PEi386)
1382    oc->formatName = "PEi386";
1383 #  elif defined(OBJFORMAT_MACHO)
1384    oc->formatName = "Mach-O";
1385 #  else
1386    stgFree(oc);
1387    barf("loadObj: not implemented on this platform");
1388 #  endif
1389
1390    r = stat(path, &st);
1391    if (r == -1) { return 0; }
1392
1393    /* sigh, strdup() isn't a POSIX function, so do it the long way */
1394    oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
1395    strcpy(oc->fileName, path);
1396
1397    oc->fileSize          = st.st_size;
1398    oc->symbols           = NULL;
1399    oc->sections          = NULL;
1400    oc->proddables        = NULL;
1401
1402    /* chain it onto the list of objects */
1403    oc->next              = objects;
1404    objects               = oc;
1405
1406 #ifdef USE_MMAP
1407    /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
1408
1409 #if defined(openbsd_HOST_OS)
1410    fd = open(path, O_RDONLY, S_IRUSR);
1411 #else
1412    fd = open(path, O_RDONLY);
1413 #endif
1414    if (fd == -1)
1415       barf("loadObj: can't open `%s'", path);
1416
1417 #ifdef ia64_HOST_ARCH
1418    /* The PLT needs to be right before the object */
1419    {
1420    int pagesize, n;
1421    pagesize = getpagesize();
1422    n = ROUND_UP(PLTSize(), pagesize);
1423    oc->plt = mmap(NULL, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0);
1424    if (oc->plt == MAP_FAILED)
1425       barf("loadObj: can't allocate PLT");
1426
1427    oc->pltIndex = 0;
1428    map_addr = oc->plt + n;
1429
1430    n = ROUND_UP(oc->fileSize, pagesize);
1431    oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE,
1432                     MAP_PRIVATE|TRY_MAP_32BIT, fd, 0);
1433    if (oc->image == MAP_FAILED)
1434       barf("loadObj: can't map `%s'", path);
1435    }
1436 #else
1437    oc->image = mmapForLinker(oc->fileSize, 0, fd);
1438 #endif
1439
1440    close(fd);
1441
1442 #else /* !USE_MMAP */
1443    /* load the image into memory */
1444    f = fopen(path, "rb");
1445    if (!f)
1446        barf("loadObj: can't read `%s'", path);
1447
1448 #   if defined(mingw32_HOST_OS)
1449         // TODO: We would like to use allocateExec here, but allocateExec
1450         //       cannot currently allocate blocks large enough.
1451     oc->image = VirtualAlloc(NULL, oc->fileSize, MEM_RESERVE | MEM_COMMIT,
1452                              PAGE_EXECUTE_READWRITE);
1453 #   elif defined(darwin_HOST_OS)
1454     // In a Mach-O .o file, all sections can and will be misaligned
1455     // if the total size of the headers is not a multiple of the
1456     // desired alignment. This is fine for .o files that only serve
1457     // as input for the static linker, but it's not fine for us,
1458     // as SSE (used by gcc for floating point) and Altivec require
1459     // 16-byte alignment.
1460     // We calculate the correct alignment from the header before
1461     // reading the file, and then we misalign oc->image on purpose so
1462     // that the actual sections end up aligned again.
1463    oc->misalignment = machoGetMisalignment(f);
1464    oc->image = stgMallocBytes(oc->fileSize + oc->misalignment, "loadObj(image)");
1465    oc->image += oc->misalignment;
1466 #  else
1467    oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)");
1468 #  endif
1469
1470    {
1471        int n;
1472        n = fread ( oc->image, 1, oc->fileSize, f );
1473        if (n != oc->fileSize)
1474            barf("loadObj: error whilst reading `%s'", path);
1475    }
1476    fclose(f);
1477 #endif /* USE_MMAP */
1478
1479 #  if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1480    r = ocAllocateSymbolExtras_MachO ( oc );
1481    if (!r) { return r; }
1482 #  elif defined(OBJFORMAT_ELF) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1483    r = ocAllocateSymbolExtras_ELF ( oc );
1484    if (!r) { return r; }
1485 #endif
1486
1487    /* verify the in-memory image */
1488 #  if defined(OBJFORMAT_ELF)
1489    r = ocVerifyImage_ELF ( oc );
1490 #  elif defined(OBJFORMAT_PEi386)
1491    r = ocVerifyImage_PEi386 ( oc );
1492 #  elif defined(OBJFORMAT_MACHO)
1493    r = ocVerifyImage_MachO ( oc );
1494 #  else
1495    barf("loadObj: no verify method");
1496 #  endif
1497    if (!r) { return r; }
1498
1499    /* build the symbol list for this image */
1500 #  if defined(OBJFORMAT_ELF)
1501    r = ocGetNames_ELF ( oc );
1502 #  elif defined(OBJFORMAT_PEi386)
1503    r = ocGetNames_PEi386 ( oc );
1504 #  elif defined(OBJFORMAT_MACHO)
1505    r = ocGetNames_MachO ( oc );
1506 #  else
1507    barf("loadObj: no getNames method");
1508 #  endif
1509    if (!r) { return r; }
1510
1511    /* loaded, but not resolved yet */
1512    oc->status = OBJECT_LOADED;
1513
1514    return 1;
1515 }
1516
1517 /* -----------------------------------------------------------------------------
1518  * resolve all the currently unlinked objects in memory
1519  *
1520  * Returns: 1 if ok, 0 on error.
1521  */
1522 HsInt
1523 resolveObjs( void )
1524 {
1525     ObjectCode *oc;
1526     int r;
1527
1528     initLinker();
1529
1530     for (oc = objects; oc; oc = oc->next) {
1531         if (oc->status != OBJECT_RESOLVED) {
1532 #           if defined(OBJFORMAT_ELF)
1533             r = ocResolve_ELF ( oc );
1534 #           elif defined(OBJFORMAT_PEi386)
1535             r = ocResolve_PEi386 ( oc );
1536 #           elif defined(OBJFORMAT_MACHO)
1537             r = ocResolve_MachO ( oc );
1538 #           else
1539             barf("resolveObjs: not implemented on this platform");
1540 #           endif
1541             if (!r) { return r; }
1542             oc->status = OBJECT_RESOLVED;
1543         }
1544     }
1545     return 1;
1546 }
1547
1548 /* -----------------------------------------------------------------------------
1549  * delete an object from the pool
1550  */
1551 HsInt
1552 unloadObj( char *path )
1553 {
1554     ObjectCode *oc, *prev;
1555
1556     ASSERT(symhash != NULL);
1557     ASSERT(objects != NULL);
1558
1559     initLinker();
1560
1561     prev = NULL;
1562     for (oc = objects; oc; prev = oc, oc = oc->next) {
1563         if (!strcmp(oc->fileName,path)) {
1564
1565             /* Remove all the mappings for the symbols within this
1566              * object..
1567              */
1568             {
1569                 int i;
1570                 for (i = 0; i < oc->n_symbols; i++) {
1571                    if (oc->symbols[i] != NULL) {
1572                        removeStrHashTable(symhash, oc->symbols[i], NULL);
1573                    }
1574                 }
1575             }
1576
1577             if (prev == NULL) {
1578                 objects = oc->next;
1579             } else {
1580                 prev->next = oc->next;
1581             }
1582
1583             // We're going to leave this in place, in case there are
1584             // any pointers from the heap into it:
1585                 // #ifdef mingw32_HOST_OS
1586                 //  VirtualFree(oc->image);
1587                 // #else
1588             //  stgFree(oc->image);
1589             // #endif
1590             stgFree(oc->fileName);
1591             stgFree(oc->symbols);
1592             stgFree(oc->sections);
1593             stgFree(oc);
1594             return 1;
1595         }
1596     }
1597
1598     errorBelch("unloadObj: can't find `%s' to unload", path);
1599     return 0;
1600 }
1601
1602 /* -----------------------------------------------------------------------------
1603  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
1604  * which may be prodded during relocation, and abort if we try and write
1605  * outside any of these.
1606  */
1607 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
1608 {
1609    ProddableBlock* pb
1610       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
1611    /* debugBelch("aPB %p %p %d\n", oc, start, size); */
1612    ASSERT(size > 0);
1613    pb->start      = start;
1614    pb->size       = size;
1615    pb->next       = oc->proddables;
1616    oc->proddables = pb;
1617 }
1618
1619 static void checkProddableBlock ( ObjectCode* oc, void* addr )
1620 {
1621    ProddableBlock* pb;
1622    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
1623       char* s = (char*)(pb->start);
1624       char* e = s + pb->size - 1;
1625       char* a = (char*)addr;
1626       /* Assumes that the biggest fixup involves a 4-byte write.  This
1627          probably needs to be changed to 8 (ie, +7) on 64-bit
1628          plats. */
1629       if (a >= s && (a+3) <= e) return;
1630    }
1631    barf("checkProddableBlock: invalid fixup in runtime linker");
1632 }
1633
1634 /* -----------------------------------------------------------------------------
1635  * Section management.
1636  */
1637 static void addSection ( ObjectCode* oc, SectionKind kind,
1638                          void* start, void* end )
1639 {
1640    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
1641    s->start     = start;
1642    s->end       = end;
1643    s->kind      = kind;
1644    s->next      = oc->sections;
1645    oc->sections = s;
1646    /*
1647    debugBelch("addSection: %p-%p (size %d), kind %d\n",
1648                    start, ((char*)end)-1, end - start + 1, kind );
1649    */
1650 }
1651
1652
1653 /* --------------------------------------------------------------------------
1654  * Symbol Extras.
1655  * This is about allocating a small chunk of memory for every symbol in the
1656  * object file. We make sure that the SymboLExtras are always "in range" of
1657  * limited-range PC-relative instructions on various platforms by allocating
1658  * them right next to the object code itself.
1659  */
1660
1661 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
1662
1663 /*
1664   ocAllocateSymbolExtras
1665
1666   Allocate additional space at the end of the object file image to make room
1667   for jump islands (powerpc, x86_64) and GOT entries (x86_64).
1668
1669   PowerPC relative branch instructions have a 24 bit displacement field.
1670   As PPC code is always 4-byte-aligned, this yields a +-32MB range.
1671   If a particular imported symbol is outside this range, we have to redirect
1672   the jump to a short piece of new code that just loads the 32bit absolute
1673   address and jumps there.
1674   On x86_64, PC-relative jumps and PC-relative accesses to the GOT are limited
1675   to 32 bits (+-2GB).
1676
1677   This function just allocates space for one SymbolExtra for every
1678   undefined symbol in the object file. The code for the jump islands is
1679   filled in by makeSymbolExtra below.
1680 */
1681
1682 static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first )
1683 {
1684 #ifdef USE_MMAP
1685   int pagesize, n, m;
1686 #endif
1687   int aligned;
1688 #ifndef USE_MMAP
1689   int misalignment = 0;
1690 #ifdef darwin_HOST_OS
1691   misalignment = oc->misalignment;
1692 #endif
1693 #endif
1694
1695   if( count > 0 )
1696   {
1697     // round up to the nearest 4
1698     aligned = (oc->fileSize + 3) & ~3;
1699
1700 #ifdef USE_MMAP
1701     pagesize = getpagesize();
1702     n = ROUND_UP( oc->fileSize, pagesize );
1703     m = ROUND_UP( aligned + sizeof (SymbolExtra) * count, pagesize );
1704
1705     /* we try to use spare space at the end of the last page of the
1706      * image for the jump islands, but if there isn't enough space
1707      * then we have to map some (anonymously, remembering MAP_32BIT).
1708      */
1709     if( m > n ) // we need to allocate more pages
1710     {
1711         oc->symbol_extras = mmapForLinker(sizeof(SymbolExtra) * count,
1712                                           MAP_ANONYMOUS, -1);
1713     }
1714     else
1715     {
1716         oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
1717     }
1718 #else
1719     oc->image -= misalignment;
1720     oc->image = stgReallocBytes( oc->image,
1721                                  misalignment +
1722                                  aligned + sizeof (SymbolExtra) * count,
1723                                  "ocAllocateSymbolExtras" );
1724     oc->image += misalignment;
1725
1726     oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
1727 #endif /* USE_MMAP */
1728
1729     memset( oc->symbol_extras, 0, sizeof (SymbolExtra) * count );
1730   }
1731   else
1732     oc->symbol_extras = NULL;
1733
1734   oc->first_symbol_extra = first;
1735   oc->n_symbol_extras = count;
1736
1737   return 1;
1738 }
1739
1740 static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
1741                                      unsigned long symbolNumber,
1742                                      unsigned long target )
1743 {
1744   SymbolExtra *extra;
1745
1746   ASSERT( symbolNumber >= oc->first_symbol_extra
1747         && symbolNumber - oc->first_symbol_extra < oc->n_symbol_extras);
1748
1749   extra = &oc->symbol_extras[symbolNumber - oc->first_symbol_extra];
1750
1751 #ifdef powerpc_HOST_ARCH
1752   // lis r12, hi16(target)
1753   extra->jumpIsland.lis_r12     = 0x3d80;
1754   extra->jumpIsland.hi_addr     = target >> 16;
1755
1756   // ori r12, r12, lo16(target)
1757   extra->jumpIsland.ori_r12_r12 = 0x618c;
1758   extra->jumpIsland.lo_addr     = target & 0xffff;
1759
1760   // mtctr r12
1761   extra->jumpIsland.mtctr_r12   = 0x7d8903a6;
1762
1763   // bctr
1764   extra->jumpIsland.bctr        = 0x4e800420;
1765 #endif
1766 #ifdef x86_64_HOST_ARCH
1767         // jmp *-14(%rip)
1768   static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
1769   extra->addr = target;
1770   memcpy(extra->jumpIsland, jmp, 6);
1771 #endif
1772
1773   return extra;
1774 }
1775
1776 #endif
1777
1778 /* --------------------------------------------------------------------------
1779  * PowerPC specifics (instruction cache flushing)
1780  * ------------------------------------------------------------------------*/
1781
1782 #ifdef powerpc_TARGET_ARCH
1783 /*
1784    ocFlushInstructionCache
1785
1786    Flush the data & instruction caches.
1787    Because the PPC has split data/instruction caches, we have to
1788    do that whenever we modify code at runtime.
1789  */
1790
1791 static void ocFlushInstructionCache( ObjectCode *oc )
1792 {
1793     int n = (oc->fileSize + sizeof( SymbolExtra ) * oc->n_symbol_extras + 3) / 4;
1794     unsigned long *p = (unsigned long *) oc->image;
1795
1796     while( n-- )
1797     {
1798         __asm__ volatile ( "dcbf 0,%0\n\t"
1799                            "sync\n\t"
1800                            "icbi 0,%0"
1801                            :
1802                            : "r" (p)
1803                          );
1804         p++;
1805     }
1806     __asm__ volatile ( "sync\n\t"
1807                        "isync"
1808                      );
1809 }
1810 #endif
1811
1812 /* --------------------------------------------------------------------------
1813  * PEi386 specifics (Win32 targets)
1814  * ------------------------------------------------------------------------*/
1815
1816 /* The information for this linker comes from
1817       Microsoft Portable Executable
1818       and Common Object File Format Specification
1819       revision 5.1 January 1998
1820    which SimonM says comes from the MS Developer Network CDs.
1821
1822    It can be found there (on older CDs), but can also be found
1823    online at:
1824
1825       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
1826
1827    (this is Rev 6.0 from February 1999).
1828
1829    Things move, so if that fails, try searching for it via
1830
1831       http://www.google.com/search?q=PE+COFF+specification
1832
1833    The ultimate reference for the PE format is the Winnt.h
1834    header file that comes with the Platform SDKs; as always,
1835    implementations will drift wrt their documentation.
1836
1837    A good background article on the PE format is Matt Pietrek's
1838    March 1994 article in Microsoft System Journal (MSJ)
1839    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
1840    Win32 Portable Executable File Format." The info in there
1841    has recently been updated in a two part article in
1842    MSDN magazine, issues Feb and March 2002,
1843    "Inside Windows: An In-Depth Look into the Win32 Portable
1844    Executable File Format"
1845
1846    John Levine's book "Linkers and Loaders" contains useful
1847    info on PE too.
1848 */
1849
1850
1851 #if defined(OBJFORMAT_PEi386)
1852
1853
1854
1855 typedef unsigned char  UChar;
1856 typedef unsigned short UInt16;
1857 typedef unsigned int   UInt32;
1858 typedef          int   Int32;
1859
1860
1861 typedef
1862    struct {
1863       UInt16 Machine;
1864       UInt16 NumberOfSections;
1865       UInt32 TimeDateStamp;
1866       UInt32 PointerToSymbolTable;
1867       UInt32 NumberOfSymbols;
1868       UInt16 SizeOfOptionalHeader;
1869       UInt16 Characteristics;
1870    }
1871    COFF_header;
1872
1873 #define sizeof_COFF_header 20
1874
1875
1876 typedef
1877    struct {
1878       UChar  Name[8];
1879       UInt32 VirtualSize;
1880       UInt32 VirtualAddress;
1881       UInt32 SizeOfRawData;
1882       UInt32 PointerToRawData;
1883       UInt32 PointerToRelocations;
1884       UInt32 PointerToLinenumbers;
1885       UInt16 NumberOfRelocations;
1886       UInt16 NumberOfLineNumbers;
1887       UInt32 Characteristics;
1888    }
1889    COFF_section;
1890
1891 #define sizeof_COFF_section 40
1892
1893
1894 typedef
1895    struct {
1896       UChar  Name[8];
1897       UInt32 Value;
1898       UInt16 SectionNumber;
1899       UInt16 Type;
1900       UChar  StorageClass;
1901       UChar  NumberOfAuxSymbols;
1902    }
1903    COFF_symbol;
1904
1905 #define sizeof_COFF_symbol 18
1906
1907
1908 typedef
1909    struct {
1910       UInt32 VirtualAddress;
1911       UInt32 SymbolTableIndex;
1912       UInt16 Type;
1913    }
1914    COFF_reloc;
1915
1916 #define sizeof_COFF_reloc 10
1917
1918
1919 /* From PE spec doc, section 3.3.2 */
1920 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
1921    windows.h -- for the same purpose, but I want to know what I'm
1922    getting, here. */
1923 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
1924 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
1925 #define MYIMAGE_FILE_DLL                 0x2000
1926 #define MYIMAGE_FILE_SYSTEM              0x1000
1927 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
1928 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
1929 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
1930
1931 /* From PE spec doc, section 5.4.2 and 5.4.4 */
1932 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
1933 #define MYIMAGE_SYM_CLASS_STATIC         3
1934 #define MYIMAGE_SYM_UNDEFINED            0
1935
1936 /* From PE spec doc, section 4.1 */
1937 #define MYIMAGE_SCN_CNT_CODE             0x00000020
1938 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
1939 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
1940
1941 /* From PE spec doc, section 5.2.1 */
1942 #define MYIMAGE_REL_I386_DIR32           0x0006
1943 #define MYIMAGE_REL_I386_REL32           0x0014
1944
1945
1946 /* We use myindex to calculate array addresses, rather than
1947    simply doing the normal subscript thing.  That's because
1948    some of the above structs have sizes which are not
1949    a whole number of words.  GCC rounds their sizes up to a
1950    whole number of words, which means that the address calcs
1951    arising from using normal C indexing or pointer arithmetic
1952    are just plain wrong.  Sigh.
1953 */
1954 static UChar *
1955 myindex ( int scale, void* base, int index )
1956 {
1957    return
1958       ((UChar*)base) + scale * index;
1959 }
1960
1961
1962 static void
1963 printName ( UChar* name, UChar* strtab )
1964 {
1965    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1966       UInt32 strtab_offset = * (UInt32*)(name+4);
1967       debugBelch("%s", strtab + strtab_offset );
1968    } else {
1969       int i;
1970       for (i = 0; i < 8; i++) {
1971          if (name[i] == 0) break;
1972          debugBelch("%c", name[i] );
1973       }
1974    }
1975 }
1976
1977
1978 static void
1979 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
1980 {
1981    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1982       UInt32 strtab_offset = * (UInt32*)(name+4);
1983       strncpy ( dst, strtab+strtab_offset, dstSize );
1984       dst[dstSize-1] = 0;
1985    } else {
1986       int i = 0;
1987       while (1) {
1988          if (i >= 8) break;
1989          if (name[i] == 0) break;
1990          dst[i] = name[i];
1991          i++;
1992       }
1993       dst[i] = 0;
1994    }
1995 }
1996
1997
1998 static UChar *
1999 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
2000 {
2001    UChar* newstr;
2002    /* If the string is longer than 8 bytes, look in the
2003       string table for it -- this will be correctly zero terminated.
2004    */
2005    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2006       UInt32 strtab_offset = * (UInt32*)(name+4);
2007       return ((UChar*)strtab) + strtab_offset;
2008    }
2009    /* Otherwise, if shorter than 8 bytes, return the original,
2010       which by defn is correctly terminated.
2011    */
2012    if (name[7]==0) return name;
2013    /* The annoying case: 8 bytes.  Copy into a temporary
2014       (which is never freed ...)
2015    */
2016    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
2017    ASSERT(newstr);
2018    strncpy(newstr,name,8);
2019    newstr[8] = 0;
2020    return newstr;
2021 }
2022
2023
2024 /* Just compares the short names (first 8 chars) */
2025 static COFF_section *
2026 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
2027 {
2028    int i;
2029    COFF_header* hdr
2030       = (COFF_header*)(oc->image);
2031    COFF_section* sectab
2032       = (COFF_section*) (
2033            ((UChar*)(oc->image))
2034            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2035         );
2036    for (i = 0; i < hdr->NumberOfSections; i++) {
2037       UChar* n1;
2038       UChar* n2;
2039       COFF_section* section_i
2040          = (COFF_section*)
2041            myindex ( sizeof_COFF_section, sectab, i );
2042       n1 = (UChar*) &(section_i->Name);
2043       n2 = name;
2044       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
2045           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
2046           n1[6]==n2[6] && n1[7]==n2[7])
2047          return section_i;
2048    }
2049
2050    return NULL;
2051 }
2052
2053
2054 static void
2055 zapTrailingAtSign ( UChar* sym )
2056 {
2057 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
2058    int i, j;
2059    if (sym[0] == 0) return;
2060    i = 0;
2061    while (sym[i] != 0) i++;
2062    i--;
2063    j = i;
2064    while (j > 0 && my_isdigit(sym[j])) j--;
2065    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
2066 #  undef my_isdigit
2067 }
2068
2069 static void *
2070 lookupSymbolInDLLs ( UChar *lbl )
2071 {
2072     OpenedDLL* o_dll;
2073     void *sym;
2074
2075     for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
2076         /* debugBelch("look in %s for %s\n", o_dll->name, lbl); */
2077
2078         if (lbl[0] == '_') {
2079             /* HACK: if the name has an initial underscore, try stripping
2080                it off & look that up first. I've yet to verify whether there's
2081                a Rule that governs whether an initial '_' *should always* be
2082                stripped off when mapping from import lib name to the DLL name.
2083             */
2084             sym = GetProcAddress(o_dll->instance, (lbl+1));
2085             if (sym != NULL) {
2086                 /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
2087                 return sym;
2088             }
2089         }
2090         sym = GetProcAddress(o_dll->instance, lbl);
2091         if (sym != NULL) {
2092             /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
2093             return sym;
2094            }
2095     }
2096     return NULL;
2097 }
2098
2099
2100 static int
2101 ocVerifyImage_PEi386 ( ObjectCode* oc )
2102 {
2103    int i;
2104    UInt32 j, noRelocs;
2105    COFF_header*  hdr;
2106    COFF_section* sectab;
2107    COFF_symbol*  symtab;
2108    UChar*        strtab;
2109    /* debugBelch("\nLOADING %s\n", oc->fileName); */
2110    hdr = (COFF_header*)(oc->image);
2111    sectab = (COFF_section*) (
2112                ((UChar*)(oc->image))
2113                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2114             );
2115    symtab = (COFF_symbol*) (
2116                ((UChar*)(oc->image))
2117                + hdr->PointerToSymbolTable
2118             );
2119    strtab = ((UChar*)symtab)
2120             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2121
2122    if (hdr->Machine != 0x14c) {
2123       errorBelch("%s: Not x86 PEi386", oc->fileName);
2124       return 0;
2125    }
2126    if (hdr->SizeOfOptionalHeader != 0) {
2127       errorBelch("%s: PEi386 with nonempty optional header", oc->fileName);
2128       return 0;
2129    }
2130    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
2131         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
2132         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
2133         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
2134       errorBelch("%s: Not a PEi386 object file", oc->fileName);
2135       return 0;
2136    }
2137    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
2138         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
2139       errorBelch("%s: Invalid PEi386 word size or endiannness: %d",
2140                  oc->fileName,
2141                  (int)(hdr->Characteristics));
2142       return 0;
2143    }
2144    /* If the string table size is way crazy, this might indicate that
2145       there are more than 64k relocations, despite claims to the
2146       contrary.  Hence this test. */
2147    /* debugBelch("strtab size %d\n", * (UInt32*)strtab); */
2148 #if 0
2149    if ( (*(UInt32*)strtab) > 600000 ) {
2150       /* Note that 600k has no special significance other than being
2151          big enough to handle the almost-2MB-sized lumps that
2152          constitute HSwin32*.o. */
2153       debugBelch("PEi386 object has suspiciously large string table; > 64k relocs?");
2154       return 0;
2155    }
2156 #endif
2157
2158    /* No further verification after this point; only debug printing. */
2159    i = 0;
2160    IF_DEBUG(linker, i=1);
2161    if (i == 0) return 1;
2162
2163    debugBelch( "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
2164    debugBelch( "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
2165    debugBelch( "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
2166
2167    debugBelch("\n" );
2168    debugBelch( "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
2169    debugBelch( "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
2170    debugBelch( "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
2171    debugBelch( "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
2172    debugBelch( "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
2173    debugBelch( "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
2174    debugBelch( "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
2175
2176    /* Print the section table. */
2177    debugBelch("\n" );
2178    for (i = 0; i < hdr->NumberOfSections; i++) {
2179       COFF_reloc* reltab;
2180       COFF_section* sectab_i
2181          = (COFF_section*)
2182            myindex ( sizeof_COFF_section, sectab, i );
2183       debugBelch(
2184                 "\n"
2185                 "section %d\n"
2186                 "     name `",
2187                 i
2188               );
2189       printName ( sectab_i->Name, strtab );
2190       debugBelch(
2191                 "'\n"
2192                 "    vsize %d\n"
2193                 "    vaddr %d\n"
2194                 "  data sz %d\n"
2195                 " data off %d\n"
2196                 "  num rel %d\n"
2197                 "  off rel %d\n"
2198                 "  ptr raw 0x%x\n",
2199                 sectab_i->VirtualSize,
2200                 sectab_i->VirtualAddress,
2201                 sectab_i->SizeOfRawData,
2202                 sectab_i->PointerToRawData,
2203                 sectab_i->NumberOfRelocations,
2204                 sectab_i->PointerToRelocations,
2205                 sectab_i->PointerToRawData
2206               );
2207       reltab = (COFF_reloc*) (
2208                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2209                );
2210
2211       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2212         /* If the relocation field (a short) has overflowed, the
2213          * real count can be found in the first reloc entry.
2214          *
2215          * See Section 4.1 (last para) of the PE spec (rev6.0).
2216          */
2217         COFF_reloc* rel = (COFF_reloc*)
2218                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2219         noRelocs = rel->VirtualAddress;
2220         j = 1;
2221       } else {
2222         noRelocs = sectab_i->NumberOfRelocations;
2223         j = 0;
2224       }
2225
2226       for (; j < noRelocs; j++) {
2227          COFF_symbol* sym;
2228          COFF_reloc* rel = (COFF_reloc*)
2229                            myindex ( sizeof_COFF_reloc, reltab, j );
2230          debugBelch(
2231                    "        type 0x%-4x   vaddr 0x%-8x   name `",
2232                    (UInt32)rel->Type,
2233                    rel->VirtualAddress );
2234          sym = (COFF_symbol*)
2235                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
2236          /* Hmm..mysterious looking offset - what's it for? SOF */
2237          printName ( sym->Name, strtab -10 );
2238          debugBelch("'\n" );
2239       }
2240
2241       debugBelch("\n" );
2242    }
2243    debugBelch("\n" );
2244    debugBelch("string table has size 0x%x\n", * (UInt32*)strtab );
2245    debugBelch("---START of string table---\n");
2246    for (i = 4; i < *(Int32*)strtab; i++) {
2247       if (strtab[i] == 0)
2248          debugBelch("\n"); else
2249          debugBelch("%c", strtab[i] );
2250    }
2251    debugBelch("--- END  of string table---\n");
2252
2253    debugBelch("\n" );
2254    i = 0;
2255    while (1) {
2256       COFF_symbol* symtab_i;
2257       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2258       symtab_i = (COFF_symbol*)
2259                  myindex ( sizeof_COFF_symbol, symtab, i );
2260       debugBelch(
2261                 "symbol %d\n"
2262                 "     name `",
2263                 i
2264               );
2265       printName ( symtab_i->Name, strtab );
2266       debugBelch(
2267                 "'\n"
2268                 "    value 0x%x\n"
2269                 "   1+sec# %d\n"
2270                 "     type 0x%x\n"
2271                 "   sclass 0x%x\n"
2272                 "     nAux %d\n",
2273                 symtab_i->Value,
2274                 (Int32)(symtab_i->SectionNumber),
2275                 (UInt32)symtab_i->Type,
2276                 (UInt32)symtab_i->StorageClass,
2277                 (UInt32)symtab_i->NumberOfAuxSymbols
2278               );
2279       i += symtab_i->NumberOfAuxSymbols;
2280       i++;
2281    }
2282
2283    debugBelch("\n" );
2284    return 1;
2285 }
2286
2287
2288 static int
2289 ocGetNames_PEi386 ( ObjectCode* oc )
2290 {
2291    COFF_header*  hdr;
2292    COFF_section* sectab;
2293    COFF_symbol*  symtab;
2294    UChar*        strtab;
2295
2296    UChar* sname;
2297    void*  addr;
2298    int    i;
2299
2300    hdr = (COFF_header*)(oc->image);
2301    sectab = (COFF_section*) (
2302                ((UChar*)(oc->image))
2303                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2304             );
2305    symtab = (COFF_symbol*) (
2306                ((UChar*)(oc->image))
2307                + hdr->PointerToSymbolTable
2308             );
2309    strtab = ((UChar*)(oc->image))
2310             + hdr->PointerToSymbolTable
2311             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2312
2313    /* Allocate space for any (local, anonymous) .bss sections. */
2314
2315    for (i = 0; i < hdr->NumberOfSections; i++) {
2316       UInt32 bss_sz;
2317       UChar* zspace;
2318       COFF_section* sectab_i
2319          = (COFF_section*)
2320            myindex ( sizeof_COFF_section, sectab, i );
2321       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
2322       /* sof 10/05: the PE spec text isn't too clear regarding what
2323        * the SizeOfRawData field is supposed to hold for object
2324        * file sections containing just uninitialized data -- for executables,
2325        * it is supposed to be zero; unclear what it's supposed to be
2326        * for object files. However, VirtualSize is guaranteed to be
2327        * zero for object files, which definitely suggests that SizeOfRawData
2328        * will be non-zero (where else would the size of this .bss section be
2329        * stored?) Looking at the COFF_section info for incoming object files,
2330        * this certainly appears to be the case.
2331        *
2332        * => I suspect we've been incorrectly handling .bss sections in (relocatable)
2333        * object files up until now. This turned out to bite us with ghc-6.4.1's use
2334        * of gcc-3.4.x, which has started to emit initially-zeroed-out local 'static'
2335        * variable decls into to the .bss section. (The specific function in Q which
2336        * triggered this is libraries/base/cbits/dirUtils.c:__hscore_getFolderPath())
2337        */
2338       if (sectab_i->VirtualSize == 0 && sectab_i->SizeOfRawData == 0) continue;
2339       /* This is a non-empty .bss section.  Allocate zeroed space for
2340          it, and set its PointerToRawData field such that oc->image +
2341          PointerToRawData == addr_of_zeroed_space.  */
2342       bss_sz = sectab_i->VirtualSize;
2343       if ( bss_sz < sectab_i->SizeOfRawData) { bss_sz = sectab_i->SizeOfRawData; }
2344       zspace = stgCallocBytes(1, bss_sz, "ocGetNames_PEi386(anonymous bss)");
2345       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
2346       addProddableBlock(oc, zspace, bss_sz);
2347       /* debugBelch("BSS anon section at 0x%x\n", zspace); */
2348    }
2349
2350    /* Copy section information into the ObjectCode. */
2351
2352    for (i = 0; i < hdr->NumberOfSections; i++) {
2353       UChar* start;
2354       UChar* end;
2355       UInt32 sz;
2356
2357       SectionKind kind
2358          = SECTIONKIND_OTHER;
2359       COFF_section* sectab_i
2360          = (COFF_section*)
2361            myindex ( sizeof_COFF_section, sectab, i );
2362       IF_DEBUG(linker, debugBelch("section name = %s\n", sectab_i->Name ));
2363
2364 #     if 0
2365       /* I'm sure this is the Right Way to do it.  However, the
2366          alternative of testing the sectab_i->Name field seems to
2367          work ok with Cygwin.
2368       */
2369       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
2370           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
2371          kind = SECTIONKIND_CODE_OR_RODATA;
2372 #     endif
2373
2374       if (0==strcmp(".text",sectab_i->Name) ||
2375           0==strcmp(".rdata",sectab_i->Name)||
2376           0==strcmp(".rodata",sectab_i->Name))
2377          kind = SECTIONKIND_CODE_OR_RODATA;
2378       if (0==strcmp(".data",sectab_i->Name) ||
2379           0==strcmp(".bss",sectab_i->Name))
2380          kind = SECTIONKIND_RWDATA;
2381
2382       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
2383       sz = sectab_i->SizeOfRawData;
2384       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
2385
2386       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
2387       end   = start + sz - 1;
2388
2389       if (kind == SECTIONKIND_OTHER
2390           /* Ignore sections called which contain stabs debugging
2391              information. */
2392           && 0 != strcmp(".stab", sectab_i->Name)
2393           && 0 != strcmp(".stabstr", sectab_i->Name)
2394           /* ignore constructor section for now */
2395           && 0 != strcmp(".ctors", sectab_i->Name)
2396           /* ignore section generated from .ident */
2397           && 0!= strcmp("/4", sectab_i->Name)
2398           /* ignore unknown section that appeared in gcc 3.4.5(?) */
2399           && 0!= strcmp(".reloc", sectab_i->Name)
2400          ) {
2401          errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", sectab_i->Name, oc->fileName);
2402          return 0;
2403       }
2404
2405       if (kind != SECTIONKIND_OTHER && end >= start) {
2406          addSection(oc, kind, start, end);
2407          addProddableBlock(oc, start, end - start + 1);
2408       }
2409    }
2410
2411    /* Copy exported symbols into the ObjectCode. */
2412
2413    oc->n_symbols = hdr->NumberOfSymbols;
2414    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
2415                                   "ocGetNames_PEi386(oc->symbols)");
2416    /* Call me paranoid; I don't care. */
2417    for (i = 0; i < oc->n_symbols; i++)
2418       oc->symbols[i] = NULL;
2419
2420    i = 0;
2421    while (1) {
2422       COFF_symbol* symtab_i;
2423       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2424       symtab_i = (COFF_symbol*)
2425                  myindex ( sizeof_COFF_symbol, symtab, i );
2426
2427       addr  = NULL;
2428
2429       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
2430           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
2431          /* This symbol is global and defined, viz, exported */
2432          /* for MYIMAGE_SYMCLASS_EXTERNAL
2433                 && !MYIMAGE_SYM_UNDEFINED,
2434             the address of the symbol is:
2435                 address of relevant section + offset in section
2436          */
2437          COFF_section* sectabent
2438             = (COFF_section*) myindex ( sizeof_COFF_section,
2439                                         sectab,
2440                                         symtab_i->SectionNumber-1 );
2441          addr = ((UChar*)(oc->image))
2442                 + (sectabent->PointerToRawData
2443                    + symtab_i->Value);
2444       }
2445       else
2446       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
2447           && symtab_i->Value > 0) {
2448          /* This symbol isn't in any section at all, ie, global bss.
2449             Allocate zeroed space for it. */
2450          addr = stgCallocBytes(1, symtab_i->Value,
2451                                "ocGetNames_PEi386(non-anonymous bss)");
2452          addSection(oc, SECTIONKIND_RWDATA, addr,
2453                         ((UChar*)addr) + symtab_i->Value - 1);
2454          addProddableBlock(oc, addr, symtab_i->Value);
2455          /* debugBelch("BSS      section at 0x%x\n", addr); */
2456       }
2457
2458       if (addr != NULL ) {
2459          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
2460          /* debugBelch("addSymbol %p `%s \n", addr,sname);  */
2461          IF_DEBUG(linker, debugBelch("addSymbol %p `%s'\n", addr,sname);)
2462          ASSERT(i >= 0 && i < oc->n_symbols);
2463          /* cstring_from_COFF_symbol_name always succeeds. */
2464          oc->symbols[i] = sname;
2465          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
2466       } else {
2467 #        if 0
2468          debugBelch(
2469                    "IGNORING symbol %d\n"
2470                    "     name `",
2471                    i
2472                  );
2473          printName ( symtab_i->Name, strtab );
2474          debugBelch(
2475                    "'\n"
2476                    "    value 0x%x\n"
2477                    "   1+sec# %d\n"
2478                    "     type 0x%x\n"
2479                    "   sclass 0x%x\n"
2480                    "     nAux %d\n",
2481                    symtab_i->Value,
2482                    (Int32)(symtab_i->SectionNumber),
2483                    (UInt32)symtab_i->Type,
2484                    (UInt32)symtab_i->StorageClass,
2485                    (UInt32)symtab_i->NumberOfAuxSymbols
2486                  );
2487 #        endif
2488       }
2489
2490       i += symtab_i->NumberOfAuxSymbols;
2491       i++;
2492    }
2493
2494    return 1;
2495 }
2496
2497
2498 static int
2499 ocResolve_PEi386 ( ObjectCode* oc )
2500 {
2501    COFF_header*  hdr;
2502    COFF_section* sectab;
2503    COFF_symbol*  symtab;
2504    UChar*        strtab;
2505
2506    UInt32        A;
2507    UInt32        S;
2508    UInt32*       pP;
2509
2510    int i;
2511    UInt32 j, noRelocs;
2512
2513    /* ToDo: should be variable-sized?  But is at least safe in the
2514       sense of buffer-overrun-proof. */
2515    char symbol[1000];
2516    /* debugBelch("resolving for %s\n", oc->fileName); */
2517
2518    hdr = (COFF_header*)(oc->image);
2519    sectab = (COFF_section*) (
2520                ((UChar*)(oc->image))
2521                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2522             );
2523    symtab = (COFF_symbol*) (
2524                ((UChar*)(oc->image))
2525                + hdr->PointerToSymbolTable
2526             );
2527    strtab = ((UChar*)(oc->image))
2528             + hdr->PointerToSymbolTable
2529             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2530
2531    for (i = 0; i < hdr->NumberOfSections; i++) {
2532       COFF_section* sectab_i
2533          = (COFF_section*)
2534            myindex ( sizeof_COFF_section, sectab, i );
2535       COFF_reloc* reltab
2536          = (COFF_reloc*) (
2537               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2538            );
2539
2540       /* Ignore sections called which contain stabs debugging
2541          information. */
2542       if (0 == strcmp(".stab", sectab_i->Name)
2543           || 0 == strcmp(".stabstr", sectab_i->Name)
2544           || 0 == strcmp(".ctors", sectab_i->Name))
2545          continue;
2546
2547       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2548         /* If the relocation field (a short) has overflowed, the
2549          * real count can be found in the first reloc entry.
2550          *
2551          * See Section 4.1 (last para) of the PE spec (rev6.0).
2552          *
2553          * Nov2003 update: the GNU linker still doesn't correctly
2554          * handle the generation of relocatable object files with
2555          * overflown relocations. Hence the output to warn of potential
2556          * troubles.
2557          */
2558         COFF_reloc* rel = (COFF_reloc*)
2559                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2560         noRelocs = rel->VirtualAddress;
2561
2562         /* 10/05: we now assume (and check for) a GNU ld that is capable
2563          * of handling object files with (>2^16) of relocs.
2564          */
2565 #if 0
2566         debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
2567                    noRelocs);
2568 #endif
2569         j = 1;
2570       } else {
2571         noRelocs = sectab_i->NumberOfRelocations;
2572         j = 0;
2573       }
2574
2575
2576       for (; j < noRelocs; j++) {
2577          COFF_symbol* sym;
2578          COFF_reloc* reltab_j
2579             = (COFF_reloc*)
2580               myindex ( sizeof_COFF_reloc, reltab, j );
2581
2582          /* the location to patch */
2583          pP = (UInt32*)(
2584                  ((UChar*)(oc->image))
2585                  + (sectab_i->PointerToRawData
2586                     + reltab_j->VirtualAddress
2587                     - sectab_i->VirtualAddress )
2588               );
2589          /* the existing contents of pP */
2590          A = *pP;
2591          /* the symbol to connect to */
2592          sym = (COFF_symbol*)
2593                myindex ( sizeof_COFF_symbol,
2594                          symtab, reltab_j->SymbolTableIndex );
2595          IF_DEBUG(linker,
2596                   debugBelch(
2597                             "reloc sec %2d num %3d:  type 0x%-4x   "
2598                             "vaddr 0x%-8x   name `",
2599                             i, j,
2600                             (UInt32)reltab_j->Type,
2601                             reltab_j->VirtualAddress );
2602                             printName ( sym->Name, strtab );
2603                             debugBelch("'\n" ));
2604
2605          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
2606             COFF_section* section_sym
2607                = findPEi386SectionCalled ( oc, sym->Name );
2608             if (!section_sym) {
2609                errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
2610                return 0;
2611             }
2612             S = ((UInt32)(oc->image))
2613                 + (section_sym->PointerToRawData
2614                    + sym->Value);
2615          } else {
2616             copyName ( sym->Name, strtab, symbol, 1000-1 );
2617             S = (UInt32) lookupSymbol( symbol );
2618             if ((void*)S != NULL) goto foundit;
2619             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
2620             return 0;
2621            foundit:;
2622          }
2623          checkProddableBlock(oc, pP);
2624          switch (reltab_j->Type) {
2625             case MYIMAGE_REL_I386_DIR32:
2626                *pP = A + S;
2627                break;
2628             case MYIMAGE_REL_I386_REL32:
2629                /* Tricky.  We have to insert a displacement at
2630                   pP which, when added to the PC for the _next_
2631                   insn, gives the address of the target (S).
2632                   Problem is to know the address of the next insn
2633                   when we only know pP.  We assume that this
2634                   literal field is always the last in the insn,
2635                   so that the address of the next insn is pP+4
2636                   -- hence the constant 4.
2637                   Also I don't know if A should be added, but so
2638                   far it has always been zero.
2639
2640                   SOF 05/2005: 'A' (old contents of *pP) have been observed
2641                   to contain values other than zero (the 'wx' object file
2642                   that came with wxhaskell-0.9.4; dunno how it was compiled..).
2643                   So, add displacement to old value instead of asserting
2644                   A to be zero. Fixes wxhaskell-related crashes, and no other
2645                   ill effects have been observed.
2646
2647                   Update: the reason why we're seeing these more elaborate
2648                   relocations is due to a switch in how the NCG compiles SRTs
2649                   and offsets to them from info tables. SRTs live in .(ro)data,
2650                   while info tables live in .text, causing GAS to emit REL32/DISP32
2651                   relocations with non-zero values. Adding the displacement is
2652                   the right thing to do.
2653                */
2654                *pP = S - ((UInt32)pP) - 4 + A;
2655                break;
2656             default:
2657                debugBelch("%s: unhandled PEi386 relocation type %d",
2658                      oc->fileName, reltab_j->Type);
2659                return 0;
2660          }
2661
2662       }
2663    }
2664
2665    IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
2666    return 1;
2667 }
2668
2669 #endif /* defined(OBJFORMAT_PEi386) */
2670
2671
2672 /* --------------------------------------------------------------------------
2673  * ELF specifics
2674  * ------------------------------------------------------------------------*/
2675
2676 #if defined(OBJFORMAT_ELF)
2677
2678 #define FALSE 0
2679 #define TRUE  1
2680
2681 #if defined(sparc_HOST_ARCH)
2682 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
2683 #elif defined(i386_HOST_ARCH)
2684 #  define ELF_TARGET_386    /* Used inside <elf.h> */
2685 #elif defined(x86_64_HOST_ARCH)
2686 #  define ELF_TARGET_X64_64
2687 #  define ELF_64BIT
2688 #elif defined (ia64_HOST_ARCH)
2689 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
2690 #  define ELF_64BIT
2691 #  define ELF_FUNCTION_DESC /* calling convention uses function descriptors */
2692 #  define ELF_NEED_GOT      /* needs Global Offset Table */
2693 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
2694 #endif
2695
2696 #if !defined(openbsd_HOST_OS)
2697 #  include <elf.h>
2698 #else
2699 /* openbsd elf has things in different places, with diff names */
2700 #  include <elf_abi.h>
2701 #  include <machine/reloc.h>
2702 #  define R_386_32    RELOC_32
2703 #  define R_386_PC32  RELOC_PC32
2704 #endif
2705
2706 /* If elf.h doesn't define it */
2707 #  ifndef R_X86_64_PC64
2708 #    define R_X86_64_PC64 24
2709 #  endif
2710
2711 /*
2712  * Define a set of types which can be used for both ELF32 and ELF64
2713  */
2714
2715 #ifdef ELF_64BIT
2716 #define ELFCLASS    ELFCLASS64
2717 #define Elf_Addr    Elf64_Addr
2718 #define Elf_Word    Elf64_Word
2719 #define Elf_Sword   Elf64_Sword
2720 #define Elf_Ehdr    Elf64_Ehdr
2721 #define Elf_Phdr    Elf64_Phdr
2722 #define Elf_Shdr    Elf64_Shdr
2723 #define Elf_Sym     Elf64_Sym
2724 #define Elf_Rel     Elf64_Rel
2725 #define Elf_Rela    Elf64_Rela
2726 #define ELF_ST_TYPE ELF64_ST_TYPE
2727 #define ELF_ST_BIND ELF64_ST_BIND
2728 #define ELF_R_TYPE  ELF64_R_TYPE
2729 #define ELF_R_SYM   ELF64_R_SYM
2730 #else
2731 #define ELFCLASS    ELFCLASS32
2732 #define Elf_Addr    Elf32_Addr
2733 #define Elf_Word    Elf32_Word
2734 #define Elf_Sword   Elf32_Sword
2735 #define Elf_Ehdr    Elf32_Ehdr
2736 #define Elf_Phdr    Elf32_Phdr
2737 #define Elf_Shdr    Elf32_Shdr
2738 #define Elf_Sym     Elf32_Sym
2739 #define Elf_Rel     Elf32_Rel
2740 #define Elf_Rela    Elf32_Rela
2741 #ifndef ELF_ST_TYPE
2742 #define ELF_ST_TYPE ELF32_ST_TYPE
2743 #endif
2744 #ifndef ELF_ST_BIND
2745 #define ELF_ST_BIND ELF32_ST_BIND
2746 #endif
2747 #ifndef ELF_R_TYPE
2748 #define ELF_R_TYPE  ELF32_R_TYPE
2749 #endif
2750 #ifndef ELF_R_SYM
2751 #define ELF_R_SYM   ELF32_R_SYM
2752 #endif
2753 #endif
2754
2755
2756 /*
2757  * Functions to allocate entries in dynamic sections.  Currently we simply
2758  * preallocate a large number, and we don't check if a entry for the given
2759  * target already exists (a linear search is too slow).  Ideally these
2760  * entries would be associated with symbols.
2761  */
2762
2763 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
2764 #define GOT_SIZE            0x20000
2765 #define FUNCTION_TABLE_SIZE 0x10000
2766 #define PLT_SIZE            0x08000
2767
2768 #ifdef ELF_NEED_GOT
2769 static Elf_Addr got[GOT_SIZE];
2770 static unsigned int gotIndex;
2771 static Elf_Addr gp_val = (Elf_Addr)got;
2772
2773 static Elf_Addr
2774 allocateGOTEntry(Elf_Addr target)
2775 {
2776    Elf_Addr *entry;
2777
2778    if (gotIndex >= GOT_SIZE)
2779       barf("Global offset table overflow");
2780
2781    entry = &got[gotIndex++];
2782    *entry = target;
2783    return (Elf_Addr)entry;
2784 }
2785 #endif
2786
2787 #ifdef ELF_FUNCTION_DESC
2788 typedef struct {
2789    Elf_Addr ip;
2790    Elf_Addr gp;
2791 } FunctionDesc;
2792
2793 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
2794 static unsigned int functionTableIndex;
2795
2796 static Elf_Addr
2797 allocateFunctionDesc(Elf_Addr target)
2798 {
2799    FunctionDesc *entry;
2800
2801    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
2802       barf("Function table overflow");
2803
2804    entry = &functionTable[functionTableIndex++];
2805    entry->ip = target;
2806    entry->gp = (Elf_Addr)gp_val;
2807    return (Elf_Addr)entry;
2808 }
2809
2810 static Elf_Addr
2811 copyFunctionDesc(Elf_Addr target)
2812 {
2813    FunctionDesc *olddesc = (FunctionDesc *)target;
2814    FunctionDesc *newdesc;
2815
2816    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
2817    newdesc->gp = olddesc->gp;
2818    return (Elf_Addr)newdesc;
2819 }
2820 #endif
2821
2822 #ifdef ELF_NEED_PLT
2823 #ifdef ia64_HOST_ARCH
2824 static void ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value);
2825 static void ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc);
2826
2827 static unsigned char plt_code[] =
2828 {
2829    /* taken from binutils bfd/elfxx-ia64.c */
2830    0x0b, 0x78, 0x00, 0x02, 0x00, 0x24,  /*   [MMI]       addl r15=0,r1;;    */
2831    0x00, 0x41, 0x3c, 0x30, 0x28, 0xc0,  /*               ld8 r16=[r15],8    */
2832    0x01, 0x08, 0x00, 0x84,              /*               mov r14=r1;;       */
2833    0x11, 0x08, 0x00, 0x1e, 0x18, 0x10,  /*   [MIB]       ld8 r1=[r15]       */
2834    0x60, 0x80, 0x04, 0x80, 0x03, 0x00,  /*               mov b6=r16         */
2835    0x60, 0x00, 0x80, 0x00               /*               br.few b6;;        */
2836 };
2837
2838 /* If we can't get to the function descriptor via gp, take a local copy of it */
2839 #define PLT_RELOC(code, target) { \
2840    Elf64_Sxword rel_value = target - gp_val; \
2841    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff)) \
2842       ia64_reloc_gprel22((Elf_Addr)code, copyFunctionDesc(target)); \
2843    else \
2844       ia64_reloc_gprel22((Elf_Addr)code, target); \
2845    }
2846 #endif
2847
2848 typedef struct {
2849    unsigned char code[sizeof(plt_code)];
2850 } PLTEntry;
2851
2852 static Elf_Addr
2853 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
2854 {
2855    PLTEntry *plt = (PLTEntry *)oc->plt;
2856    PLTEntry *entry;
2857
2858    if (oc->pltIndex >= PLT_SIZE)
2859       barf("Procedure table overflow");
2860
2861    entry = &plt[oc->pltIndex++];
2862    memcpy(entry->code, plt_code, sizeof(entry->code));
2863    PLT_RELOC(entry->code, target);
2864    return (Elf_Addr)entry;
2865 }
2866
2867 static unsigned int
2868 PLTSize(void)
2869 {
2870    return (PLT_SIZE * sizeof(PLTEntry));
2871 }
2872 #endif
2873
2874
2875 /*
2876  * Generic ELF functions
2877  */
2878
2879 static char *
2880 findElfSection ( void* objImage, Elf_Word sh_type )
2881 {
2882    char* ehdrC = (char*)objImage;
2883    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2884    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
2885    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2886    char* ptr = NULL;
2887    int i;
2888
2889    for (i = 0; i < ehdr->e_shnum; i++) {
2890       if (shdr[i].sh_type == sh_type
2891           /* Ignore the section header's string table. */
2892           && i != ehdr->e_shstrndx
2893           /* Ignore string tables named .stabstr, as they contain
2894              debugging info. */
2895           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2896          ) {
2897          ptr = ehdrC + shdr[i].sh_offset;
2898          break;
2899       }
2900    }
2901    return ptr;
2902 }
2903
2904 #if defined(ia64_HOST_ARCH)
2905 static Elf_Addr
2906 findElfSegment ( void* objImage, Elf_Addr vaddr )
2907 {
2908    char* ehdrC = (char*)objImage;
2909    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2910    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2911    Elf_Addr segaddr = 0;
2912    int i;
2913
2914    for (i = 0; i < ehdr->e_phnum; i++) {
2915       segaddr = phdr[i].p_vaddr;
2916       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2917               break;
2918    }
2919    return segaddr;
2920 }
2921 #endif
2922
2923 static int
2924 ocVerifyImage_ELF ( ObjectCode* oc )
2925 {
2926    Elf_Shdr* shdr;
2927    Elf_Sym*  stab;
2928    int i, j, nent, nstrtab, nsymtabs;
2929    char* sh_strtab;
2930    char* strtab;
2931
2932    char*     ehdrC = (char*)(oc->image);
2933    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2934
2935    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2936        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2937        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2938        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2939       errorBelch("%s: not an ELF object", oc->fileName);
2940       return 0;
2941    }
2942
2943    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2944       errorBelch("%s: unsupported ELF format", oc->fileName);
2945       return 0;
2946    }
2947
2948    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2949        IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
2950    } else
2951    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2952        IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
2953    } else {
2954        errorBelch("%s: unknown endiannness", oc->fileName);
2955        return 0;
2956    }
2957
2958    if (ehdr->e_type != ET_REL) {
2959       errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
2960       return 0;
2961    }
2962    IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
2963
2964    IF_DEBUG(linker,debugBelch( "Architecture is " ));
2965    switch (ehdr->e_machine) {
2966       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
2967 #ifdef EM_SPARC32PLUS
2968       case EM_SPARC32PLUS:
2969 #endif
2970       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
2971 #ifdef EM_IA_64
2972       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
2973 #endif
2974       case EM_PPC:   IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
2975 #ifdef EM_X86_64
2976       case EM_X86_64: IF_DEBUG(linker,debugBelch( "x86_64" )); break;
2977 #elif defined(EM_AMD64)
2978       case EM_AMD64: IF_DEBUG(linker,debugBelch( "amd64" )); break;
2979 #endif
2980       default:       IF_DEBUG(linker,debugBelch( "unknown" ));
2981                      errorBelch("%s: unknown architecture (e_machine == %d)"
2982                                 , oc->fileName, ehdr->e_machine);
2983                      return 0;
2984    }
2985
2986    IF_DEBUG(linker,debugBelch(
2987              "\nSection header table: start %ld, n_entries %d, ent_size %d\n",
2988              (long)ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
2989
2990    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
2991
2992    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2993
2994    if (ehdr->e_shstrndx == SHN_UNDEF) {
2995       errorBelch("%s: no section header string table", oc->fileName);
2996       return 0;
2997    } else {
2998       IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
2999                           ehdr->e_shstrndx));
3000       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
3001    }
3002
3003    for (i = 0; i < ehdr->e_shnum; i++) {
3004       IF_DEBUG(linker,debugBelch("%2d:  ", i ));
3005       IF_DEBUG(linker,debugBelch("type=%2d  ", (int)shdr[i].sh_type ));
3006       IF_DEBUG(linker,debugBelch("size=%4d  ", (int)shdr[i].sh_size ));
3007       IF_DEBUG(linker,debugBelch("offs=%4d  ", (int)shdr[i].sh_offset ));
3008       IF_DEBUG(linker,debugBelch("  (%p .. %p)  ",
3009                ehdrC + shdr[i].sh_offset,
3010                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
3011
3012       if (shdr[i].sh_type == SHT_REL) {
3013           IF_DEBUG(linker,debugBelch("Rel  " ));
3014       } else if (shdr[i].sh_type == SHT_RELA) {
3015           IF_DEBUG(linker,debugBelch("RelA " ));
3016       } else {
3017           IF_DEBUG(linker,debugBelch("     "));
3018       }
3019       if (sh_strtab) {
3020           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
3021       }
3022    }
3023
3024    IF_DEBUG(linker,debugBelch( "\nString tables" ));
3025    strtab = NULL;
3026    nstrtab = 0;
3027    for (i = 0; i < ehdr->e_shnum; i++) {
3028       if (shdr[i].sh_type == SHT_STRTAB
3029           /* Ignore the section header's string table. */
3030           && i != ehdr->e_shstrndx
3031           /* Ignore string tables named .stabstr, as they contain
3032              debugging info. */
3033           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
3034          ) {
3035          IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
3036          strtab = ehdrC + shdr[i].sh_offset;
3037          nstrtab++;
3038       }
3039    }
3040    if (nstrtab != 1) {
3041       errorBelch("%s: no string tables, or too many", oc->fileName);
3042       return 0;
3043    }
3044
3045    nsymtabs = 0;
3046    IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
3047    for (i = 0; i < ehdr->e_shnum; i++) {
3048       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3049       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
3050       nsymtabs++;
3051       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3052       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3053       IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%ld rem)\n",
3054                nent,
3055                (long)shdr[i].sh_size % sizeof(Elf_Sym)
3056              ));
3057       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
3058          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
3059          return 0;
3060       }
3061       for (j = 0; j < nent; j++) {
3062          IF_DEBUG(linker,debugBelch("   %2d  ", j ));
3063          IF_DEBUG(linker,debugBelch("  sec=%-5d  size=%-3d  val=%5p  ",
3064                              (int)stab[j].st_shndx,
3065                              (int)stab[j].st_size,
3066                              (char*)stab[j].st_value ));
3067
3068          IF_DEBUG(linker,debugBelch("type=" ));
3069          switch (ELF_ST_TYPE(stab[j].st_info)) {
3070             case STT_NOTYPE:  IF_DEBUG(linker,debugBelch("notype " )); break;
3071             case STT_OBJECT:  IF_DEBUG(linker,debugBelch("object " )); break;
3072             case STT_FUNC  :  IF_DEBUG(linker,debugBelch("func   " )); break;
3073             case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
3074             case STT_FILE:    IF_DEBUG(linker,debugBelch("file   " )); break;
3075             default:          IF_DEBUG(linker,debugBelch("?      " )); break;
3076          }
3077          IF_DEBUG(linker,debugBelch("  " ));
3078
3079          IF_DEBUG(linker,debugBelch("bind=" ));
3080          switch (ELF_ST_BIND(stab[j].st_info)) {
3081             case STB_LOCAL :  IF_DEBUG(linker,debugBelch("local " )); break;
3082             case STB_GLOBAL:  IF_DEBUG(linker,debugBelch("global" )); break;
3083             case STB_WEAK  :  IF_DEBUG(linker,debugBelch("weak  " )); break;
3084             default:          IF_DEBUG(linker,debugBelch("?     " )); break;
3085          }
3086          IF_DEBUG(linker,debugBelch("  " ));
3087
3088          IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
3089       }
3090    }
3091
3092    if (nsymtabs == 0) {
3093       errorBelch("%s: didn't find any symbol tables", oc->fileName);
3094       return 0;
3095    }
3096
3097    return 1;
3098 }
3099
3100 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
3101 {
3102     *is_bss = FALSE;
3103
3104     if (hdr->sh_type == SHT_PROGBITS
3105         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
3106         /* .text-style section */
3107         return SECTIONKIND_CODE_OR_RODATA;
3108     }
3109
3110     if (hdr->sh_type == SHT_PROGBITS
3111             && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3112             /* .data-style section */
3113             return SECTIONKIND_RWDATA;
3114     }
3115
3116     if (hdr->sh_type == SHT_PROGBITS
3117         && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
3118         /* .rodata-style section */
3119         return SECTIONKIND_CODE_OR_RODATA;
3120     }
3121
3122     if (hdr->sh_type == SHT_NOBITS
3123         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3124         /* .bss-style section */
3125         *is_bss = TRUE;
3126         return SECTIONKIND_RWDATA;
3127     }
3128
3129     return SECTIONKIND_OTHER;
3130 }
3131
3132
3133 static int
3134 ocGetNames_ELF ( ObjectCode* oc )
3135 {
3136    int i, j, k, nent;
3137    Elf_Sym* stab;
3138
3139    char*     ehdrC    = (char*)(oc->image);
3140    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
3141    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
3142    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3143
3144    ASSERT(symhash != NULL);
3145
3146    if (!strtab) {
3147       errorBelch("%s: no strtab", oc->fileName);
3148       return 0;
3149    }
3150
3151    k = 0;
3152    for (i = 0; i < ehdr->e_shnum; i++) {
3153       /* Figure out what kind of section it is.  Logic derived from
3154          Figure 1.14 ("Special Sections") of the ELF document
3155          ("Portable Formats Specification, Version 1.1"). */
3156       int         is_bss = FALSE;
3157       SectionKind kind   = getSectionKind_ELF(&shdr[i], &is_bss);
3158
3159       if (is_bss && shdr[i].sh_size > 0) {
3160          /* This is a non-empty .bss section.  Allocate zeroed space for
3161             it, and set its .sh_offset field such that
3162             ehdrC + .sh_offset == addr_of_zeroed_space.  */
3163          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
3164                                        "ocGetNames_ELF(BSS)");
3165          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
3166          /*
3167          debugBelch("BSS section at 0x%x, size %d\n",
3168                          zspace, shdr[i].sh_size);
3169          */
3170       }
3171
3172       /* fill in the section info */
3173       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
3174          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
3175          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
3176                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
3177       }
3178
3179       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3180
3181       /* copy stuff into this module's object symbol table */
3182       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3183       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3184
3185       oc->n_symbols = nent;
3186       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3187                                    "ocGetNames_ELF(oc->symbols)");
3188
3189       for (j = 0; j < nent; j++) {
3190
3191          char  isLocal = FALSE; /* avoids uninit-var warning */
3192          char* ad      = NULL;
3193          char* nm      = strtab + stab[j].st_name;
3194          int   secno   = stab[j].st_shndx;
3195
3196          /* Figure out if we want to add it; if so, set ad to its
3197             address.  Otherwise leave ad == NULL. */
3198
3199          if (secno == SHN_COMMON) {
3200             isLocal = FALSE;
3201             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
3202             /*
3203             debugBelch("COMMON symbol, size %d name %s\n",
3204                             stab[j].st_size, nm);
3205             */
3206             /* Pointless to do addProddableBlock() for this area,
3207                since the linker should never poke around in it. */
3208          }
3209          else
3210          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
3211                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
3212               )
3213               /* and not an undefined symbol */
3214               && stab[j].st_shndx != SHN_UNDEF
3215               /* and not in a "special section" */
3216               && stab[j].st_shndx < SHN_LORESERVE
3217               &&
3218               /* and it's a not a section or string table or anything silly */
3219               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
3220                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
3221                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
3222               )
3223             ) {
3224             /* Section 0 is the undefined section, hence > and not >=. */
3225             ASSERT(secno > 0 && secno < ehdr->e_shnum);
3226             /*
3227             if (shdr[secno].sh_type == SHT_NOBITS) {
3228                debugBelch("   BSS symbol, size %d off %d name %s\n",
3229                                stab[j].st_size, stab[j].st_value, nm);
3230             }
3231             */
3232             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
3233             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
3234                isLocal = TRUE;
3235             } else {
3236 #ifdef ELF_FUNCTION_DESC
3237                /* dlsym() and the initialisation table both give us function
3238                 * descriptors, so to be consistent we store function descriptors
3239                 * in the symbol table */
3240                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
3241                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
3242 #endif
3243                IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p  %s %s\n",
3244                                       ad, oc->fileName, nm ));
3245                isLocal = FALSE;
3246             }
3247          }
3248
3249          /* And the decision is ... */
3250
3251          if (ad != NULL) {
3252             ASSERT(nm != NULL);
3253             oc->symbols[j] = nm;
3254             /* Acquire! */
3255             if (isLocal) {
3256                /* Ignore entirely. */
3257             } else {
3258                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
3259             }
3260          } else {
3261             /* Skip. */
3262             IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
3263                                    strtab + stab[j].st_name ));
3264             /*
3265             debugBelch(
3266                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
3267                     (int)ELF_ST_BIND(stab[j].st_info),
3268                     (int)ELF_ST_TYPE(stab[j].st_info),
3269                     (int)stab[j].st_shndx,
3270                     strtab + stab[j].st_name
3271                    );
3272             */
3273             oc->symbols[j] = NULL;
3274          }
3275
3276       }
3277    }
3278
3279    return 1;
3280 }
3281
3282 /* Do ELF relocations which lack an explicit addend.  All x86-linux
3283    relocations appear to be of this form. */
3284 static int
3285 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
3286                          Elf_Shdr* shdr, int shnum,
3287                          Elf_Sym*  stab, char* strtab )
3288 {
3289    int j;
3290    char *symbol;
3291    Elf_Word* targ;
3292    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
3293    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
3294    int target_shndx = shdr[shnum].sh_info;
3295    int symtab_shndx = shdr[shnum].sh_link;
3296
3297    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3298    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
3299    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3300                           target_shndx, symtab_shndx ));
3301
3302    /* Skip sections that we're not interested in. */
3303    {
3304        int is_bss;
3305        SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
3306        if (kind == SECTIONKIND_OTHER) {
3307            IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
3308            return 1;
3309        }
3310    }
3311
3312    for (j = 0; j < nent; j++) {
3313       Elf_Addr offset = rtab[j].r_offset;
3314       Elf_Addr info   = rtab[j].r_info;
3315
3316       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
3317       Elf_Word* pP = (Elf_Word*)P;
3318       Elf_Addr  A  = *pP;
3319       Elf_Addr  S;
3320       void*     S_tmp;
3321       Elf_Addr  value;
3322       StgStablePtr stablePtr;
3323       StgPtr stableVal;
3324
3325       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
3326                              j, (void*)offset, (void*)info ));
3327       if (!info) {
3328          IF_DEBUG(linker,debugBelch( " ZERO" ));
3329          S = 0;
3330       } else {
3331          Elf_Sym sym = stab[ELF_R_SYM(info)];
3332          /* First see if it is a local symbol. */
3333          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3334             /* Yes, so we can get the address directly from the ELF symbol
3335                table. */
3336             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3337             S = (Elf_Addr)
3338                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3339                        + stab[ELF_R_SYM(info)].st_value);
3340
3341          } else {
3342             symbol = strtab + sym.st_name;
3343             stablePtr = (StgStablePtr)lookupHashTable(stablehash, (StgWord)symbol);
3344             if (NULL == stablePtr) {
3345               /* No, so look up the name in our global table. */
3346               S_tmp = lookupSymbol( symbol );
3347               S = (Elf_Addr)S_tmp;
3348             } else {
3349               stableVal = deRefStablePtr( stablePtr );
3350               S_tmp = stableVal;
3351               S = (Elf_Addr)S_tmp;
3352             }
3353          }
3354          if (!S) {
3355             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3356             return 0;
3357          }
3358          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n", symbol, (void*)S ));
3359       }
3360
3361       IF_DEBUG(linker,debugBelch( "Reloc: P = %p   S = %p   A = %p\n",
3362                              (void*)P, (void*)S, (void*)A ));
3363       checkProddableBlock ( oc, pP );
3364
3365       value = S + A;
3366
3367       switch (ELF_R_TYPE(info)) {
3368 #        ifdef i386_HOST_ARCH
3369          case R_386_32:   *pP = value;     break;
3370          case R_386_PC32: *pP = value - P; break;
3371 #        endif
3372          default:
3373             errorBelch("%s: unhandled ELF relocation(Rel) type %lu\n",
3374                   oc->fileName, (lnat)ELF_R_TYPE(info));
3375             return 0;
3376       }
3377
3378    }
3379    return 1;
3380 }
3381
3382 /* Do ELF relocations for which explicit addends are supplied.
3383    sparc-solaris relocations appear to be of this form. */
3384 static int
3385 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
3386                           Elf_Shdr* shdr, int shnum,
3387                           Elf_Sym*  stab, char* strtab )
3388 {
3389    int j;
3390    char *symbol = NULL;
3391    Elf_Addr targ;
3392    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
3393    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
3394    int target_shndx = shdr[shnum].sh_info;
3395    int symtab_shndx = shdr[shnum].sh_link;
3396
3397    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3398    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
3399    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3400                           target_shndx, symtab_shndx ));
3401
3402    for (j = 0; j < nent; j++) {
3403 #if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3404       /* This #ifdef only serves to avoid unused-var warnings. */
3405       Elf_Addr  offset = rtab[j].r_offset;
3406       Elf_Addr  P      = targ + offset;
3407 #endif
3408       Elf_Addr  info   = rtab[j].r_info;
3409       Elf_Addr  A      = rtab[j].r_addend;
3410       Elf_Addr  S;
3411       void*     S_tmp;
3412       Elf_Addr  value;
3413 #     if defined(sparc_HOST_ARCH)
3414       Elf_Word* pP = (Elf_Word*)P;
3415       Elf_Word  w1, w2;
3416 #     elif defined(ia64_HOST_ARCH)
3417       Elf64_Xword *pP = (Elf64_Xword *)P;
3418       Elf_Addr addr;
3419 #     elif defined(powerpc_HOST_ARCH)
3420       Elf_Sword delta;
3421 #     endif
3422
3423       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p %6p)   ",
3424                              j, (void*)offset, (void*)info,
3425                                 (void*)A ));
3426       if (!info) {
3427          IF_DEBUG(linker,debugBelch( " ZERO" ));
3428          S = 0;
3429       } else {
3430          Elf_Sym sym = stab[ELF_R_SYM(info)];
3431          /* First see if it is a local symbol. */
3432          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3433             /* Yes, so we can get the address directly from the ELF symbol
3434                table. */
3435             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3436             S = (Elf_Addr)
3437                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3438                        + stab[ELF_R_SYM(info)].st_value);
3439 #ifdef ELF_FUNCTION_DESC
3440             /* Make a function descriptor for this function */
3441             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
3442                S = allocateFunctionDesc(S + A);
3443                A = 0;
3444             }
3445 #endif
3446          } else {
3447             /* No, so look up the name in our global table. */
3448             symbol = strtab + sym.st_name;
3449             S_tmp = lookupSymbol( symbol );
3450             S = (Elf_Addr)S_tmp;
3451
3452 #ifdef ELF_FUNCTION_DESC
3453             /* If a function, already a function descriptor - we would
3454                have to copy it to add an offset. */
3455             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
3456                errorBelch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
3457 #endif
3458          }
3459          if (!S) {
3460            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3461            return 0;
3462          }
3463          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p", symbol, (void*)S ));
3464       }
3465
3466       IF_DEBUG(linker,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
3467                                         (void*)P, (void*)S, (void*)A ));
3468       /* checkProddableBlock ( oc, (void*)P ); */
3469
3470       value = S + A;
3471
3472       switch (ELF_R_TYPE(info)) {
3473 #        if defined(sparc_HOST_ARCH)
3474          case R_SPARC_WDISP30:
3475             w1 = *pP & 0xC0000000;
3476             w2 = (Elf_Word)((value - P) >> 2);
3477             ASSERT((w2 & 0xC0000000) == 0);
3478             w1 |= w2;
3479             *pP = w1;
3480             break;
3481          case R_SPARC_HI22:
3482             w1 = *pP & 0xFFC00000;
3483             w2 = (Elf_Word)(value >> 10);
3484             ASSERT((w2 & 0xFFC00000) == 0);
3485             w1 |= w2;
3486             *pP = w1;
3487             break;
3488          case R_SPARC_LO10:
3489             w1 = *pP & ~0x3FF;
3490             w2 = (Elf_Word)(value & 0x3FF);
3491             ASSERT((w2 & ~0x3FF) == 0);
3492             w1 |= w2;
3493             *pP = w1;
3494             break;
3495
3496          /* According to the Sun documentation:
3497             R_SPARC_UA32
3498             This relocation type resembles R_SPARC_32, except it refers to an
3499             unaligned word. That is, the word to be relocated must be treated
3500             as four separate bytes with arbitrary alignment, not as a word
3501             aligned according to the architecture requirements.
3502          */
3503          case R_SPARC_UA32:
3504             w2  = (Elf_Word)value;
3505
3506             // SPARC doesn't do misaligned writes of 32 bit words,
3507             //       so we have to do this one byte-at-a-time.
3508             char *pPc   = (char*)pP;
3509             pPc[0]      = (char) ((Elf_Word)(w2 & 0xff000000) >> 24);
3510             pPc[1]      = (char) ((Elf_Word)(w2 & 0x00ff0000) >> 16);
3511             pPc[2]      = (char) ((Elf_Word)(w2 & 0x0000ff00) >> 8);
3512             pPc[3]      = (char) ((Elf_Word)(w2 & 0x000000ff));
3513             break;
3514
3515          case R_SPARC_32:
3516             w2 = (Elf_Word)value;
3517             *pP = w2;
3518             break;
3519 #        elif defined(ia64_HOST_ARCH)
3520          case R_IA64_DIR64LSB:
3521          case R_IA64_FPTR64LSB:
3522             *pP = value;
3523             break;
3524          case R_IA64_PCREL64LSB:
3525             *pP = value - P;
3526             break;
3527          case R_IA64_SEGREL64LSB:
3528             addr = findElfSegment(ehdrC, value);
3529             *pP = value - addr;
3530             break;
3531          case R_IA64_GPREL22:
3532             ia64_reloc_gprel22(P, value);
3533             break;
3534          case R_IA64_LTOFF22:
3535          case R_IA64_LTOFF22X:
3536          case R_IA64_LTOFF_FPTR22:
3537             addr = allocateGOTEntry(value);
3538             ia64_reloc_gprel22(P, addr);
3539             break;
3540          case R_IA64_PCREL21B:
3541             ia64_reloc_pcrel21(P, S, oc);
3542             break;
3543          case R_IA64_LDXMOV:
3544             /* This goes with R_IA64_LTOFF22X and points to the load to
3545              * convert into a move.  We don't implement relaxation. */
3546             break;
3547 #        elif defined(powerpc_HOST_ARCH)
3548          case R_PPC_ADDR16_LO:
3549             *(Elf32_Half*) P = value;
3550             break;
3551
3552          case R_PPC_ADDR16_HI:
3553             *(Elf32_Half*) P = value >> 16;
3554             break;
3555
3556          case R_PPC_ADDR16_HA:
3557             *(Elf32_Half*) P = (value + 0x8000) >> 16;
3558             break;
3559
3560          case R_PPC_ADDR32:
3561             *(Elf32_Word *) P = value;
3562             break;
3563
3564          case R_PPC_REL32:
3565             *(Elf32_Word *) P = value - P;
3566             break;
3567
3568          case R_PPC_REL24:
3569             delta = value - P;
3570
3571             if( delta << 6 >> 6 != delta )
3572             {
3573                value = (Elf_Addr) (&makeSymbolExtra( oc, ELF_R_SYM(info), value )
3574                                         ->jumpIsland);
3575                delta = value - P;
3576
3577                if( value == 0 || delta << 6 >> 6 != delta )
3578                {
3579                   barf( "Unable to make SymbolExtra for #%d",
3580                         ELF_R_SYM(info) );
3581                   return 0;
3582                }
3583             }
3584
3585             *(Elf_Word *) P = (*(Elf_Word *) P & 0xfc000003)
3586                                           | (delta & 0x3fffffc);
3587             break;
3588 #        endif
3589
3590 #if x86_64_HOST_ARCH
3591       case R_X86_64_64:
3592           *(Elf64_Xword *)P = value;
3593           break;
3594
3595       case R_X86_64_PC32:
3596       {
3597           StgInt64 off = value - P;
3598           if (off >= 0x7fffffffL || off < -0x80000000L) {
3599 #if X86_64_ELF_NONPIC_HACK
3600               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3601                                                 -> jumpIsland;
3602               off = pltAddress + A - P;
3603 #else
3604               barf("R_X86_64_PC32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
3605                    symbol, off, oc->fileName );
3606 #endif
3607           }
3608           *(Elf64_Word *)P = (Elf64_Word)off;
3609           break;
3610       }
3611
3612       case R_X86_64_PC64:
3613       {
3614           StgInt64 off = value - P;
3615           *(Elf64_Word *)P = (Elf64_Word)off;
3616           break;
3617       }
3618
3619       case R_X86_64_32:
3620           if (value >= 0x7fffffffL) {
3621 #if X86_64_ELF_NONPIC_HACK
3622               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3623                                                 -> jumpIsland;
3624               value = pltAddress + A;
3625 #else
3626               barf("R_X86_64_32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
3627                    symbol, value, oc->fileName );
3628 #endif
3629           }
3630           *(Elf64_Word *)P = (Elf64_Word)value;
3631           break;
3632
3633       case R_X86_64_32S:
3634           if ((StgInt64)value > 0x7fffffffL || (StgInt64)value < -0x80000000L) {
3635 #if X86_64_ELF_NONPIC_HACK
3636               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3637                                                 -> jumpIsland;
3638               value = pltAddress + A;
3639 #else
3640               barf("R_X86_64_32S relocation out of range: %s = %p\nRecompile %s with -fPIC.",
3641                    symbol, value, oc->fileName );
3642 #endif
3643           }
3644           *(Elf64_Sword *)P = (Elf64_Sword)value;
3645           break;
3646
3647       case R_X86_64_GOTPCREL:
3648       {
3649           StgInt64 gotAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)->addr;
3650           StgInt64 off = gotAddress + A - P;
3651           *(Elf64_Word *)P = (Elf64_Word)off;
3652           break;
3653       }
3654
3655       case R_X86_64_PLT32:
3656       {
3657           StgInt64 off = value - P;
3658           if (off >= 0x7fffffffL || off < -0x80000000L) {
3659               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3660                                                     -> jumpIsland;
3661               off = pltAddress + A - P;
3662           }
3663           *(Elf64_Word *)P = (Elf64_Word)off;
3664           break;
3665       }
3666 #endif
3667
3668          default:
3669             errorBelch("%s: unhandled ELF relocation(RelA) type %lu\n",
3670                   oc->fileName, (lnat)ELF_R_TYPE(info));
3671             return 0;
3672       }
3673
3674    }
3675    return 1;
3676 }
3677
3678 static int
3679 ocResolve_ELF ( ObjectCode* oc )
3680 {
3681    char *strtab;
3682    int   shnum, ok;
3683    Elf_Sym*  stab  = NULL;
3684    char*     ehdrC = (char*)(oc->image);
3685    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
3686    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3687
3688    /* first find "the" symbol table */
3689    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
3690
3691    /* also go find the string table */
3692    strtab = findElfSection ( ehdrC, SHT_STRTAB );
3693
3694    if (stab == NULL || strtab == NULL) {
3695       errorBelch("%s: can't find string or symbol table", oc->fileName);
3696       return 0;
3697    }
3698
3699    /* Process the relocation sections. */
3700    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
3701       if (shdr[shnum].sh_type == SHT_REL) {
3702          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
3703                                        shnum, stab, strtab );
3704          if (!ok) return ok;
3705       }
3706       else
3707       if (shdr[shnum].sh_type == SHT_RELA) {
3708          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
3709                                         shnum, stab, strtab );
3710          if (!ok) return ok;
3711       }
3712    }
3713
3714 #if defined(powerpc_HOST_ARCH)
3715    ocFlushInstructionCache( oc );
3716 #endif
3717
3718    return 1;
3719 }
3720
3721 /*
3722  * IA64 specifics
3723  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
3724  * at the front.  The following utility functions pack and unpack instructions, and
3725  * take care of the most common relocations.
3726  */
3727
3728 #ifdef ia64_HOST_ARCH
3729
3730 static Elf64_Xword
3731 ia64_extract_instruction(Elf64_Xword *target)
3732 {
3733    Elf64_Xword w1, w2;
3734    int slot = (Elf_Addr)target & 3;
3735    target = (Elf_Addr)target & ~3;
3736
3737    w1 = *target;
3738    w2 = *(target+1);
3739
3740    switch (slot)
3741    {
3742       case 0:
3743          return ((w1 >> 5) & 0x1ffffffffff);
3744       case 1:
3745          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
3746       case 2:
3747          return (w2 >> 23);
3748       default:
3749          barf("ia64_extract_instruction: invalid slot %p", target);
3750    }
3751 }
3752
3753 static void
3754 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
3755 {
3756    int slot = (Elf_Addr)target & 3;
3757    target = (Elf_Addr)target & ~3;
3758
3759    switch (slot)
3760    {
3761       case 0:
3762          *target |= value << 5;
3763          break;
3764       case 1:
3765          *target |= value << 46;
3766          *(target+1) |= value >> 18;
3767          break;
3768       case 2:
3769          *(target+1) |= value << 23;
3770          break;
3771    }
3772 }
3773
3774 static void
3775 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
3776 {
3777    Elf64_Xword instruction;
3778    Elf64_Sxword rel_value;
3779
3780    rel_value = value - gp_val;
3781    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
3782       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
3783
3784    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3785    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
3786                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
3787                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
3788                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3789    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3790 }
3791
3792 static void
3793 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
3794 {
3795    Elf64_Xword instruction;
3796    Elf64_Sxword rel_value;
3797    Elf_Addr entry;
3798
3799    entry = allocatePLTEntry(value, oc);
3800
3801    rel_value = (entry >> 4) - (target >> 4);
3802    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
3803       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
3804
3805    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3806    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
3807                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3808    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3809 }
3810
3811 #endif /* ia64 */
3812
3813 /*
3814  * PowerPC & X86_64 ELF specifics
3815  */
3816
3817 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3818
3819 static int ocAllocateSymbolExtras_ELF( ObjectCode *oc )
3820 {
3821   Elf_Ehdr *ehdr;
3822   Elf_Shdr* shdr;
3823   int i;
3824
3825   ehdr = (Elf_Ehdr *) oc->image;
3826   shdr = (Elf_Shdr *) ( ((char *)oc->image) + ehdr->e_shoff );
3827
3828   for( i = 0; i < ehdr->e_shnum; i++ )
3829     if( shdr[i].sh_type == SHT_SYMTAB )
3830       break;
3831
3832   if( i == ehdr->e_shnum )
3833   {
3834     errorBelch( "This ELF file contains no symtab" );
3835     return 0;
3836   }
3837
3838   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
3839   {
3840     errorBelch( "The entry size (%d) of the symtab isn't %d\n",
3841       (int) shdr[i].sh_entsize, (int) sizeof( Elf_Sym ) );
3842
3843     return 0;
3844   }
3845
3846   return ocAllocateSymbolExtras( oc, shdr[i].sh_size / sizeof( Elf_Sym ), 0 );
3847 }
3848
3849 #endif /* powerpc */
3850
3851 #endif /* ELF */
3852
3853 /* --------------------------------------------------------------------------
3854  * Mach-O specifics
3855  * ------------------------------------------------------------------------*/
3856
3857 #if defined(OBJFORMAT_MACHO)
3858
3859 /*
3860   Support for MachO linking on Darwin/MacOS X
3861   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
3862
3863   I hereby formally apologize for the hackish nature of this code.
3864   Things that need to be done:
3865   *) implement ocVerifyImage_MachO
3866   *) add still more sanity checks.
3867 */
3868
3869 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
3870 #define mach_header mach_header_64
3871 #define segment_command segment_command_64
3872 #define section section_64
3873 #define nlist nlist_64
3874 #endif
3875
3876 #ifdef powerpc_HOST_ARCH
3877 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
3878 {
3879     struct mach_header *header = (struct mach_header *) oc->image;
3880     struct load_command *lc = (struct load_command *) (header + 1);
3881     unsigned i;
3882
3883     for( i = 0; i < header->ncmds; i++ )
3884     {
3885         if( lc->cmd == LC_SYMTAB )
3886         {
3887                 // Find out the first and last undefined external
3888                 // symbol, so we don't have to allocate too many
3889                 // jump islands.
3890             struct symtab_command *symLC = (struct symtab_command *) lc;
3891             unsigned min = symLC->nsyms, max = 0;
3892             struct nlist *nlist =
3893                 symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
3894                       : NULL;
3895             for(i=0;i<symLC->nsyms;i++)
3896             {
3897                 if(nlist[i].n_type & N_STAB)
3898                     ;
3899                 else if(nlist[i].n_type & N_EXT)
3900                 {
3901                     if((nlist[i].n_type & N_TYPE) == N_UNDF
3902                         && (nlist[i].n_value == 0))
3903                     {
3904                         if(i < min)
3905                             min = i;
3906                         if(i > max)
3907                             max = i;
3908                     }
3909                 }
3910             }
3911             if(max >= min)
3912                 return ocAllocateSymbolExtras(oc, max - min + 1, min);
3913
3914             break;
3915         }
3916
3917         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3918     }
3919     return ocAllocateSymbolExtras(oc,0,0);
3920 }
3921 #endif
3922 #ifdef x86_64_HOST_ARCH
3923 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
3924 {
3925     struct mach_header *header = (struct mach_header *) oc->image;
3926     struct load_command *lc = (struct load_command *) (header + 1);
3927     unsigned i;
3928
3929     for( i = 0; i < header->ncmds; i++ )
3930     {
3931         if( lc->cmd == LC_SYMTAB )
3932         {
3933                 // Just allocate one entry for every symbol
3934             struct symtab_command *symLC = (struct symtab_command *) lc;
3935
3936             return ocAllocateSymbolExtras(oc, symLC->nsyms, 0);
3937         }
3938
3939         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3940     }
3941     return ocAllocateSymbolExtras(oc,0,0);
3942 }
3943 #endif
3944
3945 static int ocVerifyImage_MachO(ObjectCode* oc)
3946 {
3947     char *image = (char*) oc->image;
3948     struct mach_header *header = (struct mach_header*) image;
3949
3950 #if x86_64_TARGET_ARCH || powerpc64_TARGET_ARCH
3951     if(header->magic != MH_MAGIC_64)
3952         return 0;
3953 #else
3954     if(header->magic != MH_MAGIC)
3955         return 0;
3956 #endif
3957     // FIXME: do some more verifying here
3958     return 1;
3959 }
3960
3961 static int resolveImports(
3962     ObjectCode* oc,
3963     char *image,
3964     struct symtab_command *symLC,
3965     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
3966     unsigned long *indirectSyms,
3967     struct nlist *nlist)
3968 {
3969     unsigned i;
3970     size_t itemSize = 4;
3971
3972 #if i386_HOST_ARCH
3973     int isJumpTable = 0;
3974     if(!strcmp(sect->sectname,"__jump_table"))
3975     {
3976         isJumpTable = 1;
3977         itemSize = 5;
3978         ASSERT(sect->reserved2 == itemSize);
3979     }
3980 #endif
3981
3982     for(i=0; i*itemSize < sect->size;i++)
3983     {
3984         // according to otool, reserved1 contains the first index into the indirect symbol table
3985         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
3986         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3987         void *addr = NULL;
3988
3989         if((symbol->n_type & N_TYPE) == N_UNDF
3990             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
3991             addr = (void*) (symbol->n_value);
3992         else
3993             addr = lookupSymbol(nm);
3994         if(!addr)
3995         {
3996             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
3997             return 0;
3998         }
3999         ASSERT(addr);
4000
4001 #if i386_HOST_ARCH
4002         if(isJumpTable)
4003         {
4004             checkProddableBlock(oc,image + sect->offset + i*itemSize);
4005             *(image + sect->offset + i*itemSize) = 0xe9; // jmp
4006             *(unsigned*)(image + sect->offset + i*itemSize + 1)
4007                 = (char*)addr - (image + sect->offset + i*itemSize + 5);
4008         }
4009         else
4010 #endif
4011         {
4012             checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
4013             ((void**)(image + sect->offset))[i] = addr;
4014         }
4015     }
4016
4017     return 1;
4018 }
4019
4020 static unsigned long relocateAddress(
4021     ObjectCode* oc,
4022     int nSections,
4023     struct section* sections,
4024     unsigned long address)
4025 {
4026     int i;
4027     for(i = 0; i < nSections; i++)
4028     {
4029         if(sections[i].addr <= address
4030             && address < sections[i].addr + sections[i].size)
4031         {
4032             return (unsigned long)oc->image
4033                     + sections[i].offset + address - sections[i].addr;
4034         }
4035     }
4036     barf("Invalid Mach-O file:"
4037          "Address out of bounds while relocating object file");
4038     return 0;
4039 }
4040
4041 static int relocateSection(
4042     ObjectCode* oc,
4043     char *image,
4044     struct symtab_command *symLC, struct nlist *nlist,
4045     int nSections, struct section* sections, struct section *sect)
4046 {
4047     struct relocation_info *relocs;
4048     int i,n;
4049
4050     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
4051         return 1;
4052     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
4053         return 1;
4054     else if(!strcmp(sect->sectname,"__la_sym_ptr2"))
4055         return 1;
4056     else if(!strcmp(sect->sectname,"__la_sym_ptr3"))
4057         return 1;
4058
4059     n = sect->nreloc;
4060     relocs = (struct relocation_info*) (image + sect->reloff);
4061
4062     for(i=0;i<n;i++)
4063     {
4064 #ifdef x86_64_HOST_ARCH
4065         struct relocation_info *reloc = &relocs[i];
4066
4067         char    *thingPtr = image + sect->offset + reloc->r_address;
4068         uint64_t thing;
4069         /* We shouldn't need to initialise this, but gcc on OS X 64 bit
4070            complains that it may be used uninitialized if we don't */
4071         uint64_t value = 0;
4072         uint64_t baseValue;
4073         int type = reloc->r_type;
4074
4075         checkProddableBlock(oc,thingPtr);
4076         switch(reloc->r_length)
4077         {
4078             case 0:
4079                 thing = *(uint8_t*)thingPtr;
4080                 baseValue = (uint64_t)thingPtr + 1;
4081                 break;
4082             case 1:
4083                 thing = *(uint16_t*)thingPtr;
4084                 baseValue = (uint64_t)thingPtr + 2;
4085                 break;
4086             case 2:
4087                 thing = *(uint32_t*)thingPtr;
4088                 baseValue = (uint64_t)thingPtr + 4;
4089                 break;
4090             case 3:
4091                 thing = *(uint64_t*)thingPtr;
4092                 baseValue = (uint64_t)thingPtr + 8;
4093                 break;
4094             default:
4095                 barf("Unknown size.");
4096         }
4097
4098         if(type == X86_64_RELOC_GOT
4099            || type == X86_64_RELOC_GOT_LOAD)
4100         {
4101             ASSERT(reloc->r_extern);
4102             value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)->addr;
4103
4104             type = X86_64_RELOC_SIGNED;
4105         }
4106         else if(reloc->r_extern)
4107         {
4108             struct nlist *symbol = &nlist[reloc->r_symbolnum];
4109             char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4110             if(symbol->n_value == 0)
4111                 value = (uint64_t) lookupSymbol(nm);
4112             else
4113                 value = relocateAddress(oc, nSections, sections,
4114                                         symbol->n_value);
4115         }
4116         else
4117         {
4118             value = sections[reloc->r_symbolnum-1].offset
4119                   - sections[reloc->r_symbolnum-1].addr
4120                   + (uint64_t) image;
4121         }
4122
4123         if(type == X86_64_RELOC_BRANCH)
4124         {
4125             if((int32_t)(value - baseValue) != (int64_t)(value - baseValue))
4126             {
4127                 ASSERT(reloc->r_extern);
4128                 value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)
4129                                         -> jumpIsland;
4130             }
4131             ASSERT((int32_t)(value - baseValue) == (int64_t)(value - baseValue));
4132             type = X86_64_RELOC_SIGNED;
4133         }
4134
4135         switch(type)
4136         {
4137             case X86_64_RELOC_UNSIGNED:
4138                 ASSERT(!reloc->r_pcrel);
4139                 thing += value;
4140                 break;
4141             case X86_64_RELOC_SIGNED:
4142                 ASSERT(reloc->r_pcrel);
4143                 thing += value - baseValue;
4144                 break;
4145             case X86_64_RELOC_SUBTRACTOR:
4146                 ASSERT(!reloc->r_pcrel);
4147                 thing -= value;
4148                 break;
4149             default:
4150                 barf("unkown relocation");
4151         }
4152
4153         switch(reloc->r_length)
4154         {
4155             case 0:
4156                 *(uint8_t*)thingPtr = thing;
4157                 break;
4158             case 1:
4159                 *(uint16_t*)thingPtr = thing;
4160                 break;
4161             case 2:
4162                 *(uint32_t*)thingPtr = thing;
4163                 break;
4164             case 3:
4165                 *(uint64_t*)thingPtr = thing;
4166                 break;
4167         }
4168 #else
4169         if(relocs[i].r_address & R_SCATTERED)
4170         {
4171             struct scattered_relocation_info *scat =
4172                 (struct scattered_relocation_info*) &relocs[i];
4173
4174             if(!scat->r_pcrel)
4175             {
4176                 if(scat->r_length == 2)
4177                 {
4178                     unsigned long word = 0;
4179                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
4180                     checkProddableBlock(oc,wordPtr);
4181
4182                     // Note on relocation types:
4183                     // i386 uses the GENERIC_RELOC_* types,
4184                     // while ppc uses special PPC_RELOC_* types.
4185                     // *_RELOC_VANILLA and *_RELOC_PAIR have the same value
4186                     // in both cases, all others are different.
4187                     // Therefore, we use GENERIC_RELOC_VANILLA
4188                     // and GENERIC_RELOC_PAIR instead of the PPC variants,
4189                     // and use #ifdefs for the other types.
4190
4191                     // Step 1: Figure out what the relocated value should be
4192                     if(scat->r_type == GENERIC_RELOC_VANILLA)
4193                     {
4194                         word = *wordPtr + (unsigned long) relocateAddress(
4195                                                                 oc,
4196                                                                 nSections,
4197                                                                 sections,
4198                                                                 scat->r_value)
4199                                         - scat->r_value;
4200                     }
4201 #ifdef powerpc_HOST_ARCH
4202                     else if(scat->r_type == PPC_RELOC_SECTDIFF
4203                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
4204                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
4205                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
4206 #else
4207                     else if(scat->r_type == GENERIC_RELOC_SECTDIFF)
4208 #endif
4209                     {
4210                         struct scattered_relocation_info *pair =
4211                                 (struct scattered_relocation_info*) &relocs[i+1];
4212
4213                         if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR)
4214                             barf("Invalid Mach-O file: "
4215                                  "RELOC_*_SECTDIFF not followed by RELOC_PAIR");
4216
4217                         word = (unsigned long)
4218                                (relocateAddress(oc, nSections, sections, scat->r_value)
4219                               - relocateAddress(oc, nSections, sections, pair->r_value));
4220                         i++;
4221                     }
4222 #ifdef powerpc_HOST_ARCH
4223                     else if(scat->r_type == PPC_RELOC_HI16
4224                          || scat->r_type == PPC_RELOC_LO16
4225                          || scat->r_type == PPC_RELOC_HA16
4226                          || scat->r_type == PPC_RELOC_LO14)
4227                     {   // these are generated by label+offset things
4228                         struct relocation_info *pair = &relocs[i+1];
4229                         if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
4230                             barf("Invalid Mach-O file: "
4231                                  "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
4232
4233                         if(scat->r_type == PPC_RELOC_LO16)
4234                         {
4235                             word = ((unsigned short*) wordPtr)[1];
4236                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4237                         }
4238                         else if(scat->r_type == PPC_RELOC_LO14)
4239                         {
4240                             barf("Unsupported Relocation: PPC_RELOC_LO14");
4241                             word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
4242                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4243                         }
4244                         else if(scat->r_type == PPC_RELOC_HI16)
4245                         {
4246                             word = ((unsigned short*) wordPtr)[1] << 16;
4247                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4248                         }
4249                         else if(scat->r_type == PPC_RELOC_HA16)
4250                         {
4251                             word = ((unsigned short*) wordPtr)[1] << 16;
4252                             word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4253                         }
4254
4255
4256                         word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
4257                                                 - scat->r_value;
4258
4259                         i++;
4260                     }
4261  #endif
4262                     else
4263                         continue;  // ignore the others
4264
4265 #ifdef powerpc_HOST_ARCH
4266                     if(scat->r_type == GENERIC_RELOC_VANILLA
4267                         || scat->r_type == PPC_RELOC_SECTDIFF)
4268 #else
4269                     if(scat->r_type == GENERIC_RELOC_VANILLA
4270                         || scat->r_type == GENERIC_RELOC_SECTDIFF)
4271 #endif
4272                     {
4273                         *wordPtr = word;
4274                     }
4275 #ifdef powerpc_HOST_ARCH
4276                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
4277                     {
4278                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4279                     }
4280                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
4281                     {
4282                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4283                     }
4284                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
4285                     {
4286                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4287                             + ((word & (1<<15)) ? 1 : 0);
4288                     }
4289 #endif
4290                 }
4291             }
4292
4293             continue; // FIXME: I hope it's OK to ignore all the others.
4294         }
4295         else
4296         {
4297             struct relocation_info *reloc = &relocs[i];
4298             if(reloc->r_pcrel && !reloc->r_extern)
4299                 continue;
4300
4301             if(reloc->r_length == 2)
4302             {
4303                 unsigned long word = 0;
4304 #ifdef powerpc_HOST_ARCH
4305                 unsigned long jumpIsland = 0;
4306                 long offsetToJumpIsland = 0xBADBAD42; // initialise to bad value
4307                                                       // to avoid warning and to catch
4308                                                       // bugs.
4309 #endif
4310
4311                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
4312                 checkProddableBlock(oc,wordPtr);
4313
4314                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4315                 {
4316                     word = *wordPtr;
4317                 }
4318 #ifdef powerpc_HOST_ARCH
4319                 else if(reloc->r_type == PPC_RELOC_LO16)
4320                 {
4321                     word = ((unsigned short*) wordPtr)[1];
4322                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4323                 }
4324                 else if(reloc->r_type == PPC_RELOC_HI16)
4325                 {
4326                     word = ((unsigned short*) wordPtr)[1] << 16;
4327                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4328                 }
4329                 else if(reloc->r_type == PPC_RELOC_HA16)
4330                 {
4331                     word = ((unsigned short*) wordPtr)[1] << 16;
4332                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4333                 }
4334                 else if(reloc->r_type == PPC_RELOC_BR24)
4335                 {
4336                     word = *wordPtr;
4337                     word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0);
4338                 }
4339 #endif
4340
4341                 if(!reloc->r_extern)
4342                 {
4343                     long delta =
4344                         sections[reloc->r_symbolnum-1].offset
4345                         - sections[reloc->r_symbolnum-1].addr
4346                         + ((long) image);
4347
4348                     word += delta;
4349                 }
4350                 else
4351                 {
4352                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
4353                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4354                     void *symbolAddress = lookupSymbol(nm);
4355                     if(!symbolAddress)
4356                     {
4357                         errorBelch("\nunknown symbol `%s'", nm);
4358                         return 0;
4359                     }
4360
4361                     if(reloc->r_pcrel)
4362                     {
4363 #ifdef powerpc_HOST_ARCH
4364                             // In the .o file, this should be a relative jump to NULL
4365                             // and we'll change it to a relative jump to the symbol
4366                         ASSERT(word + reloc->r_address == 0);
4367                         jumpIsland = (unsigned long)
4368                                         &makeSymbolExtra(oc,
4369                                                          reloc->r_symbolnum,
4370                                                          (unsigned long) symbolAddress)
4371                                          -> jumpIsland;
4372                         if(jumpIsland != 0)
4373                         {
4374                             offsetToJumpIsland = word + jumpIsland
4375                                 - (((long)image) + sect->offset - sect->addr);
4376                         }
4377 #endif
4378                         word += (unsigned long) symbolAddress
4379                                 - (((long)image) + sect->offset - sect->addr);
4380                     }
4381                     else
4382                     {
4383                         word += (unsigned long) symbolAddress;
4384                     }
4385                 }
4386
4387                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4388                 {
4389                     *wordPtr = word;
4390                     continue;
4391                 }
4392 #ifdef powerpc_HOST_ARCH
4393                 else if(reloc->r_type == PPC_RELOC_LO16)
4394                 {
4395                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4396                     i++; continue;
4397                 }
4398                 else if(reloc->r_type == PPC_RELOC_HI16)
4399                 {
4400                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4401                     i++; continue;
4402                 }
4403                 else if(reloc->r_type == PPC_RELOC_HA16)
4404                 {
4405                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4406                         + ((word & (1<<15)) ? 1 : 0);
4407                     i++; continue;
4408                 }
4409                 else if(reloc->r_type == PPC_RELOC_BR24)
4410                 {
4411                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4412                     {
4413                         // The branch offset is too large.
4414                         // Therefore, we try to use a jump island.
4415                         if(jumpIsland == 0)
4416                         {
4417                             barf("unconditional relative branch out of range: "
4418                                  "no jump island available");
4419                         }
4420
4421                         word = offsetToJumpIsland;
4422                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4423                             barf("unconditional relative branch out of range: "
4424                                  "jump island out of range");
4425                     }
4426                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
4427                     continue;
4428                 }
4429 #endif
4430             }
4431             barf("\nunknown relocation %d",reloc->r_type);
4432             return 0;
4433         }
4434 #endif
4435     }
4436     return 1;
4437 }
4438
4439 static int ocGetNames_MachO(ObjectCode* oc)
4440 {
4441     char *image = (char*) oc->image;
4442     struct mach_header *header = (struct mach_header*) image;
4443     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4444     unsigned i,curSymbol = 0;
4445     struct segment_command *segLC = NULL;
4446     struct section *sections;
4447     struct symtab_command *symLC = NULL;
4448     struct nlist *nlist;
4449     unsigned long commonSize = 0;
4450     char    *commonStorage = NULL;
4451     unsigned long commonCounter;
4452
4453     for(i=0;i<header->ncmds;i++)
4454     {
4455         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4456             segLC = (struct segment_command*) lc;
4457         else if(lc->cmd == LC_SYMTAB)
4458             symLC = (struct symtab_command*) lc;
4459         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4460     }
4461
4462     sections = (struct section*) (segLC+1);
4463     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4464                   : NULL;
4465
4466     if(!segLC)
4467         barf("ocGetNames_MachO: no segment load command");
4468
4469     for(i=0;i<segLC->nsects;i++)
4470     {
4471         if(sections[i].size == 0)
4472             continue;
4473
4474         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
4475         {
4476             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
4477                                       "ocGetNames_MachO(common symbols)");
4478             sections[i].offset = zeroFillArea - image;
4479         }
4480
4481         if(!strcmp(sections[i].sectname,"__text"))
4482             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
4483                 (void*) (image + sections[i].offset),
4484                 (void*) (image + sections[i].offset + sections[i].size));
4485         else if(!strcmp(sections[i].sectname,"__const"))
4486             addSection(oc, SECTIONKIND_RWDATA,
4487                 (void*) (image + sections[i].offset),
4488                 (void*) (image + sections[i].offset + sections[i].size));
4489         else if(!strcmp(sections[i].sectname,"__data"))
4490             addSection(oc, SECTIONKIND_RWDATA,
4491                 (void*) (image + sections[i].offset),
4492                 (void*) (image + sections[i].offset + sections[i].size));
4493         else if(!strcmp(sections[i].sectname,"__bss")
4494                 || !strcmp(sections[i].sectname,"__common"))
4495             addSection(oc, SECTIONKIND_RWDATA,
4496                 (void*) (image + sections[i].offset),
4497                 (void*) (image + sections[i].offset + sections[i].size));
4498
4499         addProddableBlock(oc, (void*) (image + sections[i].offset),
4500                                         sections[i].size);
4501     }
4502
4503         // count external symbols defined here
4504     oc->n_symbols = 0;
4505     if(symLC)
4506     {
4507         for(i=0;i<symLC->nsyms;i++)
4508         {
4509             if(nlist[i].n_type & N_STAB)
4510                 ;
4511             else if(nlist[i].n_type & N_EXT)
4512             {
4513                 if((nlist[i].n_type & N_TYPE) == N_UNDF
4514                     && (nlist[i].n_value != 0))
4515                 {
4516                     commonSize += nlist[i].n_value;
4517                     oc->n_symbols++;
4518                 }
4519                 else if((nlist[i].n_type & N_TYPE) == N_SECT)
4520                     oc->n_symbols++;
4521             }
4522         }
4523     }
4524     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
4525                                    "ocGetNames_MachO(oc->symbols)");
4526
4527     if(symLC)
4528     {
4529         for(i=0;i<symLC->nsyms;i++)
4530         {
4531             if(nlist[i].n_type & N_STAB)
4532                 ;
4533             else if((nlist[i].n_type & N_TYPE) == N_SECT)
4534             {
4535                 if(nlist[i].n_type & N_EXT)
4536                 {
4537                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4538                     if((nlist[i].n_desc & N_WEAK_DEF) && lookupSymbol(nm))
4539                         ; // weak definition, and we already have a definition
4540                     else
4541                     {
4542                             ghciInsertStrHashTable(oc->fileName, symhash, nm,
4543                                                     image
4544                                                     + sections[nlist[i].n_sect-1].offset
4545                                                     - sections[nlist[i].n_sect-1].addr
4546                                                     + nlist[i].n_value);
4547                             oc->symbols[curSymbol++] = nm;
4548                     }
4549                 }
4550             }
4551         }
4552     }
4553
4554     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
4555     commonCounter = (unsigned long)commonStorage;
4556     if(symLC)
4557     {
4558         for(i=0;i<symLC->nsyms;i++)
4559         {
4560             if((nlist[i].n_type & N_TYPE) == N_UNDF
4561                     && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
4562             {
4563                 char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4564                 unsigned long sz = nlist[i].n_value;
4565
4566                 nlist[i].n_value = commonCounter;
4567
4568                 ghciInsertStrHashTable(oc->fileName, symhash, nm,
4569                                        (void*)commonCounter);
4570                 oc->symbols[curSymbol++] = nm;
4571
4572                 commonCounter += sz;
4573             }
4574         }
4575     }
4576     return 1;
4577 }
4578
4579 static int ocResolve_MachO(ObjectCode* oc)
4580 {
4581     char *image = (char*) oc->image;
4582     struct mach_header *header = (struct mach_header*) image;
4583     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4584     unsigned i;
4585     struct segment_command *segLC = NULL;
4586     struct section *sections;
4587     struct symtab_command *symLC = NULL;
4588     struct dysymtab_command *dsymLC = NULL;
4589     struct nlist *nlist;
4590
4591     for(i=0;i<header->ncmds;i++)
4592     {
4593         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4594             segLC = (struct segment_command*) lc;
4595         else if(lc->cmd == LC_SYMTAB)
4596             symLC = (struct symtab_command*) lc;
4597         else if(lc->cmd == LC_DYSYMTAB)
4598             dsymLC = (struct dysymtab_command*) lc;
4599         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4600     }
4601
4602     sections = (struct section*) (segLC+1);
4603     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4604                   : NULL;
4605
4606     if(dsymLC)
4607     {
4608         unsigned long *indirectSyms
4609             = (unsigned long*) (image + dsymLC->indirectsymoff);
4610
4611         for(i=0;i<segLC->nsects;i++)
4612         {
4613             if(    !strcmp(sections[i].sectname,"__la_symbol_ptr")
4614                 || !strcmp(sections[i].sectname,"__la_sym_ptr2")
4615                 || !strcmp(sections[i].sectname,"__la_sym_ptr3"))
4616             {
4617                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4618                     return 0;
4619             }
4620             else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr")
4621                 ||  !strcmp(sections[i].sectname,"__pointers"))
4622             {
4623                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4624                     return 0;
4625             }
4626             else if(!strcmp(sections[i].sectname,"__jump_table"))
4627             {
4628                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4629                     return 0;
4630             }
4631         }
4632     }
4633
4634     for(i=0;i<segLC->nsects;i++)
4635     {
4636         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
4637             return 0;
4638     }
4639
4640 #if defined (powerpc_HOST_ARCH)
4641     ocFlushInstructionCache( oc );
4642 #endif
4643
4644     return 1;
4645 }
4646
4647 #ifdef powerpc_HOST_ARCH
4648 /*
4649  * The Mach-O object format uses leading underscores. But not everywhere.
4650  * There is a small number of runtime support functions defined in
4651  * libcc_dynamic.a whose name does not have a leading underscore.
4652  * As a consequence, we can't get their address from C code.
4653  * We have to use inline assembler just to take the address of a function.
4654  * Yuck.
4655  */
4656
4657 static void machoInitSymbolsWithoutUnderscore()
4658 {
4659     extern void* symbolsWithoutUnderscore[];
4660     void **p = symbolsWithoutUnderscore;
4661     __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:");
4662
4663 #undef SymI_NeedsProto
4664 #define SymI_NeedsProto(x)  \
4665     __asm__ volatile(".long " # x);
4666
4667     RTS_MACHO_NOUNDERLINE_SYMBOLS
4668
4669     __asm__ volatile(".text");
4670
4671 #undef SymI_NeedsProto
4672 #define SymI_NeedsProto(x)  \
4673     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
4674
4675     RTS_MACHO_NOUNDERLINE_SYMBOLS
4676
4677 #undef SymI_NeedsProto
4678 }
4679 #endif
4680
4681 /*
4682  * Figure out by how much to shift the entire Mach-O file in memory
4683  * when loading so that its single segment ends up 16-byte-aligned
4684  */
4685 static int machoGetMisalignment( FILE * f )
4686 {
4687     struct mach_header header;
4688     int misalignment;
4689
4690     fread(&header, sizeof(header), 1, f);
4691     rewind(f);
4692
4693 #if x86_64_TARGET_ARCH || powerpc64_TARGET_ARCH
4694     if(header.magic != MH_MAGIC_64)
4695         return 0;
4696 #else
4697     if(header.magic != MH_MAGIC)
4698         return 0;
4699 #endif
4700
4701     misalignment = (header.sizeofcmds + sizeof(header))
4702                     & 0xF;
4703
4704     return misalignment ? (16 - misalignment) : 0;
4705 }
4706
4707 #endif
4708