rts/Linker.c

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