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