rts/Linker.c

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