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