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