rts/Linker.c

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