rts/Linker.c

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