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