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