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