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