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