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
1468    /* load the image into memory */
1469    f = fopen(path, "rb");
1470    if (!f)
1471        barf("loadObj: can't read `%s'", path);
1472
1473 #   if defined(mingw32_HOST_OS)
1474         // TODO: We would like to use allocateExec here, but allocateExec
1475         //       cannot currently allocate blocks large enough.
1476     oc->image = VirtualAlloc(NULL, oc->fileSize, MEM_RESERVE | MEM_COMMIT,
1477                              PAGE_EXECUTE_READWRITE);
1478 #   elif defined(darwin_HOST_OS)
1479     // In a Mach-O .o file, all sections can and will be misaligned
1480     // if the total size of the headers is not a multiple of the
1481     // desired alignment. This is fine for .o files that only serve
1482     // as input for the static linker, but it's not fine for us,
1483     // as SSE (used by gcc for floating point) and Altivec require
1484     // 16-byte alignment.
1485     // We calculate the correct alignment from the header before
1486     // reading the file, and then we misalign oc->image on purpose so
1487     // that the actual sections end up aligned again.
1488    oc->misalignment = machoGetMisalignment(f);
1489    oc->image = stgMallocBytes(oc->fileSize + oc->misalignment, "loadObj(image)");
1490    oc->image += oc->misalignment;
1491 #  else
1492    oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)");
1493 #  endif
1494
1495    n = fread ( oc->image, 1, oc->fileSize, f );
1496    if (n != oc->fileSize)
1497       barf("loadObj: error whilst reading `%s'", path);
1498
1499    fclose(f);
1500 #endif /* USE_MMAP */
1501
1502 #  if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1503    r = ocAllocateSymbolExtras_MachO ( oc );
1504    if (!r) { return r; }
1505 #  elif defined(OBJFORMAT_ELF) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1506    r = ocAllocateSymbolExtras_ELF ( oc );
1507    if (!r) { return r; }
1508 #endif
1509
1510    /* verify the in-memory image */
1511 #  if defined(OBJFORMAT_ELF)
1512    r = ocVerifyImage_ELF ( oc );
1513 #  elif defined(OBJFORMAT_PEi386)
1514    r = ocVerifyImage_PEi386 ( oc );
1515 #  elif defined(OBJFORMAT_MACHO)
1516    r = ocVerifyImage_MachO ( oc );
1517 #  else
1518    barf("loadObj: no verify method");
1519 #  endif
1520    if (!r) { return r; }
1521
1522    /* build the symbol list for this image */
1523 #  if defined(OBJFORMAT_ELF)
1524    r = ocGetNames_ELF ( oc );
1525 #  elif defined(OBJFORMAT_PEi386)
1526    r = ocGetNames_PEi386 ( oc );
1527 #  elif defined(OBJFORMAT_MACHO)
1528    r = ocGetNames_MachO ( oc );
1529 #  else
1530    barf("loadObj: no getNames method");
1531 #  endif
1532    if (!r) { return r; }
1533
1534    /* loaded, but not resolved yet */
1535    oc->status = OBJECT_LOADED;
1536
1537    return 1;
1538 }
1539
1540 /* -----------------------------------------------------------------------------
1541  * resolve all the currently unlinked objects in memory
1542  *
1543  * Returns: 1 if ok, 0 on error.
1544  */
1545 HsInt
1546 resolveObjs( void )
1547 {
1548     ObjectCode *oc;
1549     int r;
1550
1551     initLinker();
1552
1553     for (oc = objects; oc; oc = oc->next) {
1554         if (oc->status != OBJECT_RESOLVED) {
1555 #           if defined(OBJFORMAT_ELF)
1556             r = ocResolve_ELF ( oc );
1557 #           elif defined(OBJFORMAT_PEi386)
1558             r = ocResolve_PEi386 ( oc );
1559 #           elif defined(OBJFORMAT_MACHO)
1560             r = ocResolve_MachO ( oc );
1561 #           else
1562             barf("resolveObjs: not implemented on this platform");
1563 #           endif
1564             if (!r) { return r; }
1565             oc->status = OBJECT_RESOLVED;
1566         }
1567     }
1568     return 1;
1569 }
1570
1571 /* -----------------------------------------------------------------------------
1572  * delete an object from the pool
1573  */
1574 HsInt
1575 unloadObj( char *path )
1576 {
1577     ObjectCode *oc, *prev;
1578
1579     ASSERT(symhash != NULL);
1580     ASSERT(objects != NULL);
1581
1582     initLinker();
1583
1584     prev = NULL;
1585     for (oc = objects; oc; prev = oc, oc = oc->next) {
1586         if (!strcmp(oc->fileName,path)) {
1587
1588             /* Remove all the mappings for the symbols within this
1589              * object..
1590              */
1591             {
1592                 int i;
1593                 for (i = 0; i < oc->n_symbols; i++) {
1594                    if (oc->symbols[i] != NULL) {
1595                        removeStrHashTable(symhash, oc->symbols[i], NULL);
1596                    }
1597                 }
1598             }
1599
1600             if (prev == NULL) {
1601                 objects = oc->next;
1602             } else {
1603                 prev->next = oc->next;
1604             }
1605
1606             // We're going to leave this in place, in case there are
1607             // any pointers from the heap into it:
1608                 // #ifdef mingw32_HOST_OS
1609                 //  VirtualFree(oc->image);
1610                 // #else
1611             //  stgFree(oc->image);
1612             // #endif
1613             stgFree(oc->fileName);
1614             stgFree(oc->symbols);
1615             stgFree(oc->sections);
1616             stgFree(oc);
1617             return 1;
1618         }
1619     }
1620
1621     errorBelch("unloadObj: can't find `%s' to unload", path);
1622     return 0;
1623 }
1624
1625 /* -----------------------------------------------------------------------------
1626  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
1627  * which may be prodded during relocation, and abort if we try and write
1628  * outside any of these.
1629  */
1630 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
1631 {
1632    ProddableBlock* pb
1633       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
1634    /* debugBelch("aPB %p %p %d\n", oc, start, size); */
1635    ASSERT(size > 0);
1636    pb->start      = start;
1637    pb->size       = size;
1638    pb->next       = oc->proddables;
1639    oc->proddables = pb;
1640 }
1641
1642 static void checkProddableBlock ( ObjectCode* oc, void* addr )
1643 {
1644    ProddableBlock* pb;
1645    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
1646       char* s = (char*)(pb->start);
1647       char* e = s + pb->size - 1;
1648       char* a = (char*)addr;
1649       /* Assumes that the biggest fixup involves a 4-byte write.  This
1650          probably needs to be changed to 8 (ie, +7) on 64-bit
1651          plats. */
1652       if (a >= s && (a+3) <= e) return;
1653    }
1654    barf("checkProddableBlock: invalid fixup in runtime linker");
1655 }
1656
1657 /* -----------------------------------------------------------------------------
1658  * Section management.
1659  */
1660 static void addSection ( ObjectCode* oc, SectionKind kind,
1661                          void* start, void* end )
1662 {
1663    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
1664    s->start     = start;
1665    s->end       = end;
1666    s->kind      = kind;
1667    s->next      = oc->sections;
1668    oc->sections = s;
1669    /*
1670    debugBelch("addSection: %p-%p (size %d), kind %d\n",
1671                    start, ((char*)end)-1, end - start + 1, kind );
1672    */
1673 }
1674
1675
1676 /* --------------------------------------------------------------------------
1677  * Symbol Extras.
1678  * This is about allocating a small chunk of memory for every symbol in the
1679  * object file. We make sure that the SymboLExtras are always "in range" of
1680  * limited-range PC-relative instructions on various platforms by allocating
1681  * them right next to the object code itself.
1682  */
1683
1684 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
1685
1686 /*
1687   ocAllocateSymbolExtras
1688
1689   Allocate additional space at the end of the object file image to make room
1690   for jump islands (powerpc, x86_64) and GOT entries (x86_64).
1691
1692   PowerPC relative branch instructions have a 24 bit displacement field.
1693   As PPC code is always 4-byte-aligned, this yields a +-32MB range.
1694   If a particular imported symbol is outside this range, we have to redirect
1695   the jump to a short piece of new code that just loads the 32bit absolute
1696   address and jumps there.
1697   On x86_64, PC-relative jumps and PC-relative accesses to the GOT are limited
1698   to 32 bits (+-2GB).
1699
1700   This function just allocates space for one SymbolExtra for every
1701   undefined symbol in the object file. The code for the jump islands is
1702   filled in by makeSymbolExtra below.
1703 */
1704
1705 static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first )
1706 {
1707 #ifdef USE_MMAP
1708   int pagesize, n, m;
1709 #endif
1710   int aligned;
1711 #ifndef USE_MMAP
1712   int misalignment = 0;
1713 #ifdef darwin_HOST_OS
1714   misalignment = oc->misalignment;
1715 #endif
1716 #endif
1717
1718   if( count > 0 )
1719   {
1720     // round up to the nearest 4
1721     aligned = (oc->fileSize + 3) & ~3;
1722
1723 #ifdef USE_MMAP
1724     pagesize = getpagesize();
1725     n = ROUND_UP( oc->fileSize, pagesize );
1726     m = ROUND_UP( aligned + sizeof (SymbolExtra) * count, pagesize );
1727
1728     /* we try to use spare space at the end of the last page of the
1729      * image for the jump islands, but if there isn't enough space
1730      * then we have to map some (anonymously, remembering MAP_32BIT).
1731      */
1732     if( m > n ) // we need to allocate more pages
1733     {
1734         oc->symbol_extras = mmapForLinker(sizeof(SymbolExtra) * count,
1735                                           MAP_ANONYMOUS, 0);
1736     }
1737     else
1738     {
1739         oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
1740     }
1741 #else
1742     oc->image -= misalignment;
1743     oc->image = stgReallocBytes( oc->image,
1744                                  misalignment +
1745                                  aligned + sizeof (SymbolExtra) * count,
1746                                  "ocAllocateSymbolExtras" );
1747     oc->image += misalignment;
1748
1749     oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
1750 #endif /* USE_MMAP */
1751
1752     memset( oc->symbol_extras, 0, sizeof (SymbolExtra) * count );
1753   }
1754   else
1755     oc->symbol_extras = NULL;
1756
1757   oc->first_symbol_extra = first;
1758   oc->n_symbol_extras = count;
1759
1760   return 1;
1761 }
1762
1763 static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
1764                                      unsigned long symbolNumber,
1765                                      unsigned long target )
1766 {
1767   SymbolExtra *extra;
1768
1769   ASSERT( symbolNumber >= oc->first_symbol_extra
1770         && symbolNumber - oc->first_symbol_extra < oc->n_symbol_extras);
1771
1772   extra = &oc->symbol_extras[symbolNumber - oc->first_symbol_extra];
1773
1774 #ifdef powerpc_HOST_ARCH
1775   // lis r12, hi16(target)
1776   extra->jumpIsland.lis_r12     = 0x3d80;
1777   extra->jumpIsland.hi_addr     = target >> 16;
1778
1779   // ori r12, r12, lo16(target)
1780   extra->jumpIsland.ori_r12_r12 = 0x618c;
1781   extra->jumpIsland.lo_addr     = target & 0xffff;
1782
1783   // mtctr r12
1784   extra->jumpIsland.mtctr_r12   = 0x7d8903a6;
1785
1786   // bctr
1787   extra->jumpIsland.bctr        = 0x4e800420;
1788 #endif
1789 #ifdef x86_64_HOST_ARCH
1790         // jmp *-14(%rip)
1791   static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
1792   extra->addr = target;
1793   memcpy(extra->jumpIsland, jmp, 6);
1794 #endif
1795
1796   return extra;
1797 }
1798
1799 #endif
1800
1801 /* --------------------------------------------------------------------------
1802  * PowerPC specifics (instruction cache flushing)
1803  * ------------------------------------------------------------------------*/
1804
1805 #ifdef powerpc_TARGET_ARCH
1806 /*
1807    ocFlushInstructionCache
1808
1809    Flush the data & instruction caches.
1810    Because the PPC has split data/instruction caches, we have to
1811    do that whenever we modify code at runtime.
1812  */
1813
1814 static void ocFlushInstructionCache( ObjectCode *oc )
1815 {
1816     int n = (oc->fileSize + sizeof( SymbolExtra ) * oc->n_symbol_extras + 3) / 4;
1817     unsigned long *p = (unsigned long *) oc->image;
1818
1819     while( n-- )
1820     {
1821         __asm__ volatile ( "dcbf 0,%0\n\t"
1822                            "sync\n\t"
1823                            "icbi 0,%0"
1824                            :
1825                            : "r" (p)
1826                          );
1827         p++;
1828     }
1829     __asm__ volatile ( "sync\n\t"
1830                        "isync"
1831                      );
1832 }
1833 #endif
1834
1835 /* --------------------------------------------------------------------------
1836  * PEi386 specifics (Win32 targets)
1837  * ------------------------------------------------------------------------*/
1838
1839 /* The information for this linker comes from
1840       Microsoft Portable Executable
1841       and Common Object File Format Specification
1842       revision 5.1 January 1998
1843    which SimonM says comes from the MS Developer Network CDs.
1844
1845    It can be found there (on older CDs), but can also be found
1846    online at:
1847
1848       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
1849
1850    (this is Rev 6.0 from February 1999).
1851
1852    Things move, so if that fails, try searching for it via
1853
1854       http://www.google.com/search?q=PE+COFF+specification
1855
1856    The ultimate reference for the PE format is the Winnt.h
1857    header file that comes with the Platform SDKs; as always,
1858    implementations will drift wrt their documentation.
1859
1860    A good background article on the PE format is Matt Pietrek's
1861    March 1994 article in Microsoft System Journal (MSJ)
1862    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
1863    Win32 Portable Executable File Format." The info in there
1864    has recently been updated in a two part article in
1865    MSDN magazine, issues Feb and March 2002,
1866    "Inside Windows: An In-Depth Look into the Win32 Portable
1867    Executable File Format"
1868
1869    John Levine's book "Linkers and Loaders" contains useful
1870    info on PE too.
1871 */
1872
1873
1874 #if defined(OBJFORMAT_PEi386)
1875
1876
1877
1878 typedef unsigned char  UChar;
1879 typedef unsigned short UInt16;
1880 typedef unsigned int   UInt32;
1881 typedef          int   Int32;
1882
1883
1884 typedef
1885    struct {
1886       UInt16 Machine;
1887       UInt16 NumberOfSections;
1888       UInt32 TimeDateStamp;
1889       UInt32 PointerToSymbolTable;
1890       UInt32 NumberOfSymbols;
1891       UInt16 SizeOfOptionalHeader;
1892       UInt16 Characteristics;
1893    }
1894    COFF_header;
1895
1896 #define sizeof_COFF_header 20
1897
1898
1899 typedef
1900    struct {
1901       UChar  Name[8];
1902       UInt32 VirtualSize;
1903       UInt32 VirtualAddress;
1904       UInt32 SizeOfRawData;
1905       UInt32 PointerToRawData;
1906       UInt32 PointerToRelocations;
1907       UInt32 PointerToLinenumbers;
1908       UInt16 NumberOfRelocations;
1909       UInt16 NumberOfLineNumbers;
1910       UInt32 Characteristics;
1911    }
1912    COFF_section;
1913
1914 #define sizeof_COFF_section 40
1915
1916
1917 typedef
1918    struct {
1919       UChar  Name[8];
1920       UInt32 Value;
1921       UInt16 SectionNumber;
1922       UInt16 Type;
1923       UChar  StorageClass;
1924       UChar  NumberOfAuxSymbols;
1925    }
1926    COFF_symbol;
1927
1928 #define sizeof_COFF_symbol 18
1929
1930
1931 typedef
1932    struct {
1933       UInt32 VirtualAddress;
1934       UInt32 SymbolTableIndex;
1935       UInt16 Type;
1936    }
1937    COFF_reloc;
1938
1939 #define sizeof_COFF_reloc 10
1940
1941
1942 /* From PE spec doc, section 3.3.2 */
1943 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
1944    windows.h -- for the same purpose, but I want to know what I'm
1945    getting, here. */
1946 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
1947 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
1948 #define MYIMAGE_FILE_DLL                 0x2000
1949 #define MYIMAGE_FILE_SYSTEM              0x1000
1950 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
1951 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
1952 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
1953
1954 /* From PE spec doc, section 5.4.2 and 5.4.4 */
1955 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
1956 #define MYIMAGE_SYM_CLASS_STATIC         3
1957 #define MYIMAGE_SYM_UNDEFINED            0
1958
1959 /* From PE spec doc, section 4.1 */
1960 #define MYIMAGE_SCN_CNT_CODE             0x00000020
1961 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
1962 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
1963
1964 /* From PE spec doc, section 5.2.1 */
1965 #define MYIMAGE_REL_I386_DIR32           0x0006
1966 #define MYIMAGE_REL_I386_REL32           0x0014
1967
1968
1969 /* We use myindex to calculate array addresses, rather than
1970    simply doing the normal subscript thing.  That's because
1971    some of the above structs have sizes which are not
1972    a whole number of words.  GCC rounds their sizes up to a
1973    whole number of words, which means that the address calcs
1974    arising from using normal C indexing or pointer arithmetic
1975    are just plain wrong.  Sigh.
1976 */
1977 static UChar *
1978 myindex ( int scale, void* base, int index )
1979 {
1980    return
1981       ((UChar*)base) + scale * index;
1982 }
1983
1984
1985 static void
1986 printName ( UChar* name, UChar* strtab )
1987 {
1988    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1989       UInt32 strtab_offset = * (UInt32*)(name+4);
1990       debugBelch("%s", strtab + strtab_offset );
1991    } else {
1992       int i;
1993       for (i = 0; i < 8; i++) {
1994          if (name[i] == 0) break;
1995          debugBelch("%c", name[i] );
1996       }
1997    }
1998 }
1999
2000
2001 static void
2002 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
2003 {
2004    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2005       UInt32 strtab_offset = * (UInt32*)(name+4);
2006       strncpy ( dst, strtab+strtab_offset, dstSize );
2007       dst[dstSize-1] = 0;
2008    } else {
2009       int i = 0;
2010       while (1) {
2011          if (i >= 8) break;
2012          if (name[i] == 0) break;
2013          dst[i] = name[i];
2014          i++;
2015       }
2016       dst[i] = 0;
2017    }
2018 }
2019
2020
2021 static UChar *
2022 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
2023 {
2024    UChar* newstr;
2025    /* If the string is longer than 8 bytes, look in the
2026       string table for it -- this will be correctly zero terminated.
2027    */
2028    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2029       UInt32 strtab_offset = * (UInt32*)(name+4);
2030       return ((UChar*)strtab) + strtab_offset;
2031    }
2032    /* Otherwise, if shorter than 8 bytes, return the original,
2033       which by defn is correctly terminated.
2034    */
2035    if (name[7]==0) return name;
2036    /* The annoying case: 8 bytes.  Copy into a temporary
2037       (which is never freed ...)
2038    */
2039    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
2040    ASSERT(newstr);
2041    strncpy(newstr,name,8);
2042    newstr[8] = 0;
2043    return newstr;
2044 }
2045
2046
2047 /* Just compares the short names (first 8 chars) */
2048 static COFF_section *
2049 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
2050 {
2051    int i;
2052    COFF_header* hdr
2053       = (COFF_header*)(oc->image);
2054    COFF_section* sectab
2055       = (COFF_section*) (
2056            ((UChar*)(oc->image))
2057            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2058         );
2059    for (i = 0; i < hdr->NumberOfSections; i++) {
2060       UChar* n1;
2061       UChar* n2;
2062       COFF_section* section_i
2063          = (COFF_section*)
2064            myindex ( sizeof_COFF_section, sectab, i );
2065       n1 = (UChar*) &(section_i->Name);
2066       n2 = name;
2067       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
2068           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
2069           n1[6]==n2[6] && n1[7]==n2[7])
2070          return section_i;
2071    }
2072
2073    return NULL;
2074 }
2075
2076
2077 static void
2078 zapTrailingAtSign ( UChar* sym )
2079 {
2080 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
2081    int i, j;
2082    if (sym[0] == 0) return;
2083    i = 0;
2084    while (sym[i] != 0) i++;
2085    i--;
2086    j = i;
2087    while (j > 0 && my_isdigit(sym[j])) j--;
2088    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
2089 #  undef my_isdigit
2090 }
2091
2092 static void *
2093 lookupSymbolInDLLs ( UChar *lbl )
2094 {
2095     OpenedDLL* o_dll;
2096     void *sym;
2097
2098     for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
2099         /* debugBelch("look in %s for %s\n", o_dll->name, lbl); */
2100
2101         if (lbl[0] == '_') {
2102             /* HACK: if the name has an initial underscore, try stripping
2103                it off & look that up first. I've yet to verify whether there's
2104                a Rule that governs whether an initial '_' *should always* be
2105                stripped off when mapping from import lib name to the DLL name.
2106             */
2107             sym = GetProcAddress(o_dll->instance, (lbl+1));
2108             if (sym != NULL) {
2109                 /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
2110                 return sym;
2111             }
2112         }
2113         sym = GetProcAddress(o_dll->instance, lbl);
2114         if (sym != NULL) {
2115             /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
2116             return sym;
2117            }
2118     }
2119     return NULL;
2120 }
2121
2122
2123 static int
2124 ocVerifyImage_PEi386 ( ObjectCode* oc )
2125 {
2126    int i;
2127    UInt32 j, noRelocs;
2128    COFF_header*  hdr;
2129    COFF_section* sectab;
2130    COFF_symbol*  symtab;
2131    UChar*        strtab;
2132    /* debugBelch("\nLOADING %s\n", oc->fileName); */
2133    hdr = (COFF_header*)(oc->image);
2134    sectab = (COFF_section*) (
2135                ((UChar*)(oc->image))
2136                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2137             );
2138    symtab = (COFF_symbol*) (
2139                ((UChar*)(oc->image))
2140                + hdr->PointerToSymbolTable
2141             );
2142    strtab = ((UChar*)symtab)
2143             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2144
2145    if (hdr->Machine != 0x14c) {
2146       errorBelch("%s: Not x86 PEi386", oc->fileName);
2147       return 0;
2148    }
2149    if (hdr->SizeOfOptionalHeader != 0) {
2150       errorBelch("%s: PEi386 with nonempty optional header", oc->fileName);
2151       return 0;
2152    }
2153    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
2154         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
2155         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
2156         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
2157       errorBelch("%s: Not a PEi386 object file", oc->fileName);
2158       return 0;
2159    }
2160    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
2161         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
2162       errorBelch("%s: Invalid PEi386 word size or endiannness: %d",
2163                  oc->fileName,
2164                  (int)(hdr->Characteristics));
2165       return 0;
2166    }
2167    /* If the string table size is way crazy, this might indicate that
2168       there are more than 64k relocations, despite claims to the
2169       contrary.  Hence this test. */
2170    /* debugBelch("strtab size %d\n", * (UInt32*)strtab); */
2171 #if 0
2172    if ( (*(UInt32*)strtab) > 600000 ) {
2173       /* Note that 600k has no special significance other than being
2174          big enough to handle the almost-2MB-sized lumps that
2175          constitute HSwin32*.o. */
2176       debugBelch("PEi386 object has suspiciously large string table; > 64k relocs?");
2177       return 0;
2178    }
2179 #endif
2180
2181    /* No further verification after this point; only debug printing. */
2182    i = 0;
2183    IF_DEBUG(linker, i=1);
2184    if (i == 0) return 1;
2185
2186    debugBelch( "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
2187    debugBelch( "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
2188    debugBelch( "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
2189
2190    debugBelch("\n" );
2191    debugBelch( "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
2192    debugBelch( "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
2193    debugBelch( "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
2194    debugBelch( "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
2195    debugBelch( "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
2196    debugBelch( "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
2197    debugBelch( "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
2198
2199    /* Print the section table. */
2200    debugBelch("\n" );
2201    for (i = 0; i < hdr->NumberOfSections; i++) {
2202       COFF_reloc* reltab;
2203       COFF_section* sectab_i
2204          = (COFF_section*)
2205            myindex ( sizeof_COFF_section, sectab, i );
2206       debugBelch(
2207                 "\n"
2208                 "section %d\n"
2209                 "     name `",
2210                 i
2211               );
2212       printName ( sectab_i->Name, strtab );
2213       debugBelch(
2214                 "'\n"
2215                 "    vsize %d\n"
2216                 "    vaddr %d\n"
2217                 "  data sz %d\n"
2218                 " data off %d\n"
2219                 "  num rel %d\n"
2220                 "  off rel %d\n"
2221                 "  ptr raw 0x%x\n",
2222                 sectab_i->VirtualSize,
2223                 sectab_i->VirtualAddress,
2224                 sectab_i->SizeOfRawData,
2225                 sectab_i->PointerToRawData,
2226                 sectab_i->NumberOfRelocations,
2227                 sectab_i->PointerToRelocations,
2228                 sectab_i->PointerToRawData
2229               );
2230       reltab = (COFF_reloc*) (
2231                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2232                );
2233
2234       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2235         /* If the relocation field (a short) has overflowed, the
2236          * real count can be found in the first reloc entry.
2237          *
2238          * See Section 4.1 (last para) of the PE spec (rev6.0).
2239          */
2240         COFF_reloc* rel = (COFF_reloc*)
2241                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2242         noRelocs = rel->VirtualAddress;
2243         j = 1;
2244       } else {
2245         noRelocs = sectab_i->NumberOfRelocations;
2246         j = 0;
2247       }
2248
2249       for (; j < noRelocs; j++) {
2250          COFF_symbol* sym;
2251          COFF_reloc* rel = (COFF_reloc*)
2252                            myindex ( sizeof_COFF_reloc, reltab, j );
2253          debugBelch(
2254                    "        type 0x%-4x   vaddr 0x%-8x   name `",
2255                    (UInt32)rel->Type,
2256                    rel->VirtualAddress );
2257          sym = (COFF_symbol*)
2258                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
2259          /* Hmm..mysterious looking offset - what's it for? SOF */
2260          printName ( sym->Name, strtab -10 );
2261          debugBelch("'\n" );
2262       }
2263
2264       debugBelch("\n" );
2265    }
2266    debugBelch("\n" );
2267    debugBelch("string table has size 0x%x\n", * (UInt32*)strtab );
2268    debugBelch("---START of string table---\n");
2269    for (i = 4; i < *(Int32*)strtab; i++) {
2270       if (strtab[i] == 0)
2271          debugBelch("\n"); else
2272          debugBelch("%c", strtab[i] );
2273    }
2274    debugBelch("--- END  of string table---\n");
2275
2276    debugBelch("\n" );
2277    i = 0;
2278    while (1) {
2279       COFF_symbol* symtab_i;
2280       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2281       symtab_i = (COFF_symbol*)
2282                  myindex ( sizeof_COFF_symbol, symtab, i );
2283       debugBelch(
2284                 "symbol %d\n"
2285                 "     name `",
2286                 i
2287               );
2288       printName ( symtab_i->Name, strtab );
2289       debugBelch(
2290                 "'\n"
2291                 "    value 0x%x\n"
2292                 "   1+sec# %d\n"
2293                 "     type 0x%x\n"
2294                 "   sclass 0x%x\n"
2295                 "     nAux %d\n",
2296                 symtab_i->Value,
2297                 (Int32)(symtab_i->SectionNumber),
2298                 (UInt32)symtab_i->Type,
2299                 (UInt32)symtab_i->StorageClass,
2300                 (UInt32)symtab_i->NumberOfAuxSymbols
2301               );
2302       i += symtab_i->NumberOfAuxSymbols;
2303       i++;
2304    }
2305
2306    debugBelch("\n" );
2307    return 1;
2308 }
2309
2310
2311 static int
2312 ocGetNames_PEi386 ( ObjectCode* oc )
2313 {
2314    COFF_header*  hdr;
2315    COFF_section* sectab;
2316    COFF_symbol*  symtab;
2317    UChar*        strtab;
2318
2319    UChar* sname;
2320    void*  addr;
2321    int    i;
2322
2323    hdr = (COFF_header*)(oc->image);
2324    sectab = (COFF_section*) (
2325                ((UChar*)(oc->image))
2326                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2327             );
2328    symtab = (COFF_symbol*) (
2329                ((UChar*)(oc->image))
2330                + hdr->PointerToSymbolTable
2331             );
2332    strtab = ((UChar*)(oc->image))
2333             + hdr->PointerToSymbolTable
2334             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2335
2336    /* Allocate space for any (local, anonymous) .bss sections. */
2337
2338    for (i = 0; i < hdr->NumberOfSections; i++) {
2339       UInt32 bss_sz;
2340       UChar* zspace;
2341       COFF_section* sectab_i
2342          = (COFF_section*)
2343            myindex ( sizeof_COFF_section, sectab, i );
2344       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
2345       /* sof 10/05: the PE spec text isn't too clear regarding what
2346        * the SizeOfRawData field is supposed to hold for object
2347        * file sections containing just uninitialized data -- for executables,
2348        * it is supposed to be zero; unclear what it's supposed to be
2349        * for object files. However, VirtualSize is guaranteed to be
2350        * zero for object files, which definitely suggests that SizeOfRawData
2351        * will be non-zero (where else would the size of this .bss section be
2352        * stored?) Looking at the COFF_section info for incoming object files,
2353        * this certainly appears to be the case.
2354        *
2355        * => I suspect we've been incorrectly handling .bss sections in (relocatable)
2356        * object files up until now. This turned out to bite us with ghc-6.4.1's use
2357        * of gcc-3.4.x, which has started to emit initially-zeroed-out local 'static'
2358        * variable decls into to the .bss section. (The specific function in Q which
2359        * triggered this is libraries/base/cbits/dirUtils.c:__hscore_getFolderPath())
2360        */
2361       if (sectab_i->VirtualSize == 0 && sectab_i->SizeOfRawData == 0) continue;
2362       /* This is a non-empty .bss section.  Allocate zeroed space for
2363          it, and set its PointerToRawData field such that oc->image +
2364          PointerToRawData == addr_of_zeroed_space.  */
2365       bss_sz = sectab_i->VirtualSize;
2366       if ( bss_sz < sectab_i->SizeOfRawData) { bss_sz = sectab_i->SizeOfRawData; }
2367       zspace = stgCallocBytes(1, bss_sz, "ocGetNames_PEi386(anonymous bss)");
2368       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
2369       addProddableBlock(oc, zspace, bss_sz);
2370       /* debugBelch("BSS anon section at 0x%x\n", zspace); */
2371    }
2372
2373    /* Copy section information into the ObjectCode. */
2374
2375    for (i = 0; i < hdr->NumberOfSections; i++) {
2376       UChar* start;
2377       UChar* end;
2378       UInt32 sz;
2379
2380       SectionKind kind
2381          = SECTIONKIND_OTHER;
2382       COFF_section* sectab_i
2383          = (COFF_section*)
2384            myindex ( sizeof_COFF_section, sectab, i );
2385       IF_DEBUG(linker, debugBelch("section name = %s\n", sectab_i->Name ));
2386
2387 #     if 0
2388       /* I'm sure this is the Right Way to do it.  However, the
2389          alternative of testing the sectab_i->Name field seems to
2390          work ok with Cygwin.
2391       */
2392       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
2393           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
2394          kind = SECTIONKIND_CODE_OR_RODATA;
2395 #     endif
2396
2397       if (0==strcmp(".text",sectab_i->Name) ||
2398           0==strcmp(".rdata",sectab_i->Name)||
2399           0==strcmp(".rodata",sectab_i->Name))
2400          kind = SECTIONKIND_CODE_OR_RODATA;
2401       if (0==strcmp(".data",sectab_i->Name) ||
2402           0==strcmp(".bss",sectab_i->Name))
2403          kind = SECTIONKIND_RWDATA;
2404
2405       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
2406       sz = sectab_i->SizeOfRawData;
2407       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
2408
2409       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
2410       end   = start + sz - 1;
2411
2412       if (kind == SECTIONKIND_OTHER
2413           /* Ignore sections called which contain stabs debugging
2414              information. */
2415           && 0 != strcmp(".stab", sectab_i->Name)
2416           && 0 != strcmp(".stabstr", sectab_i->Name)
2417           /* ignore constructor section for now */
2418           && 0 != strcmp(".ctors", sectab_i->Name)
2419           /* ignore section generated from .ident */
2420           && 0!= strcmp("/4", sectab_i->Name)
2421           /* ignore unknown section that appeared in gcc 3.4.5(?) */
2422           && 0!= strcmp(".reloc", sectab_i->Name)
2423          ) {
2424          errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", sectab_i->Name, oc->fileName);
2425          return 0;
2426       }
2427
2428       if (kind != SECTIONKIND_OTHER && end >= start) {
2429          addSection(oc, kind, start, end);
2430          addProddableBlock(oc, start, end - start + 1);
2431       }
2432    }
2433
2434    /* Copy exported symbols into the ObjectCode. */
2435
2436    oc->n_symbols = hdr->NumberOfSymbols;
2437    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
2438                                   "ocGetNames_PEi386(oc->symbols)");
2439    /* Call me paranoid; I don't care. */
2440    for (i = 0; i < oc->n_symbols; i++)
2441       oc->symbols[i] = NULL;
2442
2443    i = 0;
2444    while (1) {
2445       COFF_symbol* symtab_i;
2446       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2447       symtab_i = (COFF_symbol*)
2448                  myindex ( sizeof_COFF_symbol, symtab, i );
2449
2450       addr  = NULL;
2451
2452       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
2453           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
2454          /* This symbol is global and defined, viz, exported */
2455          /* for MYIMAGE_SYMCLASS_EXTERNAL
2456                 && !MYIMAGE_SYM_UNDEFINED,
2457             the address of the symbol is:
2458                 address of relevant section + offset in section
2459          */
2460          COFF_section* sectabent
2461             = (COFF_section*) myindex ( sizeof_COFF_section,
2462                                         sectab,
2463                                         symtab_i->SectionNumber-1 );
2464          addr = ((UChar*)(oc->image))
2465                 + (sectabent->PointerToRawData
2466                    + symtab_i->Value);
2467       }
2468       else
2469       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
2470           && symtab_i->Value > 0) {
2471          /* This symbol isn't in any section at all, ie, global bss.
2472             Allocate zeroed space for it. */
2473          addr = stgCallocBytes(1, symtab_i->Value,
2474                                "ocGetNames_PEi386(non-anonymous bss)");
2475          addSection(oc, SECTIONKIND_RWDATA, addr,
2476                         ((UChar*)addr) + symtab_i->Value - 1);
2477          addProddableBlock(oc, addr, symtab_i->Value);
2478          /* debugBelch("BSS      section at 0x%x\n", addr); */
2479       }
2480
2481       if (addr != NULL ) {
2482          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
2483          /* debugBelch("addSymbol %p `%s \n", addr,sname);  */
2484          IF_DEBUG(linker, debugBelch("addSymbol %p `%s'\n", addr,sname);)
2485          ASSERT(i >= 0 && i < oc->n_symbols);
2486          /* cstring_from_COFF_symbol_name always succeeds. */
2487          oc->symbols[i] = sname;
2488          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
2489       } else {
2490 #        if 0
2491          debugBelch(
2492                    "IGNORING symbol %d\n"
2493                    "     name `",
2494                    i
2495                  );
2496          printName ( symtab_i->Name, strtab );
2497          debugBelch(
2498                    "'\n"
2499                    "    value 0x%x\n"
2500                    "   1+sec# %d\n"
2501                    "     type 0x%x\n"
2502                    "   sclass 0x%x\n"
2503                    "     nAux %d\n",
2504                    symtab_i->Value,
2505                    (Int32)(symtab_i->SectionNumber),
2506                    (UInt32)symtab_i->Type,
2507                    (UInt32)symtab_i->StorageClass,
2508                    (UInt32)symtab_i->NumberOfAuxSymbols
2509                  );
2510 #        endif
2511       }
2512
2513       i += symtab_i->NumberOfAuxSymbols;
2514       i++;
2515    }
2516
2517    return 1;
2518 }
2519
2520
2521 static int
2522 ocResolve_PEi386 ( ObjectCode* oc )
2523 {
2524    COFF_header*  hdr;
2525    COFF_section* sectab;
2526    COFF_symbol*  symtab;
2527    UChar*        strtab;
2528
2529    UInt32        A;
2530    UInt32        S;
2531    UInt32*       pP;
2532
2533    int i;
2534    UInt32 j, noRelocs;
2535
2536    /* ToDo: should be variable-sized?  But is at least safe in the
2537       sense of buffer-overrun-proof. */
2538    char symbol[1000];
2539    /* debugBelch("resolving for %s\n", oc->fileName); */
2540
2541    hdr = (COFF_header*)(oc->image);
2542    sectab = (COFF_section*) (
2543                ((UChar*)(oc->image))
2544                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2545             );
2546    symtab = (COFF_symbol*) (
2547                ((UChar*)(oc->image))
2548                + hdr->PointerToSymbolTable
2549             );
2550    strtab = ((UChar*)(oc->image))
2551             + hdr->PointerToSymbolTable
2552             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2553
2554    for (i = 0; i < hdr->NumberOfSections; i++) {
2555       COFF_section* sectab_i
2556          = (COFF_section*)
2557            myindex ( sizeof_COFF_section, sectab, i );
2558       COFF_reloc* reltab
2559          = (COFF_reloc*) (
2560               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2561            );
2562
2563       /* Ignore sections called which contain stabs debugging
2564          information. */
2565       if (0 == strcmp(".stab", sectab_i->Name)
2566           || 0 == strcmp(".stabstr", sectab_i->Name)
2567           || 0 == strcmp(".ctors", sectab_i->Name))
2568          continue;
2569
2570       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2571         /* If the relocation field (a short) has overflowed, the
2572          * real count can be found in the first reloc entry.
2573          *
2574          * See Section 4.1 (last para) of the PE spec (rev6.0).
2575          *
2576          * Nov2003 update: the GNU linker still doesn't correctly
2577          * handle the generation of relocatable object files with
2578          * overflown relocations. Hence the output to warn of potential
2579          * troubles.
2580          */
2581         COFF_reloc* rel = (COFF_reloc*)
2582                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2583         noRelocs = rel->VirtualAddress;
2584
2585         /* 10/05: we now assume (and check for) a GNU ld that is capable
2586          * of handling object files with (>2^16) of relocs.
2587          */
2588 #if 0
2589         debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
2590                    noRelocs);
2591 #endif
2592         j = 1;
2593       } else {
2594         noRelocs = sectab_i->NumberOfRelocations;
2595         j = 0;
2596       }
2597
2598
2599       for (; j < noRelocs; j++) {
2600          COFF_symbol* sym;
2601          COFF_reloc* reltab_j
2602             = (COFF_reloc*)
2603               myindex ( sizeof_COFF_reloc, reltab, j );
2604
2605          /* the location to patch */
2606          pP = (UInt32*)(
2607                  ((UChar*)(oc->image))
2608                  + (sectab_i->PointerToRawData
2609                     + reltab_j->VirtualAddress
2610                     - sectab_i->VirtualAddress )
2611               );
2612          /* the existing contents of pP */
2613          A = *pP;
2614          /* the symbol to connect to */
2615          sym = (COFF_symbol*)
2616                myindex ( sizeof_COFF_symbol,
2617                          symtab, reltab_j->SymbolTableIndex );
2618          IF_DEBUG(linker,
2619                   debugBelch(
2620                             "reloc sec %2d num %3d:  type 0x%-4x   "
2621                             "vaddr 0x%-8x   name `",
2622                             i, j,
2623                             (UInt32)reltab_j->Type,
2624                             reltab_j->VirtualAddress );
2625                             printName ( sym->Name, strtab );
2626                             debugBelch("'\n" ));
2627
2628          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
2629             COFF_section* section_sym
2630                = findPEi386SectionCalled ( oc, sym->Name );
2631             if (!section_sym) {
2632                errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
2633                return 0;
2634             }
2635             S = ((UInt32)(oc->image))
2636                 + (section_sym->PointerToRawData
2637                    + sym->Value);
2638          } else {
2639             copyName ( sym->Name, strtab, symbol, 1000-1 );
2640             S = (UInt32) lookupSymbol( symbol );
2641             if ((void*)S != NULL) goto foundit;
2642             /* Newline first because the interactive linker has printed "linking..." */
2643             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
2644             return 0;
2645            foundit:;
2646          }
2647          checkProddableBlock(oc, pP);
2648          switch (reltab_j->Type) {
2649             case MYIMAGE_REL_I386_DIR32:
2650                *pP = A + S;
2651                break;
2652             case MYIMAGE_REL_I386_REL32:
2653                /* Tricky.  We have to insert a displacement at
2654                   pP which, when added to the PC for the _next_
2655                   insn, gives the address of the target (S).
2656                   Problem is to know the address of the next insn
2657                   when we only know pP.  We assume that this
2658                   literal field is always the last in the insn,
2659                   so that the address of the next insn is pP+4
2660                   -- hence the constant 4.
2661                   Also I don't know if A should be added, but so
2662                   far it has always been zero.
2663
2664                   SOF 05/2005: 'A' (old contents of *pP) have been observed
2665                   to contain values other than zero (the 'wx' object file
2666                   that came with wxhaskell-0.9.4; dunno how it was compiled..).
2667                   So, add displacement to old value instead of asserting
2668                   A to be zero. Fixes wxhaskell-related crashes, and no other
2669                   ill effects have been observed.
2670
2671                   Update: the reason why we're seeing these more elaborate
2672                   relocations is due to a switch in how the NCG compiles SRTs
2673                   and offsets to them from info tables. SRTs live in .(ro)data,
2674                   while info tables live in .text, causing GAS to emit REL32/DISP32
2675                   relocations with non-zero values. Adding the displacement is
2676                   the right thing to do.
2677                */
2678                *pP = S - ((UInt32)pP) - 4 + A;
2679                break;
2680             default:
2681                debugBelch("%s: unhandled PEi386 relocation type %d",
2682                      oc->fileName, reltab_j->Type);
2683                return 0;
2684          }
2685
2686       }
2687    }
2688
2689    IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
2690    return 1;
2691 }
2692
2693 #endif /* defined(OBJFORMAT_PEi386) */
2694
2695
2696 /* --------------------------------------------------------------------------
2697  * ELF specifics
2698  * ------------------------------------------------------------------------*/
2699
2700 #if defined(OBJFORMAT_ELF)
2701
2702 #define FALSE 0
2703 #define TRUE  1
2704
2705 #if defined(sparc_HOST_ARCH)
2706 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
2707 #elif defined(i386_HOST_ARCH)
2708 #  define ELF_TARGET_386    /* Used inside <elf.h> */
2709 #elif defined(x86_64_HOST_ARCH)
2710 #  define ELF_TARGET_X64_64
2711 #  define ELF_64BIT
2712 #elif defined (ia64_HOST_ARCH)
2713 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
2714 #  define ELF_64BIT
2715 #  define ELF_FUNCTION_DESC /* calling convention uses function descriptors */
2716 #  define ELF_NEED_GOT      /* needs Global Offset Table */
2717 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
2718 #endif
2719
2720 #if !defined(openbsd_HOST_OS)
2721 #  include <elf.h>
2722 #else
2723 /* openbsd elf has things in different places, with diff names */
2724 #  include <elf_abi.h>
2725 #  include <machine/reloc.h>
2726 #  define R_386_32    RELOC_32
2727 #  define R_386_PC32  RELOC_PC32
2728 #endif
2729
2730 /* If elf.h doesn't define it */
2731 #  ifndef R_X86_64_PC64
2732 #    define R_X86_64_PC64 24
2733 #  endif
2734
2735 /*
2736  * Define a set of types which can be used for both ELF32 and ELF64
2737  */
2738
2739 #ifdef ELF_64BIT
2740 #define ELFCLASS    ELFCLASS64
2741 #define Elf_Addr    Elf64_Addr
2742 #define Elf_Word    Elf64_Word
2743 #define Elf_Sword   Elf64_Sword
2744 #define Elf_Ehdr    Elf64_Ehdr
2745 #define Elf_Phdr    Elf64_Phdr
2746 #define Elf_Shdr    Elf64_Shdr
2747 #define Elf_Sym     Elf64_Sym
2748 #define Elf_Rel     Elf64_Rel
2749 #define Elf_Rela    Elf64_Rela
2750 #define ELF_ST_TYPE ELF64_ST_TYPE
2751 #define ELF_ST_BIND ELF64_ST_BIND
2752 #define ELF_R_TYPE  ELF64_R_TYPE
2753 #define ELF_R_SYM   ELF64_R_SYM
2754 #else
2755 #define ELFCLASS    ELFCLASS32
2756 #define Elf_Addr    Elf32_Addr
2757 #define Elf_Word    Elf32_Word
2758 #define Elf_Sword   Elf32_Sword
2759 #define Elf_Ehdr    Elf32_Ehdr
2760 #define Elf_Phdr    Elf32_Phdr
2761 #define Elf_Shdr    Elf32_Shdr
2762 #define Elf_Sym     Elf32_Sym
2763 #define Elf_Rel     Elf32_Rel
2764 #define Elf_Rela    Elf32_Rela
2765 #ifndef ELF_ST_TYPE
2766 #define ELF_ST_TYPE ELF32_ST_TYPE
2767 #endif
2768 #ifndef ELF_ST_BIND
2769 #define ELF_ST_BIND ELF32_ST_BIND
2770 #endif
2771 #ifndef ELF_R_TYPE
2772 #define ELF_R_TYPE  ELF32_R_TYPE
2773 #endif
2774 #ifndef ELF_R_SYM
2775 #define ELF_R_SYM   ELF32_R_SYM
2776 #endif
2777 #endif
2778
2779
2780 /*
2781  * Functions to allocate entries in dynamic sections.  Currently we simply
2782  * preallocate a large number, and we don't check if a entry for the given
2783  * target already exists (a linear search is too slow).  Ideally these
2784  * entries would be associated with symbols.
2785  */
2786
2787 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
2788 #define GOT_SIZE            0x20000
2789 #define FUNCTION_TABLE_SIZE 0x10000
2790 #define PLT_SIZE            0x08000
2791
2792 #ifdef ELF_NEED_GOT
2793 static Elf_Addr got[GOT_SIZE];
2794 static unsigned int gotIndex;
2795 static Elf_Addr gp_val = (Elf_Addr)got;
2796
2797 static Elf_Addr
2798 allocateGOTEntry(Elf_Addr target)
2799 {
2800    Elf_Addr *entry;
2801
2802    if (gotIndex >= GOT_SIZE)
2803       barf("Global offset table overflow");
2804
2805    entry = &got[gotIndex++];
2806    *entry = target;
2807    return (Elf_Addr)entry;
2808 }
2809 #endif
2810
2811 #ifdef ELF_FUNCTION_DESC
2812 typedef struct {
2813    Elf_Addr ip;
2814    Elf_Addr gp;
2815 } FunctionDesc;
2816
2817 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
2818 static unsigned int functionTableIndex;
2819
2820 static Elf_Addr
2821 allocateFunctionDesc(Elf_Addr target)
2822 {
2823    FunctionDesc *entry;
2824
2825    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
2826       barf("Function table overflow");
2827
2828    entry = &functionTable[functionTableIndex++];
2829    entry->ip = target;
2830    entry->gp = (Elf_Addr)gp_val;
2831    return (Elf_Addr)entry;
2832 }
2833
2834 static Elf_Addr
2835 copyFunctionDesc(Elf_Addr target)
2836 {
2837    FunctionDesc *olddesc = (FunctionDesc *)target;
2838    FunctionDesc *newdesc;
2839
2840    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
2841    newdesc->gp = olddesc->gp;
2842    return (Elf_Addr)newdesc;
2843 }
2844 #endif
2845
2846 #ifdef ELF_NEED_PLT
2847 #ifdef ia64_HOST_ARCH
2848 static void ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value);
2849 static void ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc);
2850
2851 static unsigned char plt_code[] =
2852 {
2853    /* taken from binutils bfd/elfxx-ia64.c */
2854    0x0b, 0x78, 0x00, 0x02, 0x00, 0x24,  /*   [MMI]       addl r15=0,r1;;    */
2855    0x00, 0x41, 0x3c, 0x30, 0x28, 0xc0,  /*               ld8 r16=[r15],8    */
2856    0x01, 0x08, 0x00, 0x84,              /*               mov r14=r1;;       */
2857    0x11, 0x08, 0x00, 0x1e, 0x18, 0x10,  /*   [MIB]       ld8 r1=[r15]       */
2858    0x60, 0x80, 0x04, 0x80, 0x03, 0x00,  /*               mov b6=r16         */
2859    0x60, 0x00, 0x80, 0x00               /*               br.few b6;;        */
2860 };
2861
2862 /* If we can't get to the function descriptor via gp, take a local copy of it */
2863 #define PLT_RELOC(code, target) { \
2864    Elf64_Sxword rel_value = target - gp_val; \
2865    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff)) \
2866       ia64_reloc_gprel22((Elf_Addr)code, copyFunctionDesc(target)); \
2867    else \
2868       ia64_reloc_gprel22((Elf_Addr)code, target); \
2869    }
2870 #endif
2871
2872 typedef struct {
2873    unsigned char code[sizeof(plt_code)];
2874 } PLTEntry;
2875
2876 static Elf_Addr
2877 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
2878 {
2879    PLTEntry *plt = (PLTEntry *)oc->plt;
2880    PLTEntry *entry;
2881
2882    if (oc->pltIndex >= PLT_SIZE)
2883       barf("Procedure table overflow");
2884
2885    entry = &plt[oc->pltIndex++];
2886    memcpy(entry->code, plt_code, sizeof(entry->code));
2887    PLT_RELOC(entry->code, target);
2888    return (Elf_Addr)entry;
2889 }
2890
2891 static unsigned int
2892 PLTSize(void)
2893 {
2894    return (PLT_SIZE * sizeof(PLTEntry));
2895 }
2896 #endif
2897
2898
2899 /*
2900  * Generic ELF functions
2901  */
2902
2903 static char *
2904 findElfSection ( void* objImage, Elf_Word sh_type )
2905 {
2906    char* ehdrC = (char*)objImage;
2907    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2908    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
2909    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2910    char* ptr = NULL;
2911    int i;
2912
2913    for (i = 0; i < ehdr->e_shnum; i++) {
2914       if (shdr[i].sh_type == sh_type
2915           /* Ignore the section header's string table. */
2916           && i != ehdr->e_shstrndx
2917           /* Ignore string tables named .stabstr, as they contain
2918              debugging info. */
2919           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2920          ) {
2921          ptr = ehdrC + shdr[i].sh_offset;
2922          break;
2923       }
2924    }
2925    return ptr;
2926 }
2927
2928 #if defined(ia64_HOST_ARCH)
2929 static Elf_Addr
2930 findElfSegment ( void* objImage, Elf_Addr vaddr )
2931 {
2932    char* ehdrC = (char*)objImage;
2933    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2934    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2935    Elf_Addr segaddr = 0;
2936    int i;
2937
2938    for (i = 0; i < ehdr->e_phnum; i++) {
2939       segaddr = phdr[i].p_vaddr;
2940       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2941               break;
2942    }
2943    return segaddr;
2944 }
2945 #endif
2946
2947 static int
2948 ocVerifyImage_ELF ( ObjectCode* oc )
2949 {
2950    Elf_Shdr* shdr;
2951    Elf_Sym*  stab;
2952    int i, j, nent, nstrtab, nsymtabs;
2953    char* sh_strtab;
2954    char* strtab;
2955
2956    char*     ehdrC = (char*)(oc->image);
2957    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2958
2959    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2960        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2961        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2962        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2963       errorBelch("%s: not an ELF object", oc->fileName);
2964       return 0;
2965    }
2966
2967    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2968       errorBelch("%s: unsupported ELF format", oc->fileName);
2969       return 0;
2970    }
2971
2972    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2973        IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
2974    } else
2975    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2976        IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
2977    } else {
2978        errorBelch("%s: unknown endiannness", oc->fileName);
2979        return 0;
2980    }
2981
2982    if (ehdr->e_type != ET_REL) {
2983       errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
2984       return 0;
2985    }
2986    IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
2987
2988    IF_DEBUG(linker,debugBelch( "Architecture is " ));
2989    switch (ehdr->e_machine) {
2990       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
2991 #ifdef EM_SPARC32PLUS
2992       case EM_SPARC32PLUS:
2993 #endif
2994       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
2995 #ifdef EM_IA_64
2996       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
2997 #endif
2998       case EM_PPC:   IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
2999 #ifdef EM_X86_64
3000       case EM_X86_64: IF_DEBUG(linker,debugBelch( "x86_64" )); break;
3001 #elif defined(EM_AMD64)
3002       case EM_AMD64: IF_DEBUG(linker,debugBelch( "amd64" )); break;
3003 #endif
3004       default:       IF_DEBUG(linker,debugBelch( "unknown" ));
3005                      errorBelch("%s: unknown architecture (e_machine == %d)"
3006                                 , oc->fileName, ehdr->e_machine);
3007                      return 0;
3008    }
3009
3010    IF_DEBUG(linker,debugBelch(
3011              "\nSection header table: start %ld, n_entries %d, ent_size %d\n",
3012              (long)ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
3013
3014    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
3015
3016    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3017
3018    if (ehdr->e_shstrndx == SHN_UNDEF) {
3019       errorBelch("%s: no section header string table", oc->fileName);
3020       return 0;
3021    } else {
3022       IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
3023                           ehdr->e_shstrndx));
3024       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
3025    }
3026
3027    for (i = 0; i < ehdr->e_shnum; i++) {
3028       IF_DEBUG(linker,debugBelch("%2d:  ", i ));
3029       IF_DEBUG(linker,debugBelch("type=%2d  ", (int)shdr[i].sh_type ));
3030       IF_DEBUG(linker,debugBelch("size=%4d  ", (int)shdr[i].sh_size ));
3031       IF_DEBUG(linker,debugBelch("offs=%4d  ", (int)shdr[i].sh_offset ));
3032       IF_DEBUG(linker,debugBelch("  (%p .. %p)  ",
3033                ehdrC + shdr[i].sh_offset,
3034                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
3035
3036       if (shdr[i].sh_type == SHT_REL) {
3037           IF_DEBUG(linker,debugBelch("Rel  " ));
3038       } else if (shdr[i].sh_type == SHT_RELA) {
3039           IF_DEBUG(linker,debugBelch("RelA " ));
3040       } else {
3041           IF_DEBUG(linker,debugBelch("     "));
3042       }
3043       if (sh_strtab) {
3044           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
3045       }
3046    }
3047
3048    IF_DEBUG(linker,debugBelch( "\nString tables" ));
3049    strtab = NULL;
3050    nstrtab = 0;
3051    for (i = 0; i < ehdr->e_shnum; i++) {
3052       if (shdr[i].sh_type == SHT_STRTAB
3053           /* Ignore the section header's string table. */
3054           && i != ehdr->e_shstrndx
3055           /* Ignore string tables named .stabstr, as they contain
3056              debugging info. */
3057           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
3058          ) {
3059          IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
3060          strtab = ehdrC + shdr[i].sh_offset;
3061          nstrtab++;
3062       }
3063    }
3064    if (nstrtab != 1) {
3065       errorBelch("%s: no string tables, or too many", oc->fileName);
3066       return 0;
3067    }
3068
3069    nsymtabs = 0;
3070    IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
3071    for (i = 0; i < ehdr->e_shnum; i++) {
3072       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3073       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
3074       nsymtabs++;
3075       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3076       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3077       IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%ld rem)\n",
3078                nent,
3079                (long)shdr[i].sh_size % sizeof(Elf_Sym)
3080              ));
3081       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
3082          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
3083          return 0;
3084       }
3085       for (j = 0; j < nent; j++) {
3086          IF_DEBUG(linker,debugBelch("   %2d  ", j ));
3087          IF_DEBUG(linker,debugBelch("  sec=%-5d  size=%-3d  val=%5p  ",
3088                              (int)stab[j].st_shndx,
3089                              (int)stab[j].st_size,
3090                              (char*)stab[j].st_value ));
3091
3092          IF_DEBUG(linker,debugBelch("type=" ));
3093          switch (ELF_ST_TYPE(stab[j].st_info)) {
3094             case STT_NOTYPE:  IF_DEBUG(linker,debugBelch("notype " )); break;
3095             case STT_OBJECT:  IF_DEBUG(linker,debugBelch("object " )); break;
3096             case STT_FUNC  :  IF_DEBUG(linker,debugBelch("func   " )); break;
3097             case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
3098             case STT_FILE:    IF_DEBUG(linker,debugBelch("file   " )); break;
3099             default:          IF_DEBUG(linker,debugBelch("?      " )); break;
3100          }
3101          IF_DEBUG(linker,debugBelch("  " ));
3102
3103          IF_DEBUG(linker,debugBelch("bind=" ));
3104          switch (ELF_ST_BIND(stab[j].st_info)) {
3105             case STB_LOCAL :  IF_DEBUG(linker,debugBelch("local " )); break;
3106             case STB_GLOBAL:  IF_DEBUG(linker,debugBelch("global" )); break;
3107             case STB_WEAK  :  IF_DEBUG(linker,debugBelch("weak  " )); break;
3108             default:          IF_DEBUG(linker,debugBelch("?     " )); break;
3109          }
3110          IF_DEBUG(linker,debugBelch("  " ));
3111
3112          IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
3113       }
3114    }
3115
3116    if (nsymtabs == 0) {
3117       errorBelch("%s: didn't find any symbol tables", oc->fileName);
3118       return 0;
3119    }
3120
3121    return 1;
3122 }
3123
3124 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
3125 {
3126     *is_bss = FALSE;
3127
3128     if (hdr->sh_type == SHT_PROGBITS
3129         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
3130         /* .text-style section */
3131         return SECTIONKIND_CODE_OR_RODATA;
3132     }
3133
3134     if (hdr->sh_type == SHT_PROGBITS
3135             && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3136             /* .data-style section */
3137             return SECTIONKIND_RWDATA;
3138     }
3139
3140     if (hdr->sh_type == SHT_PROGBITS
3141         && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
3142         /* .rodata-style section */
3143         return SECTIONKIND_CODE_OR_RODATA;
3144     }
3145
3146     if (hdr->sh_type == SHT_NOBITS
3147         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3148         /* .bss-style section */
3149         *is_bss = TRUE;
3150         return SECTIONKIND_RWDATA;
3151     }
3152
3153     return SECTIONKIND_OTHER;
3154 }
3155
3156
3157 static int
3158 ocGetNames_ELF ( ObjectCode* oc )
3159 {
3160    int i, j, k, nent;
3161    Elf_Sym* stab;
3162
3163    char*     ehdrC    = (char*)(oc->image);
3164    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
3165    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
3166    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3167
3168    ASSERT(symhash != NULL);
3169
3170    if (!strtab) {
3171       errorBelch("%s: no strtab", oc->fileName);
3172       return 0;
3173    }
3174
3175    k = 0;
3176    for (i = 0; i < ehdr->e_shnum; i++) {
3177       /* Figure out what kind of section it is.  Logic derived from
3178          Figure 1.14 ("Special Sections") of the ELF document
3179          ("Portable Formats Specification, Version 1.1"). */
3180       int         is_bss = FALSE;
3181       SectionKind kind   = getSectionKind_ELF(&shdr[i], &is_bss);
3182
3183       if (is_bss && shdr[i].sh_size > 0) {
3184          /* This is a non-empty .bss section.  Allocate zeroed space for
3185             it, and set its .sh_offset field such that
3186             ehdrC + .sh_offset == addr_of_zeroed_space.  */
3187          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
3188                                        "ocGetNames_ELF(BSS)");
3189          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
3190          /*
3191          debugBelch("BSS section at 0x%x, size %d\n",
3192                          zspace, shdr[i].sh_size);
3193          */
3194       }
3195
3196       /* fill in the section info */
3197       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
3198          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
3199          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
3200                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
3201       }
3202
3203       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3204
3205       /* copy stuff into this module's object symbol table */
3206       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3207       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3208
3209       oc->n_symbols = nent;
3210       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3211                                    "ocGetNames_ELF(oc->symbols)");
3212
3213       for (j = 0; j < nent; j++) {
3214
3215          char  isLocal = FALSE; /* avoids uninit-var warning */
3216          char* ad      = NULL;
3217          char* nm      = strtab + stab[j].st_name;
3218          int   secno   = stab[j].st_shndx;
3219
3220          /* Figure out if we want to add it; if so, set ad to its
3221             address.  Otherwise leave ad == NULL. */
3222
3223          if (secno == SHN_COMMON) {
3224             isLocal = FALSE;
3225             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
3226             /*
3227             debugBelch("COMMON symbol, size %d name %s\n",
3228                             stab[j].st_size, nm);
3229             */
3230             /* Pointless to do addProddableBlock() for this area,
3231                since the linker should never poke around in it. */
3232          }
3233          else
3234          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
3235                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
3236               )
3237               /* and not an undefined symbol */
3238               && stab[j].st_shndx != SHN_UNDEF
3239               /* and not in a "special section" */
3240               && stab[j].st_shndx < SHN_LORESERVE
3241               &&
3242               /* and it's a not a section or string table or anything silly */
3243               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
3244                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
3245                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
3246               )
3247             ) {
3248             /* Section 0 is the undefined section, hence > and not >=. */
3249             ASSERT(secno > 0 && secno < ehdr->e_shnum);
3250             /*
3251             if (shdr[secno].sh_type == SHT_NOBITS) {
3252                debugBelch("   BSS symbol, size %d off %d name %s\n",
3253                                stab[j].st_size, stab[j].st_value, nm);
3254             }
3255             */
3256             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
3257             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
3258                isLocal = TRUE;
3259             } else {
3260 #ifdef ELF_FUNCTION_DESC
3261                /* dlsym() and the initialisation table both give us function
3262                 * descriptors, so to be consistent we store function descriptors
3263                 * in the symbol table */
3264                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
3265                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
3266 #endif
3267                IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p  %s %s\n",
3268                                       ad, oc->fileName, nm ));
3269                isLocal = FALSE;
3270             }
3271          }
3272
3273          /* And the decision is ... */
3274
3275          if (ad != NULL) {
3276             ASSERT(nm != NULL);
3277             oc->symbols[j] = nm;
3278             /* Acquire! */
3279             if (isLocal) {
3280                /* Ignore entirely. */
3281             } else {
3282                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
3283             }
3284          } else {
3285             /* Skip. */
3286             IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
3287                                    strtab + stab[j].st_name ));
3288             /*
3289             debugBelch(
3290                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
3291                     (int)ELF_ST_BIND(stab[j].st_info),
3292                     (int)ELF_ST_TYPE(stab[j].st_info),
3293                     (int)stab[j].st_shndx,
3294                     strtab + stab[j].st_name
3295                    );
3296             */
3297             oc->symbols[j] = NULL;
3298          }
3299
3300       }
3301    }
3302
3303    return 1;
3304 }
3305
3306 /* Do ELF relocations which lack an explicit addend.  All x86-linux
3307    relocations appear to be of this form. */
3308 static int
3309 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
3310                          Elf_Shdr* shdr, int shnum,
3311                          Elf_Sym*  stab, char* strtab )
3312 {
3313    int j;
3314    char *symbol;
3315    Elf_Word* targ;
3316    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
3317    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
3318    int target_shndx = shdr[shnum].sh_info;
3319    int symtab_shndx = shdr[shnum].sh_link;
3320
3321    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3322    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
3323    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3324                           target_shndx, symtab_shndx ));
3325
3326    /* Skip sections that we're not interested in. */
3327    {
3328        int is_bss;
3329        SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
3330        if (kind == SECTIONKIND_OTHER) {
3331            IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
3332            return 1;
3333        }
3334    }
3335
3336    for (j = 0; j < nent; j++) {
3337       Elf_Addr offset = rtab[j].r_offset;
3338       Elf_Addr info   = rtab[j].r_info;
3339
3340       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
3341       Elf_Word* pP = (Elf_Word*)P;
3342       Elf_Addr  A  = *pP;
3343       Elf_Addr  S;
3344       void*     S_tmp;
3345       Elf_Addr  value;
3346       StgStablePtr stablePtr;
3347       StgPtr stableVal;
3348
3349       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
3350                              j, (void*)offset, (void*)info ));
3351       if (!info) {
3352          IF_DEBUG(linker,debugBelch( " ZERO" ));
3353          S = 0;
3354       } else {
3355          Elf_Sym sym = stab[ELF_R_SYM(info)];
3356          /* First see if it is a local symbol. */
3357          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3358             /* Yes, so we can get the address directly from the ELF symbol
3359                table. */
3360             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3361             S = (Elf_Addr)
3362                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3363                        + stab[ELF_R_SYM(info)].st_value);
3364
3365          } else {
3366             symbol = strtab + sym.st_name;
3367             stablePtr = (StgStablePtr)lookupHashTable(stablehash, (StgWord)symbol);
3368             if (NULL == stablePtr) {
3369               /* No, so look up the name in our global table. */
3370               S_tmp = lookupSymbol( symbol );
3371               S = (Elf_Addr)S_tmp;
3372             } else {
3373               stableVal = deRefStablePtr( stablePtr );
3374               S_tmp = stableVal;
3375               S = (Elf_Addr)S_tmp;
3376             }
3377          }
3378          if (!S) {
3379             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3380             return 0;
3381          }
3382          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n", symbol, (void*)S ));
3383       }
3384
3385       IF_DEBUG(linker,debugBelch( "Reloc: P = %p   S = %p   A = %p\n",
3386                              (void*)P, (void*)S, (void*)A ));
3387       checkProddableBlock ( oc, pP );
3388
3389       value = S + A;
3390
3391       switch (ELF_R_TYPE(info)) {
3392 #        ifdef i386_HOST_ARCH
3393          case R_386_32:   *pP = value;     break;
3394          case R_386_PC32: *pP = value - P; break;
3395 #        endif
3396          default:
3397             errorBelch("%s: unhandled ELF relocation(Rel) type %lu\n",
3398                   oc->fileName, (lnat)ELF_R_TYPE(info));
3399             return 0;
3400       }
3401
3402    }
3403    return 1;
3404 }
3405
3406 /* Do ELF relocations for which explicit addends are supplied.
3407    sparc-solaris relocations appear to be of this form. */
3408 static int
3409 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
3410                           Elf_Shdr* shdr, int shnum,
3411                           Elf_Sym*  stab, char* strtab )
3412 {
3413    int j;
3414    char *symbol = NULL;
3415    Elf_Addr targ;
3416    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
3417    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
3418    int target_shndx = shdr[shnum].sh_info;
3419    int symtab_shndx = shdr[shnum].sh_link;
3420
3421    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3422    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
3423    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3424                           target_shndx, symtab_shndx ));
3425
3426    for (j = 0; j < nent; j++) {
3427 #if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3428       /* This #ifdef only serves to avoid unused-var warnings. */
3429       Elf_Addr  offset = rtab[j].r_offset;
3430       Elf_Addr  P      = targ + offset;
3431 #endif
3432       Elf_Addr  info   = rtab[j].r_info;
3433       Elf_Addr  A      = rtab[j].r_addend;
3434       Elf_Addr  S;
3435       void*     S_tmp;
3436       Elf_Addr  value;
3437 #     if defined(sparc_HOST_ARCH)
3438       Elf_Word* pP = (Elf_Word*)P;
3439       Elf_Word  w1, w2;
3440 #     elif defined(ia64_HOST_ARCH)
3441       Elf64_Xword *pP = (Elf64_Xword *)P;
3442       Elf_Addr addr;
3443 #     elif defined(powerpc_HOST_ARCH)
3444       Elf_Sword delta;
3445 #     endif
3446
3447       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p %6p)   ",
3448                              j, (void*)offset, (void*)info,
3449                                 (void*)A ));
3450       if (!info) {
3451          IF_DEBUG(linker,debugBelch( " ZERO" ));
3452          S = 0;
3453       } else {
3454          Elf_Sym sym = stab[ELF_R_SYM(info)];
3455          /* First see if it is a local symbol. */
3456          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3457             /* Yes, so we can get the address directly from the ELF symbol
3458                table. */
3459             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3460             S = (Elf_Addr)
3461                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3462                        + stab[ELF_R_SYM(info)].st_value);
3463 #ifdef ELF_FUNCTION_DESC
3464             /* Make a function descriptor for this function */
3465             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
3466                S = allocateFunctionDesc(S + A);
3467                A = 0;
3468             }
3469 #endif
3470          } else {
3471             /* No, so look up the name in our global table. */
3472             symbol = strtab + sym.st_name;
3473             S_tmp = lookupSymbol( symbol );
3474             S = (Elf_Addr)S_tmp;
3475
3476 #ifdef ELF_FUNCTION_DESC
3477             /* If a function, already a function descriptor - we would
3478                have to copy it to add an offset. */
3479             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
3480                errorBelch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
3481 #endif
3482          }
3483          if (!S) {
3484            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3485            return 0;
3486          }
3487          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p", symbol, (void*)S ));
3488       }
3489
3490       IF_DEBUG(linker,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
3491                                         (void*)P, (void*)S, (void*)A ));
3492       /* checkProddableBlock ( oc, (void*)P ); */
3493
3494       value = S + A;
3495
3496       switch (ELF_R_TYPE(info)) {
3497 #        if defined(sparc_HOST_ARCH)
3498          case R_SPARC_WDISP30:
3499             w1 = *pP & 0xC0000000;
3500             w2 = (Elf_Word)((value - P) >> 2);
3501             ASSERT((w2 & 0xC0000000) == 0);
3502             w1 |= w2;
3503             *pP = w1;
3504             break;
3505          case R_SPARC_HI22:
3506             w1 = *pP & 0xFFC00000;
3507             w2 = (Elf_Word)(value >> 10);
3508             ASSERT((w2 & 0xFFC00000) == 0);
3509             w1 |= w2;
3510             *pP = w1;
3511             break;
3512          case R_SPARC_LO10:
3513             w1 = *pP & ~0x3FF;
3514             w2 = (Elf_Word)(value & 0x3FF);
3515             ASSERT((w2 & ~0x3FF) == 0);
3516             w1 |= w2;
3517             *pP = w1;
3518             break;
3519          /* According to the Sun documentation:
3520             R_SPARC_UA32
3521             This relocation type resembles R_SPARC_32, except it refers to an
3522             unaligned word. That is, the word to be relocated must be treated
3523             as four separate bytes with arbitrary alignment, not as a word
3524             aligned according to the architecture requirements.
3525
3526             (JRS: which means that freeloading on the R_SPARC_32 case
3527             is probably wrong, but hey ...)
3528          */
3529          case R_SPARC_UA32:
3530          case R_SPARC_32:
3531             w2 = (Elf_Word)value;
3532             *pP = w2;
3533             break;
3534 #        elif defined(ia64_HOST_ARCH)
3535          case R_IA64_DIR64LSB:
3536          case R_IA64_FPTR64LSB:
3537             *pP = value;
3538             break;
3539          case R_IA64_PCREL64LSB:
3540             *pP = value - P;
3541             break;
3542          case R_IA64_SEGREL64LSB:
3543             addr = findElfSegment(ehdrC, value);
3544             *pP = value - addr;
3545             break;
3546          case R_IA64_GPREL22:
3547             ia64_reloc_gprel22(P, value);
3548             break;
3549          case R_IA64_LTOFF22:
3550          case R_IA64_LTOFF22X:
3551          case R_IA64_LTOFF_FPTR22:
3552             addr = allocateGOTEntry(value);
3553             ia64_reloc_gprel22(P, addr);
3554             break;
3555          case R_IA64_PCREL21B:
3556             ia64_reloc_pcrel21(P, S, oc);
3557             break;
3558          case R_IA64_LDXMOV:
3559             /* This goes with R_IA64_LTOFF22X and points to the load to
3560              * convert into a move.  We don't implement relaxation. */
3561             break;
3562 #        elif defined(powerpc_HOST_ARCH)
3563          case R_PPC_ADDR16_LO:
3564             *(Elf32_Half*) P = value;
3565             break;
3566
3567          case R_PPC_ADDR16_HI:
3568             *(Elf32_Half*) P = value >> 16;
3569             break;
3570
3571          case R_PPC_ADDR16_HA:
3572             *(Elf32_Half*) P = (value + 0x8000) >> 16;
3573             break;
3574
3575          case R_PPC_ADDR32:
3576             *(Elf32_Word *) P = value;
3577             break;
3578
3579          case R_PPC_REL32:
3580             *(Elf32_Word *) P = value - P;
3581             break;
3582
3583          case R_PPC_REL24:
3584             delta = value - P;
3585
3586             if( delta << 6 >> 6 != delta )
3587             {
3588                value = (Elf_Addr) (&makeSymbolExtra( oc, ELF_R_SYM(info), value )
3589                                         ->jumpIsland);
3590                delta = value - P;
3591
3592                if( value == 0 || delta << 6 >> 6 != delta )
3593                {
3594                   barf( "Unable to make SymbolExtra for #%d",
3595                         ELF_R_SYM(info) );
3596                   return 0;
3597                }
3598             }
3599
3600             *(Elf_Word *) P = (*(Elf_Word *) P & 0xfc000003)
3601                                           | (delta & 0x3fffffc);
3602             break;
3603 #        endif
3604
3605 #if x86_64_HOST_ARCH
3606       case R_X86_64_64:
3607           *(Elf64_Xword *)P = value;
3608           break;
3609
3610       case R_X86_64_PC32:
3611       {
3612           StgInt64 off = value - P;
3613           if (off >= 0x7fffffffL || off < -0x80000000L) {
3614 #if X86_64_ELF_NONPIC_HACK
3615               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3616                                                 -> jumpIsland;
3617               off = pltAddress + A - P;
3618 #else
3619               barf("R_X86_64_PC32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
3620                    symbol, off, oc->fileName );
3621 #endif
3622           }
3623           *(Elf64_Word *)P = (Elf64_Word)off;
3624           break;
3625       }
3626
3627       case R_X86_64_PC64:
3628       {
3629           StgInt64 off = value - P;
3630           *(Elf64_Word *)P = (Elf64_Word)off;
3631           break;
3632       }
3633
3634       case R_X86_64_32:
3635           if (value >= 0x7fffffffL) {
3636 #if X86_64_ELF_NONPIC_HACK
3637               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3638                                                 -> jumpIsland;
3639               value = pltAddress + A;
3640 #else
3641               barf("R_X86_64_32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
3642                    symbol, value, oc->fileName );
3643 #endif
3644           }
3645           *(Elf64_Word *)P = (Elf64_Word)value;
3646           break;
3647
3648       case R_X86_64_32S:
3649           if ((StgInt64)value > 0x7fffffffL || (StgInt64)value < -0x80000000L) {
3650 #if X86_64_ELF_NONPIC_HACK
3651               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3652                                                 -> jumpIsland;
3653               value = pltAddress + A;
3654 #else
3655               barf("R_X86_64_32S relocation out of range: %s = %p\nRecompile %s with -fPIC.",
3656                    symbol, value, oc->fileName );
3657 #endif
3658           }
3659           *(Elf64_Sword *)P = (Elf64_Sword)value;
3660           break;
3661
3662       case R_X86_64_GOTPCREL:
3663       {
3664           StgInt64 gotAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)->addr;
3665           StgInt64 off = gotAddress + A - P;
3666           *(Elf64_Word *)P = (Elf64_Word)off;
3667           break;
3668       }
3669
3670       case R_X86_64_PLT32:
3671       {
3672           StgInt64 off = value - P;
3673           if (off >= 0x7fffffffL || off < -0x80000000L) {
3674               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3675                                                     -> jumpIsland;
3676               off = pltAddress + A - P;
3677           }
3678           *(Elf64_Word *)P = (Elf64_Word)off;
3679           break;
3680       }
3681 #endif
3682
3683          default:
3684             errorBelch("%s: unhandled ELF relocation(RelA) type %lu\n",
3685                   oc->fileName, (lnat)ELF_R_TYPE(info));
3686             return 0;
3687       }
3688
3689    }
3690    return 1;
3691 }
3692
3693 static int
3694 ocResolve_ELF ( ObjectCode* oc )
3695 {
3696    char *strtab;
3697    int   shnum, ok;
3698    Elf_Sym*  stab  = NULL;
3699    char*     ehdrC = (char*)(oc->image);
3700    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
3701    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3702
3703    /* first find "the" symbol table */
3704    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
3705
3706    /* also go find the string table */
3707    strtab = findElfSection ( ehdrC, SHT_STRTAB );
3708
3709    if (stab == NULL || strtab == NULL) {
3710       errorBelch("%s: can't find string or symbol table", oc->fileName);
3711       return 0;
3712    }
3713
3714    /* Process the relocation sections. */
3715    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
3716       if (shdr[shnum].sh_type == SHT_REL) {
3717          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
3718                                        shnum, stab, strtab );
3719          if (!ok) return ok;
3720       }
3721       else
3722       if (shdr[shnum].sh_type == SHT_RELA) {
3723          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
3724                                         shnum, stab, strtab );
3725          if (!ok) return ok;
3726       }
3727    }
3728
3729 #if defined(powerpc_HOST_ARCH)
3730    ocFlushInstructionCache( oc );
3731 #endif
3732
3733    return 1;
3734 }
3735
3736 /*
3737  * IA64 specifics
3738  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
3739  * at the front.  The following utility functions pack and unpack instructions, and
3740  * take care of the most common relocations.
3741  */
3742
3743 #ifdef ia64_HOST_ARCH
3744
3745 static Elf64_Xword
3746 ia64_extract_instruction(Elf64_Xword *target)
3747 {
3748    Elf64_Xword w1, w2;
3749    int slot = (Elf_Addr)target & 3;
3750    target = (Elf_Addr)target & ~3;
3751
3752    w1 = *target;
3753    w2 = *(target+1);
3754
3755    switch (slot)
3756    {
3757       case 0:
3758          return ((w1 >> 5) & 0x1ffffffffff);
3759       case 1:
3760          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
3761       case 2:
3762          return (w2 >> 23);
3763       default:
3764          barf("ia64_extract_instruction: invalid slot %p", target);
3765    }
3766 }
3767
3768 static void
3769 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
3770 {
3771    int slot = (Elf_Addr)target & 3;
3772    target = (Elf_Addr)target & ~3;
3773
3774    switch (slot)
3775    {
3776       case 0:
3777          *target |= value << 5;
3778          break;
3779       case 1:
3780          *target |= value << 46;
3781          *(target+1) |= value >> 18;
3782          break;
3783       case 2:
3784          *(target+1) |= value << 23;
3785          break;
3786    }
3787 }
3788
3789 static void
3790 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
3791 {
3792    Elf64_Xword instruction;
3793    Elf64_Sxword rel_value;
3794
3795    rel_value = value - gp_val;
3796    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
3797       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
3798
3799    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3800    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
3801                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
3802                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
3803                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3804    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3805 }
3806
3807 static void
3808 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
3809 {
3810    Elf64_Xword instruction;
3811    Elf64_Sxword rel_value;
3812    Elf_Addr entry;
3813
3814    entry = allocatePLTEntry(value, oc);
3815
3816    rel_value = (entry >> 4) - (target >> 4);
3817    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
3818       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
3819
3820    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3821    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
3822                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3823    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3824 }
3825
3826 #endif /* ia64 */
3827
3828 /*
3829  * PowerPC & X86_64 ELF specifics
3830  */
3831
3832 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3833
3834 static int ocAllocateSymbolExtras_ELF( ObjectCode *oc )
3835 {
3836   Elf_Ehdr *ehdr;
3837   Elf_Shdr* shdr;
3838   int i;
3839
3840   ehdr = (Elf_Ehdr *) oc->image;
3841   shdr = (Elf_Shdr *) ( ((char *)oc->image) + ehdr->e_shoff );
3842
3843   for( i = 0; i < ehdr->e_shnum; i++ )
3844     if( shdr[i].sh_type == SHT_SYMTAB )
3845       break;
3846
3847   if( i == ehdr->e_shnum )
3848   {
3849     errorBelch( "This ELF file contains no symtab" );
3850     return 0;
3851   }
3852
3853   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
3854   {
3855     errorBelch( "The entry size (%d) of the symtab isn't %d\n",
3856       (int) shdr[i].sh_entsize, (int) sizeof( Elf_Sym ) );
3857
3858     return 0;
3859   }
3860
3861   return ocAllocateSymbolExtras( oc, shdr[i].sh_size / sizeof( Elf_Sym ), 0 );
3862 }
3863
3864 #endif /* powerpc */
3865
3866 #endif /* ELF */
3867
3868 /* --------------------------------------------------------------------------
3869  * Mach-O specifics
3870  * ------------------------------------------------------------------------*/
3871
3872 #if defined(OBJFORMAT_MACHO)
3873
3874 /*
3875   Support for MachO linking on Darwin/MacOS X
3876   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
3877
3878   I hereby formally apologize for the hackish nature of this code.
3879   Things that need to be done:
3880   *) implement ocVerifyImage_MachO
3881   *) add still more sanity checks.
3882 */
3883
3884 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
3885 #define mach_header mach_header_64
3886 #define segment_command segment_command_64
3887 #define section section_64
3888 #define nlist nlist_64
3889 #endif
3890
3891 #ifdef powerpc_HOST_ARCH
3892 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
3893 {
3894     struct mach_header *header = (struct mach_header *) oc->image;
3895     struct load_command *lc = (struct load_command *) (header + 1);
3896     unsigned i;
3897
3898     for( i = 0; i < header->ncmds; i++ )
3899     {
3900         if( lc->cmd == LC_SYMTAB )
3901         {
3902                 // Find out the first and last undefined external
3903                 // symbol, so we don't have to allocate too many
3904                 // jump islands.
3905             struct symtab_command *symLC = (struct symtab_command *) lc;
3906             unsigned min = symLC->nsyms, max = 0;
3907             struct nlist *nlist =
3908                 symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
3909                       : NULL;
3910             for(i=0;i<symLC->nsyms;i++)
3911             {
3912                 if(nlist[i].n_type & N_STAB)
3913                     ;
3914                 else if(nlist[i].n_type & N_EXT)
3915                 {
3916                     if((nlist[i].n_type & N_TYPE) == N_UNDF
3917                         && (nlist[i].n_value == 0))
3918                     {
3919                         if(i < min)
3920                             min = i;
3921                         if(i > max)
3922                             max = i;
3923                     }
3924                 }
3925             }
3926             if(max >= min)
3927                 return ocAllocateSymbolExtras(oc, max - min + 1, min);
3928
3929             break;
3930         }
3931
3932         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3933     }
3934     return ocAllocateSymbolExtras(oc,0,0);
3935 }
3936 #endif
3937 #ifdef x86_64_HOST_ARCH
3938 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
3939 {
3940     struct mach_header *header = (struct mach_header *) oc->image;
3941     struct load_command *lc = (struct load_command *) (header + 1);
3942     unsigned i;
3943
3944     for( i = 0; i < header->ncmds; i++ )
3945     {
3946         if( lc->cmd == LC_SYMTAB )
3947         {
3948                 // Just allocate one entry for every symbol
3949             struct symtab_command *symLC = (struct symtab_command *) lc;
3950
3951             return ocAllocateSymbolExtras(oc, symLC->nsyms, 0);
3952         }
3953
3954         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3955     }
3956     return ocAllocateSymbolExtras(oc,0,0);
3957 }
3958 #endif
3959
3960 static int ocVerifyImage_MachO(ObjectCode* oc)
3961 {
3962     char *image = (char*) oc->image;
3963     struct mach_header *header = (struct mach_header*) image;
3964
3965 #if x86_64_TARGET_ARCH || powerpc64_TARGET_ARCH
3966     if(header->magic != MH_MAGIC_64)
3967         return 0;
3968 #else
3969     if(header->magic != MH_MAGIC)
3970         return 0;
3971 #endif
3972     // FIXME: do some more verifying here
3973     return 1;
3974 }
3975
3976 static int resolveImports(
3977     ObjectCode* oc,
3978     char *image,
3979     struct symtab_command *symLC,
3980     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
3981     unsigned long *indirectSyms,
3982     struct nlist *nlist)
3983 {
3984     unsigned i;
3985     size_t itemSize = 4;
3986
3987 #if i386_HOST_ARCH
3988     int isJumpTable = 0;
3989     if(!strcmp(sect->sectname,"__jump_table"))
3990     {
3991         isJumpTable = 1;
3992         itemSize = 5;
3993         ASSERT(sect->reserved2 == itemSize);
3994     }
3995 #endif
3996
3997     for(i=0; i*itemSize < sect->size;i++)
3998     {
3999         // according to otool, reserved1 contains the first index into the indirect symbol table
4000         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
4001         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4002         void *addr = NULL;
4003
4004         if((symbol->n_type & N_TYPE) == N_UNDF
4005             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
4006             addr = (void*) (symbol->n_value);
4007         else
4008             addr = lookupSymbol(nm);
4009         if(!addr)
4010         {
4011             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
4012             return 0;
4013         }
4014         ASSERT(addr);
4015
4016 #if i386_HOST_ARCH
4017         if(isJumpTable)
4018         {
4019             checkProddableBlock(oc,image + sect->offset + i*itemSize);
4020             *(image + sect->offset + i*itemSize) = 0xe9; // jmp
4021             *(unsigned*)(image + sect->offset + i*itemSize + 1)
4022                 = (char*)addr - (image + sect->offset + i*itemSize + 5);
4023         }
4024         else
4025 #endif
4026         {
4027             checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
4028             ((void**)(image + sect->offset))[i] = addr;
4029         }
4030     }
4031
4032     return 1;
4033 }
4034
4035 static unsigned long relocateAddress(
4036     ObjectCode* oc,
4037     int nSections,
4038     struct section* sections,
4039     unsigned long address)
4040 {
4041     int i;
4042     for(i = 0; i < nSections; i++)
4043     {
4044         if(sections[i].addr <= address
4045             && address < sections[i].addr + sections[i].size)
4046         {
4047             return (unsigned long)oc->image
4048                     + sections[i].offset + address - sections[i].addr;
4049         }
4050     }
4051     barf("Invalid Mach-O file:"
4052          "Address out of bounds while relocating object file");
4053     return 0;
4054 }
4055
4056 static int relocateSection(
4057     ObjectCode* oc,
4058     char *image,
4059     struct symtab_command *symLC, struct nlist *nlist,
4060     int nSections, struct section* sections, struct section *sect)
4061 {
4062     struct relocation_info *relocs;
4063     int i,n;
4064
4065     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
4066         return 1;
4067     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
4068         return 1;
4069     else if(!strcmp(sect->sectname,"__la_sym_ptr2"))
4070         return 1;
4071     else if(!strcmp(sect->sectname,"__la_sym_ptr3"))
4072         return 1;
4073
4074     n = sect->nreloc;
4075     relocs = (struct relocation_info*) (image + sect->reloff);
4076
4077     for(i=0;i<n;i++)
4078     {
4079 #ifdef x86_64_HOST_ARCH
4080         struct relocation_info *reloc = &relocs[i];
4081
4082         char    *thingPtr = image + sect->offset + reloc->r_address;
4083         uint64_t thing;
4084         uint64_t value;
4085         uint64_t baseValue;
4086         int type = reloc->r_type;
4087
4088         checkProddableBlock(oc,thingPtr);
4089         switch(reloc->r_length)
4090         {
4091             case 0:
4092                 thing = *(uint8_t*)thingPtr;
4093                 baseValue = (uint64_t)thingPtr + 1;
4094                 break;
4095             case 1:
4096                 thing = *(uint16_t*)thingPtr;
4097                 baseValue = (uint64_t)thingPtr + 2;
4098                 break;
4099             case 2:
4100                 thing = *(uint32_t*)thingPtr;
4101                 baseValue = (uint64_t)thingPtr + 4;
4102                 break;
4103             case 3:
4104                 thing = *(uint64_t*)thingPtr;
4105                 baseValue = (uint64_t)thingPtr + 8;
4106                 break;
4107             default:
4108                 barf("Unknown size.");
4109         }
4110
4111         if(type == X86_64_RELOC_GOT
4112            || type == X86_64_RELOC_GOT_LOAD)
4113         {
4114             ASSERT(reloc->r_extern);
4115             value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)->addr;
4116
4117             type = X86_64_RELOC_SIGNED;
4118         }
4119         else if(reloc->r_extern)
4120         {
4121             struct nlist *symbol = &nlist[reloc->r_symbolnum];
4122             char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4123             if(symbol->n_value == 0)
4124                 value = (uint64_t) lookupSymbol(nm);
4125             else
4126                 value = relocateAddress(oc, nSections, sections,
4127                                         symbol->n_value);
4128         }
4129         else
4130         {
4131             value = sections[reloc->r_symbolnum-1].offset
4132                   - sections[reloc->r_symbolnum-1].addr
4133                   + (uint64_t) image;
4134         }
4135
4136         if(type == X86_64_RELOC_BRANCH)
4137         {
4138             if((int32_t)(value - baseValue) != (int64_t)(value - baseValue))
4139             {
4140                 ASSERT(reloc->r_extern);
4141                 value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)
4142                                         -> jumpIsland;
4143             }
4144             ASSERT((int32_t)(value - baseValue) == (int64_t)(value - baseValue));
4145             type = X86_64_RELOC_SIGNED;
4146         }
4147
4148         switch(type)
4149         {
4150             case X86_64_RELOC_UNSIGNED:
4151                 ASSERT(!reloc->r_pcrel);
4152                 thing += value;
4153                 break;
4154             case X86_64_RELOC_SIGNED:
4155                 ASSERT(reloc->r_pcrel);
4156                 thing += value - baseValue;
4157                 break;
4158             case X86_64_RELOC_SUBTRACTOR:
4159                 ASSERT(!reloc->r_pcrel);
4160                 thing -= value;
4161                 break;
4162             default:
4163                 barf("unkown relocation");
4164         }
4165
4166         switch(reloc->r_length)
4167         {
4168             case 0:
4169                 *(uint8_t*)thingPtr = thing;
4170                 break;
4171             case 1:
4172                 *(uint16_t*)thingPtr = thing;
4173                 break;
4174             case 2:
4175                 *(uint32_t*)thingPtr = thing;
4176                 break;
4177             case 3:
4178                 *(uint64_t*)thingPtr = thing;
4179                 break;
4180         }
4181 #else
4182         if(relocs[i].r_address & R_SCATTERED)
4183         {
4184             struct scattered_relocation_info *scat =
4185                 (struct scattered_relocation_info*) &relocs[i];
4186
4187             if(!scat->r_pcrel)
4188             {
4189                 if(scat->r_length == 2)
4190                 {
4191                     unsigned long word = 0;
4192                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
4193                     checkProddableBlock(oc,wordPtr);
4194
4195                     // Note on relocation types:
4196                     // i386 uses the GENERIC_RELOC_* types,
4197                     // while ppc uses special PPC_RELOC_* types.
4198                     // *_RELOC_VANILLA and *_RELOC_PAIR have the same value
4199                     // in both cases, all others are different.
4200                     // Therefore, we use GENERIC_RELOC_VANILLA
4201                     // and GENERIC_RELOC_PAIR instead of the PPC variants,
4202                     // and use #ifdefs for the other types.
4203
4204                     // Step 1: Figure out what the relocated value should be
4205                     if(scat->r_type == GENERIC_RELOC_VANILLA)
4206                     {
4207                         word = *wordPtr + (unsigned long) relocateAddress(
4208                                                                 oc,
4209                                                                 nSections,
4210                                                                 sections,
4211                                                                 scat->r_value)
4212                                         - scat->r_value;
4213                     }
4214 #ifdef powerpc_HOST_ARCH
4215                     else if(scat->r_type == PPC_RELOC_SECTDIFF
4216                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
4217                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
4218                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
4219 #else
4220                     else if(scat->r_type == GENERIC_RELOC_SECTDIFF)
4221 #endif
4222                     {
4223                         struct scattered_relocation_info *pair =
4224                                 (struct scattered_relocation_info*) &relocs[i+1];
4225
4226                         if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR)
4227                             barf("Invalid Mach-O file: "
4228                                  "RELOC_*_SECTDIFF not followed by RELOC_PAIR");
4229
4230                         word = (unsigned long)
4231                                (relocateAddress(oc, nSections, sections, scat->r_value)
4232                               - relocateAddress(oc, nSections, sections, pair->r_value));
4233                         i++;
4234                     }
4235 #ifdef powerpc_HOST_ARCH
4236                     else if(scat->r_type == PPC_RELOC_HI16
4237                          || scat->r_type == PPC_RELOC_LO16
4238                          || scat->r_type == PPC_RELOC_HA16
4239                          || scat->r_type == PPC_RELOC_LO14)
4240                     {   // these are generated by label+offset things
4241                         struct relocation_info *pair = &relocs[i+1];
4242                         if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
4243                             barf("Invalid Mach-O file: "
4244                                  "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
4245
4246                         if(scat->r_type == PPC_RELOC_LO16)
4247                         {
4248                             word = ((unsigned short*) wordPtr)[1];
4249                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4250                         }
4251                         else if(scat->r_type == PPC_RELOC_LO14)
4252                         {
4253                             barf("Unsupported Relocation: PPC_RELOC_LO14");
4254                             word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
4255                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4256                         }
4257                         else if(scat->r_type == PPC_RELOC_HI16)
4258                         {
4259                             word = ((unsigned short*) wordPtr)[1] << 16;
4260                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4261                         }
4262                         else if(scat->r_type == PPC_RELOC_HA16)
4263                         {
4264                             word = ((unsigned short*) wordPtr)[1] << 16;
4265                             word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4266                         }
4267
4268
4269                         word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
4270                                                 - scat->r_value;
4271
4272                         i++;
4273                     }
4274  #endif
4275                     else
4276                         continue;  // ignore the others
4277
4278 #ifdef powerpc_HOST_ARCH
4279                     if(scat->r_type == GENERIC_RELOC_VANILLA
4280                         || scat->r_type == PPC_RELOC_SECTDIFF)
4281 #else
4282                     if(scat->r_type == GENERIC_RELOC_VANILLA
4283                         || scat->r_type == GENERIC_RELOC_SECTDIFF)
4284 #endif
4285                     {
4286                         *wordPtr = word;
4287                     }
4288 #ifdef powerpc_HOST_ARCH
4289                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
4290                     {
4291                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4292                     }
4293                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
4294                     {
4295                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4296                     }
4297                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
4298                     {
4299                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4300                             + ((word & (1<<15)) ? 1 : 0);
4301                     }
4302 #endif
4303                 }
4304             }
4305
4306             continue; // FIXME: I hope it's OK to ignore all the others.
4307         }
4308         else
4309         {
4310             struct relocation_info *reloc = &relocs[i];
4311             if(reloc->r_pcrel && !reloc->r_extern)
4312                 continue;
4313
4314             if(reloc->r_length == 2)
4315             {
4316                 unsigned long word = 0;
4317 #ifdef powerpc_HOST_ARCH
4318                 unsigned long jumpIsland = 0;
4319                 long offsetToJumpIsland = 0xBADBAD42; // initialise to bad value
4320                                                       // to avoid warning and to catch
4321                                                       // bugs.
4322 #endif
4323
4324                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
4325                 checkProddableBlock(oc,wordPtr);
4326
4327                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4328                 {
4329                     word = *wordPtr;
4330                 }
4331 #ifdef powerpc_HOST_ARCH
4332                 else if(reloc->r_type == PPC_RELOC_LO16)
4333                 {
4334                     word = ((unsigned short*) wordPtr)[1];
4335                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4336                 }
4337                 else if(reloc->r_type == PPC_RELOC_HI16)
4338                 {
4339                     word = ((unsigned short*) wordPtr)[1] << 16;
4340                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4341                 }
4342                 else if(reloc->r_type == PPC_RELOC_HA16)
4343                 {
4344                     word = ((unsigned short*) wordPtr)[1] << 16;
4345                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4346                 }
4347                 else if(reloc->r_type == PPC_RELOC_BR24)
4348                 {
4349                     word = *wordPtr;
4350                     word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0);
4351                 }
4352 #endif
4353
4354                 if(!reloc->r_extern)
4355                 {
4356                     long delta =
4357                         sections[reloc->r_symbolnum-1].offset
4358                         - sections[reloc->r_symbolnum-1].addr
4359                         + ((long) image);
4360
4361                     word += delta;
4362                 }
4363                 else
4364                 {
4365                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
4366                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4367                     void *symbolAddress = lookupSymbol(nm);
4368                     if(!symbolAddress)
4369                     {
4370                         errorBelch("\nunknown symbol `%s'", nm);
4371                         return 0;
4372                     }
4373
4374                     if(reloc->r_pcrel)
4375                     {
4376 #ifdef powerpc_HOST_ARCH
4377                             // In the .o file, this should be a relative jump to NULL
4378                             // and we'll change it to a relative jump to the symbol
4379                         ASSERT(word + reloc->r_address == 0);
4380                         jumpIsland = (unsigned long)
4381                                         &makeSymbolExtra(oc,
4382                                                          reloc->r_symbolnum,
4383                                                          (unsigned long) symbolAddress)
4384                                          -> jumpIsland;
4385                         if(jumpIsland != 0)
4386                         {
4387                             offsetToJumpIsland = word + jumpIsland
4388                                 - (((long)image) + sect->offset - sect->addr);
4389                         }
4390 #endif
4391                         word += (unsigned long) symbolAddress
4392                                 - (((long)image) + sect->offset - sect->addr);
4393                     }
4394                     else
4395                     {
4396                         word += (unsigned long) symbolAddress;
4397                     }
4398                 }
4399
4400                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4401                 {
4402                     *wordPtr = word;
4403                     continue;
4404                 }
4405 #ifdef powerpc_HOST_ARCH
4406                 else if(reloc->r_type == PPC_RELOC_LO16)
4407                 {
4408                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4409                     i++; continue;
4410                 }
4411                 else if(reloc->r_type == PPC_RELOC_HI16)
4412                 {
4413                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4414                     i++; continue;
4415                 }
4416                 else if(reloc->r_type == PPC_RELOC_HA16)
4417                 {
4418                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4419                         + ((word & (1<<15)) ? 1 : 0);
4420                     i++; continue;
4421                 }
4422                 else if(reloc->r_type == PPC_RELOC_BR24)
4423                 {
4424                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4425                     {
4426                         // The branch offset is too large.
4427                         // Therefore, we try to use a jump island.
4428                         if(jumpIsland == 0)
4429                         {
4430                             barf("unconditional relative branch out of range: "
4431                                  "no jump island available");
4432                         }
4433
4434                         word = offsetToJumpIsland;
4435                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4436                             barf("unconditional relative branch out of range: "
4437                                  "jump island out of range");
4438                     }
4439                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
4440                     continue;
4441                 }
4442 #endif
4443             }
4444             barf("\nunknown relocation %d",reloc->r_type);
4445             return 0;
4446         }
4447 #endif
4448     }
4449     return 1;
4450 }
4451
4452 static int ocGetNames_MachO(ObjectCode* oc)
4453 {
4454     char *image = (char*) oc->image;
4455     struct mach_header *header = (struct mach_header*) image;
4456     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4457     unsigned i,curSymbol = 0;
4458     struct segment_command *segLC = NULL;
4459     struct section *sections;
4460     struct symtab_command *symLC = NULL;
4461     struct nlist *nlist;
4462     unsigned long commonSize = 0;
4463     char    *commonStorage = NULL;
4464     unsigned long commonCounter;
4465
4466     for(i=0;i<header->ncmds;i++)
4467     {
4468         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4469             segLC = (struct segment_command*) lc;
4470         else if(lc->cmd == LC_SYMTAB)
4471             symLC = (struct symtab_command*) lc;
4472         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4473     }
4474
4475     sections = (struct section*) (segLC+1);
4476     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4477                   : NULL;
4478
4479     if(!segLC)
4480         barf("ocGetNames_MachO: no segment load command");
4481
4482     for(i=0;i<segLC->nsects;i++)
4483     {
4484         if(sections[i].size == 0)
4485             continue;
4486
4487         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
4488         {
4489             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
4490                                       "ocGetNames_MachO(common symbols)");
4491             sections[i].offset = zeroFillArea - image;
4492         }
4493
4494         if(!strcmp(sections[i].sectname,"__text"))
4495             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
4496                 (void*) (image + sections[i].offset),
4497                 (void*) (image + sections[i].offset + sections[i].size));
4498         else if(!strcmp(sections[i].sectname,"__const"))
4499             addSection(oc, SECTIONKIND_RWDATA,
4500                 (void*) (image + sections[i].offset),
4501                 (void*) (image + sections[i].offset + sections[i].size));
4502         else if(!strcmp(sections[i].sectname,"__data"))
4503             addSection(oc, SECTIONKIND_RWDATA,
4504                 (void*) (image + sections[i].offset),
4505                 (void*) (image + sections[i].offset + sections[i].size));
4506         else if(!strcmp(sections[i].sectname,"__bss")
4507                 || !strcmp(sections[i].sectname,"__common"))
4508             addSection(oc, SECTIONKIND_RWDATA,
4509                 (void*) (image + sections[i].offset),
4510                 (void*) (image + sections[i].offset + sections[i].size));
4511
4512         addProddableBlock(oc, (void*) (image + sections[i].offset),
4513                                         sections[i].size);
4514     }
4515
4516         // count external symbols defined here
4517     oc->n_symbols = 0;
4518     if(symLC)
4519     {
4520         for(i=0;i<symLC->nsyms;i++)
4521         {
4522             if(nlist[i].n_type & N_STAB)
4523                 ;
4524             else if(nlist[i].n_type & N_EXT)
4525             {
4526                 if((nlist[i].n_type & N_TYPE) == N_UNDF
4527                     && (nlist[i].n_value != 0))
4528                 {
4529                     commonSize += nlist[i].n_value;
4530                     oc->n_symbols++;
4531                 }
4532                 else if((nlist[i].n_type & N_TYPE) == N_SECT)
4533                     oc->n_symbols++;
4534             }
4535         }
4536     }
4537     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
4538                                    "ocGetNames_MachO(oc->symbols)");
4539
4540     if(symLC)
4541     {
4542         for(i=0;i<symLC->nsyms;i++)
4543         {
4544             if(nlist[i].n_type & N_STAB)
4545                 ;
4546             else if((nlist[i].n_type & N_TYPE) == N_SECT)
4547             {
4548                 if(nlist[i].n_type & N_EXT)
4549                 {
4550                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4551                     if((nlist[i].n_desc & N_WEAK_DEF) && lookupSymbol(nm))
4552                         ; // weak definition, and we already have a definition
4553                     else
4554                     {
4555                             ghciInsertStrHashTable(oc->fileName, symhash, nm,
4556                                                     image
4557                                                     + sections[nlist[i].n_sect-1].offset
4558                                                     - sections[nlist[i].n_sect-1].addr
4559                                                     + nlist[i].n_value);
4560                             oc->symbols[curSymbol++] = nm;
4561                     }
4562                 }
4563             }
4564         }
4565     }
4566
4567     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
4568     commonCounter = (unsigned long)commonStorage;
4569     if(symLC)
4570     {
4571         for(i=0;i<symLC->nsyms;i++)
4572         {
4573             if((nlist[i].n_type & N_TYPE) == N_UNDF
4574                     && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
4575             {
4576                 char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4577                 unsigned long sz = nlist[i].n_value;
4578
4579                 nlist[i].n_value = commonCounter;
4580
4581                 ghciInsertStrHashTable(oc->fileName, symhash, nm,
4582                                        (void*)commonCounter);
4583                 oc->symbols[curSymbol++] = nm;
4584
4585                 commonCounter += sz;
4586             }
4587         }
4588     }
4589     return 1;
4590 }
4591
4592 static int ocResolve_MachO(ObjectCode* oc)
4593 {
4594     char *image = (char*) oc->image;
4595     struct mach_header *header = (struct mach_header*) image;
4596     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4597     unsigned i;
4598     struct segment_command *segLC = NULL;
4599     struct section *sections;
4600     struct symtab_command *symLC = NULL;
4601     struct dysymtab_command *dsymLC = NULL;
4602     struct nlist *nlist;
4603
4604     for(i=0;i<header->ncmds;i++)
4605     {
4606         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4607             segLC = (struct segment_command*) lc;
4608         else if(lc->cmd == LC_SYMTAB)
4609             symLC = (struct symtab_command*) lc;
4610         else if(lc->cmd == LC_DYSYMTAB)
4611             dsymLC = (struct dysymtab_command*) lc;
4612         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4613     }
4614
4615     sections = (struct section*) (segLC+1);
4616     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4617                   : NULL;
4618
4619     if(dsymLC)
4620     {
4621         unsigned long *indirectSyms
4622             = (unsigned long*) (image + dsymLC->indirectsymoff);
4623
4624         for(i=0;i<segLC->nsects;i++)
4625         {
4626             if(    !strcmp(sections[i].sectname,"__la_symbol_ptr")
4627                 || !strcmp(sections[i].sectname,"__la_sym_ptr2")
4628                 || !strcmp(sections[i].sectname,"__la_sym_ptr3"))
4629             {
4630                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4631                     return 0;
4632             }
4633             else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr")
4634                 ||  !strcmp(sections[i].sectname,"__pointers"))
4635             {
4636                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4637                     return 0;
4638             }
4639             else if(!strcmp(sections[i].sectname,"__jump_table"))
4640             {
4641                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4642                     return 0;
4643             }
4644         }
4645     }
4646
4647     for(i=0;i<segLC->nsects;i++)
4648     {
4649         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
4650             return 0;
4651     }
4652
4653 #if defined (powerpc_HOST_ARCH)
4654     ocFlushInstructionCache( oc );
4655 #endif
4656
4657     return 1;
4658 }
4659
4660 #ifdef powerpc_HOST_ARCH
4661 /*
4662  * The Mach-O object format uses leading underscores. But not everywhere.
4663  * There is a small number of runtime support functions defined in
4664  * libcc_dynamic.a whose name does not have a leading underscore.
4665  * As a consequence, we can't get their address from C code.
4666  * We have to use inline assembler just to take the address of a function.
4667  * Yuck.
4668  */
4669
4670 static void machoInitSymbolsWithoutUnderscore()
4671 {
4672     extern void* symbolsWithoutUnderscore[];
4673     void **p = symbolsWithoutUnderscore;
4674     __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:");
4675
4676 #undef Sym
4677 #define SymI_NeedsProto(x)  \
4678     __asm__ volatile(".long " # x);
4679
4680     RTS_MACHO_NOUNDERLINE_SYMBOLS
4681
4682     __asm__ volatile(".text");
4683
4684 #undef Sym
4685 #define SymI_NeedsProto(x)  \
4686     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
4687
4688     RTS_MACHO_NOUNDERLINE_SYMBOLS
4689
4690 #undef Sym
4691 }
4692 #endif
4693
4694 /*
4695  * Figure out by how much to shift the entire Mach-O file in memory
4696  * when loading so that its single segment ends up 16-byte-aligned
4697  */
4698 static int machoGetMisalignment( FILE * f )
4699 {
4700     struct mach_header header;
4701     int misalignment;
4702
4703     fread(&header, sizeof(header), 1, f);
4704     rewind(f);
4705
4706 #if x86_64_TARGET_ARCH || powerpc64_TARGET_ARCH
4707     if(header.magic != MH_MAGIC_64)
4708         return 0;
4709 #else
4710     if(header.magic != MH_MAGIC)
4711         return 0;
4712 #endif
4713
4714     misalignment = (header.sizeofcmds + sizeof(header))
4715                     & 0xF;
4716
4717     return misalignment ? (16 - misalignment) : 0;
4718 }
4719
4720 #endif
4721