rts/Linker.c

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