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