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