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