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