rts/Linker.c

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