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