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