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