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