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