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