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