rts/Linker.c

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