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