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