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