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