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