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