rts/Linker.c

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