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