rts/Linker.c

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