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