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