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