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    stg_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     IF_DEBUG(linker, debugBelch("initLinker: start\n"));
1139
1140     /* Make initLinker idempotent, so we can call it
1141        before evey relevant operation; that means we
1142        don't need to initialise the linker separately */
1143     if (linker_init_done == 1) {
1144         IF_DEBUG(linker, debugBelch("initLinker: idempotent return\n"));
1145         return;
1146     } else {
1147         linker_init_done = 1;
1148     }
1149
1150 #if defined(THREADED_RTS) && (defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO))
1151     initMutex(&dl_mutex);
1152 #endif
1153     stablehash = allocStrHashTable();
1154     symhash = allocStrHashTable();
1155
1156     /* populate the symbol table with stuff from the RTS */
1157     for (sym = rtsSyms; sym->lbl != NULL; sym++) {
1158         ghciInsertStrHashTable("(GHCi built-in symbols)",
1159                                symhash, sym->lbl, sym->addr);
1160         IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
1161     }
1162 #   if defined(OBJFORMAT_MACHO) && defined(powerpc_HOST_ARCH)
1163     machoInitSymbolsWithoutUnderscore();
1164 #   endif
1165
1166 #   if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1167 #   if defined(RTLD_DEFAULT)
1168     dl_prog_handle = RTLD_DEFAULT;
1169 #   else
1170     dl_prog_handle = dlopen(NULL, RTLD_LAZY);
1171 #   endif /* RTLD_DEFAULT */
1172
1173     compileResult = regcomp(&re_invalid,
1174            "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*invalid ELF header",
1175            REG_EXTENDED);
1176     ASSERT( compileResult == 0 );
1177     compileResult = regcomp(&re_realso,
1178            "GROUP *\\( *(([^ )])+)",
1179            REG_EXTENDED);
1180     ASSERT( compileResult == 0 );
1181 #   endif
1182
1183 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1184     if (RtsFlags.MiscFlags.linkerMemBase != 0) {
1185         // User-override for mmap_32bit_base
1186         mmap_32bit_base = (void*)RtsFlags.MiscFlags.linkerMemBase;
1187     }
1188 #endif
1189
1190 #if defined(mingw32_HOST_OS)
1191     /*
1192      * These two libraries cause problems when added to the static link,
1193      * but are necessary for resolving symbols in GHCi, hence we load
1194      * them manually here.
1195      */
1196     addDLL("msvcrt");
1197     addDLL("kernel32");
1198 #endif
1199
1200     IF_DEBUG(linker, debugBelch("initLinker: done\n"));
1201     return;
1202 }
1203
1204 void
1205 exitLinker( void ) {
1206 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1207    if (linker_init_done == 1) {
1208       regfree(&re_invalid);
1209       regfree(&re_realso);
1210 #ifdef THREADED_RTS
1211       closeMutex(&dl_mutex);
1212 #endif
1213    }
1214 #endif
1215 }
1216
1217 /* -----------------------------------------------------------------------------
1218  *                  Loading DLL or .so dynamic libraries
1219  * -----------------------------------------------------------------------------
1220  *
1221  * Add a DLL from which symbols may be found.  In the ELF case, just
1222  * do RTLD_GLOBAL-style add, so no further messing around needs to
1223  * happen in order that symbols in the loaded .so are findable --
1224  * lookupSymbol() will subsequently see them by dlsym on the program's
1225  * dl-handle.  Returns NULL if success, otherwise ptr to an err msg.
1226  *
1227  * In the PEi386 case, open the DLLs and put handles to them in a
1228  * linked list.  When looking for a symbol, try all handles in the
1229  * list.  This means that we need to load even DLLs that are guaranteed
1230  * to be in the ghc.exe image already, just so we can get a handle
1231  * to give to loadSymbol, so that we can find the symbols.  For such
1232  * libraries, the LoadLibrary call should be a no-op except for returning
1233  * the handle.
1234  *
1235  */
1236
1237 #if defined(OBJFORMAT_PEi386)
1238 /* A record for storing handles into DLLs. */
1239
1240 typedef
1241    struct _OpenedDLL {
1242       char*              name;
1243       struct _OpenedDLL* next;
1244       HINSTANCE instance;
1245    }
1246    OpenedDLL;
1247
1248 /* A list thereof. */
1249 static OpenedDLL* opened_dlls = NULL;
1250 #endif
1251
1252 #  if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1253
1254 static const char *
1255 internal_dlopen(const char *dll_name)
1256 {
1257    void *hdl;
1258    const char *errmsg;
1259    char *errmsg_copy;
1260
1261    // omitted: RTLD_NOW
1262    // see http://www.haskell.org/pipermail/cvs-ghc/2007-September/038570.html
1263    IF_DEBUG(linker,
1264       debugBelch("internal_dlopen: dll_name = '%s'\n", dll_name));
1265
1266    //-------------- Begin critical section ------------------
1267    // This critical section is necessary because dlerror() is not
1268    // required to be reentrant (see POSIX -- IEEE Std 1003.1-2008)
1269    // Also, the error message returned must be copied to preserve it
1270    // (see POSIX also)
1271
1272    ACQUIRE_LOCK(&dl_mutex);
1273    hdl = dlopen(dll_name, RTLD_LAZY | RTLD_GLOBAL);
1274
1275    errmsg = NULL;
1276    if (hdl == NULL) {
1277       /* dlopen failed; return a ptr to the error msg. */
1278       errmsg = dlerror();
1279       if (errmsg == NULL) errmsg = "addDLL: unknown error";
1280       errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL");
1281       strcpy(errmsg_copy, errmsg);
1282       errmsg = errmsg_copy;
1283    }
1284    RELEASE_LOCK(&dl_mutex);
1285    //--------------- End critical section -------------------
1286
1287    return errmsg;
1288 }
1289 #  endif
1290
1291 const char *
1292 addDLL( char *dll_name )
1293 {
1294 #  if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
1295    /* ------------------- ELF DLL loader ------------------- */
1296
1297 #define NMATCH 5
1298    regmatch_t match[NMATCH];
1299    const char *errmsg;
1300    FILE* fp;
1301    size_t match_length;
1302 #define MAXLINE 1000
1303    char line[MAXLINE];
1304    int result;
1305
1306    initLinker();
1307
1308    IF_DEBUG(linker, debugBelch("addDLL: dll_name = '%s'\n", dll_name));
1309    errmsg = internal_dlopen(dll_name);
1310
1311    if (errmsg == NULL) {
1312       return NULL;
1313    }
1314
1315    // GHC Trac ticket #2615
1316    // On some systems (e.g., Gentoo Linux) dynamic files (e.g. libc.so)
1317    // contain linker scripts rather than ELF-format object code. This
1318    // code handles the situation by recognizing the real object code
1319    // file name given in the linker script.
1320    //
1321    // If an "invalid ELF header" error occurs, it is assumed that the
1322    // .so file contains a linker script instead of ELF object code.
1323    // In this case, the code looks for the GROUP ( ... ) linker
1324    // directive. If one is found, the first file name inside the
1325    // parentheses is treated as the name of a dynamic library and the
1326    // code attempts to dlopen that file. If this is also unsuccessful,
1327    // an error message is returned.
1328
1329    // see if the error message is due to an invalid ELF header
1330    IF_DEBUG(linker, debugBelch("errmsg = '%s'\n", errmsg));
1331    result = regexec(&re_invalid, errmsg, (size_t) NMATCH, match, 0);
1332    IF_DEBUG(linker, debugBelch("result = %i\n", result));
1333    if (result == 0) {
1334       // success -- try to read the named file as a linker script
1335       match_length = (size_t) stg_min((match[1].rm_eo - match[1].rm_so),
1336                                  MAXLINE-1);
1337       strncpy(line, (errmsg+(match[1].rm_so)),match_length);
1338       line[match_length] = '\0'; // make sure string is null-terminated
1339       IF_DEBUG(linker, debugBelch ("file name = '%s'\n", line));
1340       if ((fp = fopen(line, "r")) == NULL) {
1341          return errmsg; // return original error if open fails
1342       }
1343       // try to find a GROUP ( ... ) command
1344       while (fgets(line, MAXLINE, fp) != NULL) {
1345          IF_DEBUG(linker, debugBelch("input line = %s", line));
1346          if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) {
1347             // success -- try to dlopen the first named file
1348             IF_DEBUG(linker, debugBelch("match%s\n",""));
1349             line[match[1].rm_eo] = '\0';
1350             errmsg = internal_dlopen(line+match[1].rm_so);
1351             break;
1352          }
1353          // if control reaches here, no GROUP ( ... ) directive was found
1354          // and the original error message is returned to the caller
1355       }
1356       fclose(fp);
1357    }
1358    return errmsg;
1359
1360 #  elif defined(OBJFORMAT_PEi386)
1361    /* ------------------- Win32 DLL loader ------------------- */
1362
1363    char*      buf;
1364    OpenedDLL* o_dll;
1365    HINSTANCE  instance;
1366
1367    initLinker();
1368
1369    /* debugBelch("\naddDLL; dll_name = `%s'\n", dll_name); */
1370
1371    /* See if we've already got it, and ignore if so. */
1372    for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
1373       if (0 == strcmp(o_dll->name, dll_name))
1374          return NULL;
1375    }
1376
1377    /* The file name has no suffix (yet) so that we can try
1378       both foo.dll and foo.drv
1379
1380       The documentation for LoadLibrary says:
1381         If no file name extension is specified in the lpFileName
1382         parameter, the default library extension .dll is
1383         appended. However, the file name string can include a trailing
1384         point character (.) to indicate that the module name has no
1385         extension. */
1386
1387    buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
1388    sprintf(buf, "%s.DLL", dll_name);
1389    instance = LoadLibrary(buf);
1390    if (instance == NULL) {
1391        if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
1392        // KAA: allow loading of drivers (like winspool.drv)
1393        sprintf(buf, "%s.DRV", dll_name);
1394        instance = LoadLibrary(buf);
1395        if (instance == NULL) {
1396            if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
1397            // #1883: allow loading of unix-style libfoo.dll DLLs
1398            sprintf(buf, "lib%s.DLL", dll_name);
1399            instance = LoadLibrary(buf);
1400            if (instance == NULL) {
1401                goto error;
1402            }
1403        }
1404    }
1405    stgFree(buf);
1406
1407    /* Add this DLL to the list of DLLs in which to search for symbols. */
1408    o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
1409    o_dll->name     = stgMallocBytes(1+strlen(dll_name), "addDLL");
1410    strcpy(o_dll->name, dll_name);
1411    o_dll->instance = instance;
1412    o_dll->next     = opened_dlls;
1413    opened_dlls     = o_dll;
1414
1415    return NULL;
1416
1417 error:
1418    stgFree(buf);
1419    sysErrorBelch(dll_name);
1420
1421    /* LoadLibrary failed; return a ptr to the error msg. */
1422    return "addDLL: could not load DLL";
1423
1424 #  else
1425    barf("addDLL: not implemented on this platform");
1426 #  endif
1427 }
1428
1429 /* -----------------------------------------------------------------------------
1430  * insert a stable symbol in the hash table
1431  */
1432
1433 void
1434 insertStableSymbol(char* obj_name, char* key, StgPtr p)
1435 {
1436   ghciInsertStrHashTable(obj_name, stablehash, key, getStablePtr(p));
1437 }
1438
1439
1440 /* -----------------------------------------------------------------------------
1441  * insert a symbol in the hash table
1442  */
1443 void
1444 insertSymbol(char* obj_name, char* key, void* data)
1445 {
1446   ghciInsertStrHashTable(obj_name, symhash, key, data);
1447 }
1448
1449 /* -----------------------------------------------------------------------------
1450  * lookup a symbol in the hash table
1451  */
1452 void *
1453 lookupSymbol( char *lbl )
1454 {
1455     void *val;
1456     IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s\n", lbl));
1457     initLinker() ;
1458     ASSERT(symhash != NULL);
1459     val = lookupStrHashTable(symhash, lbl);
1460
1461     if (val == NULL) {
1462         IF_DEBUG(linker, debugBelch("lookupSymbol: symbol not found\n"));
1463 #       if defined(OBJFORMAT_ELF)
1464         return dlsym(dl_prog_handle, lbl);
1465 #       elif defined(OBJFORMAT_MACHO)
1466 #       if HAVE_DLFCN_H
1467         /* On OS X 10.3 and later, we use dlsym instead of the old legacy
1468            interface.
1469
1470            HACK: On OS X, global symbols are prefixed with an underscore.
1471                  However, dlsym wants us to omit the leading underscore from the
1472                  symbol name. For now, we simply strip it off here (and ONLY
1473                  here).
1474         */
1475         IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s with dlsym\n", lbl));
1476         ASSERT(lbl[0] == '_');
1477         return dlsym(dl_prog_handle, lbl+1);
1478 #       else
1479         if(NSIsSymbolNameDefined(lbl)) {
1480             NSSymbol symbol = NSLookupAndBindSymbol(lbl);
1481             return NSAddressOfSymbol(symbol);
1482         } else {
1483             return NULL;
1484         }
1485 #       endif /* HAVE_DLFCN_H */
1486 #       elif defined(OBJFORMAT_PEi386)
1487         void* sym;
1488
1489         sym = lookupSymbolInDLLs((unsigned char*)lbl);
1490         if (sym != NULL) { return sym; };
1491
1492         // Also try looking up the symbol without the @N suffix.  Some
1493         // DLLs have the suffixes on their symbols, some don't.
1494         zapTrailingAtSign ( (unsigned char*)lbl );
1495         sym = lookupSymbolInDLLs((unsigned char*)lbl);
1496         if (sym != NULL) { return sym; };
1497         return NULL;
1498
1499 #       else
1500         ASSERT(2+2 == 5);
1501         return NULL;
1502 #       endif
1503     } else {
1504         IF_DEBUG(linker, debugBelch("lookupSymbol: value of %s is %p\n", lbl, val));
1505         return val;
1506     }
1507 }
1508
1509 /* -----------------------------------------------------------------------------
1510  * Debugging aid: look in GHCi's object symbol tables for symbols
1511  * within DELTA bytes of the specified address, and show their names.
1512  */
1513 #ifdef DEBUG
1514 void ghci_enquire ( char* addr );
1515
1516 void ghci_enquire ( char* addr )
1517 {
1518    int   i;
1519    char* sym;
1520    char* a;
1521    const int DELTA = 64;
1522    ObjectCode* oc;
1523
1524    initLinker();
1525
1526    for (oc = objects; oc; oc = oc->next) {
1527       for (i = 0; i < oc->n_symbols; i++) {
1528          sym = oc->symbols[i];
1529          if (sym == NULL) continue;
1530          a = NULL;
1531          if (a == NULL) {
1532             a = lookupStrHashTable(symhash, sym);
1533          }
1534          if (a == NULL) {
1535              // debugBelch("ghci_enquire: can't find %s\n", sym);
1536          }
1537          else if (addr-DELTA <= a && a <= addr+DELTA) {
1538             debugBelch("%p + %3d  ==  `%s'\n", addr, (int)(a - addr), sym);
1539          }
1540       }
1541    }
1542 }
1543 #endif
1544
1545 #ifdef USE_MMAP
1546 #define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))
1547
1548 static void *
1549 mmapForLinker (size_t bytes, nat flags, int fd)
1550 {
1551    void *map_addr = NULL;
1552    void *result;
1553    int pagesize, size;
1554    static nat fixed = 0;
1555
1556    pagesize = getpagesize();
1557    size = ROUND_UP(bytes, pagesize);
1558
1559 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1560 mmap_again:
1561
1562    if (mmap_32bit_base != 0) {
1563        map_addr = mmap_32bit_base;
1564    }
1565 #endif
1566
1567    result = mmap(map_addr, size, PROT_EXEC|PROT_READ|PROT_WRITE,
1568                     MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, 0);
1569
1570    if (result == MAP_FAILED) {
1571        sysErrorBelch("mmap %lu bytes at %p",(lnat)size,map_addr);
1572        errorBelch("Try specifying an address with +RTS -xm<addr> -RTS");
1573        stg_exit(EXIT_FAILURE);
1574    }
1575
1576 #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH)
1577    if (mmap_32bit_base != 0) {
1578        if (result == map_addr) {
1579            mmap_32bit_base = (StgWord8*)map_addr + size;
1580        } else {
1581            if ((W_)result > 0x80000000) {
1582                // oops, we were given memory over 2Gb
1583 #if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)
1584                // Some platforms require MAP_FIXED.  This is normally
1585                // a bad idea, because MAP_FIXED will overwrite
1586                // existing mappings.
1587                munmap(result,size);
1588                fixed = MAP_FIXED;
1589                goto mmap_again;
1590 #else
1591                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);
1592 #endif
1593            } else {
1594                // hmm, we were given memory somewhere else, but it's
1595                // still under 2Gb so we can use it.  Next time, ask
1596                // for memory right after the place we just got some
1597                mmap_32bit_base = (StgWord8*)result + size;
1598            }
1599        }
1600    } else {
1601        if ((W_)result > 0x80000000) {
1602            // oops, we were given memory over 2Gb
1603            // ... try allocating memory somewhere else?;
1604            debugTrace(DEBUG_linker,"MAP_32BIT didn't work; gave us %lu bytes at 0x%p", bytes, result);
1605            munmap(result, size);
1606
1607            // Set a base address and try again... (guess: 1Gb)
1608            mmap_32bit_base = (void*)0x40000000;
1609            goto mmap_again;
1610        }
1611    }
1612 #endif
1613
1614    return result;
1615 }
1616 #endif // USE_MMAP
1617
1618 static ObjectCode*
1619 mkOc( char *path, char *image, int imageSize,
1620       char *archiveMemberName
1621 #ifndef USE_MMAP
1622 #ifdef darwin_HOST_OS
1623     , int misalignment
1624 #endif
1625 #endif
1626     ) {
1627    ObjectCode* oc;
1628
1629    oc = stgMallocBytes(sizeof(ObjectCode), "loadArchive(oc)");
1630
1631 #  if defined(OBJFORMAT_ELF)
1632    oc->formatName = "ELF";
1633 #  elif defined(OBJFORMAT_PEi386)
1634    oc->formatName = "PEi386";
1635 #  elif defined(OBJFORMAT_MACHO)
1636    oc->formatName = "Mach-O";
1637 #  else
1638    stgFree(oc);
1639    barf("loadObj: not implemented on this platform");
1640 #  endif
1641
1642    oc->image = image;
1643    /* sigh, strdup() isn't a POSIX function, so do it the long way */
1644    oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
1645    strcpy(oc->fileName, path);
1646
1647    if (archiveMemberName) {
1648        oc->archiveMemberName = stgMallocBytes( strlen(archiveMemberName)+1, "loadObj" );
1649        strcpy(oc->archiveMemberName, archiveMemberName);
1650    }
1651    else {
1652        oc->archiveMemberName = NULL;
1653    }
1654
1655    oc->fileSize          = imageSize;
1656    oc->symbols           = NULL;
1657    oc->sections          = NULL;
1658    oc->proddables        = NULL;
1659
1660 #ifndef USE_MMAP
1661 #ifdef darwin_HOST_OS
1662    oc->misalignment = misalignment;
1663 #endif
1664 #endif
1665
1666    /* chain it onto the list of objects */
1667    oc->next              = objects;
1668    objects               = oc;
1669
1670    return oc;
1671 }
1672
1673 HsInt
1674 loadArchive( char *path )
1675 {
1676    ObjectCode* oc;
1677    char *image;
1678    int imageSize;
1679    FILE *f;
1680    int n;
1681    size_t fileNameSize;
1682    char *file;
1683    size_t fileSize;
1684    int isObject;
1685    char tmp[12];
1686
1687    IF_DEBUG(linker, debugBelch("loadArchive: Loading archive `%s'\n", path));
1688
1689    fileSize = 32;
1690    file = stgMallocBytes(fileSize, "loadArchive(file)");
1691
1692    f = fopen(path, "rb");
1693    if (!f)
1694        barf("loadObj: can't read `%s'", path);
1695
1696    n = fread ( tmp, 1, 8, f );
1697    if (strncmp(tmp, "!<arch>\n", 8) != 0)
1698        barf("loadArchive: Not an archive: `%s'", path);
1699
1700    while(1) {
1701        n = fread ( file, 1, 16, f );
1702        if (n != 16) {
1703            if (feof(f)) {
1704                break;
1705            }
1706            else {
1707                barf("loadArchive: Failed reading file name from `%s'", path);
1708            }
1709        }
1710        n = fread ( tmp, 1, 12, f );
1711        if (n != 12)
1712            barf("loadArchive: Failed reading mod time from `%s'", path);
1713        n = fread ( tmp, 1, 6, f );
1714        if (n != 6)
1715            barf("loadArchive: Failed reading owner from `%s'", path);
1716        n = fread ( tmp, 1, 6, f );
1717        if (n != 6)
1718            barf("loadArchive: Failed reading group from `%s'", path);
1719        n = fread ( tmp, 1, 8, f );
1720        if (n != 8)
1721            barf("loadArchive: Failed reading mode from `%s'", path);
1722        n = fread ( tmp, 1, 10, f );
1723        if (n != 10)
1724            barf("loadArchive: Failed reading size from `%s'", path);
1725        tmp[10] = '\0';
1726        for (n = 0; isdigit(tmp[n]); n++);
1727        tmp[n] = '\0';
1728        imageSize = atoi(tmp);
1729        n = fread ( tmp, 1, 2, f );
1730        if (strncmp(tmp, "\x60\x0A", 2) != 0)
1731            barf("loadArchive: Failed reading magic from `%s' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]);
1732
1733        /* Check for BSD-variant large filenames */
1734        if (0 == strncmp(file, "#1/", 3)) {
1735            file[16] = '\0';
1736            for (n = 3; isdigit(file[n]); n++);
1737            file[n] = '\0';
1738            fileNameSize = atoi(file + 3);
1739            imageSize -= fileNameSize;
1740            if (fileNameSize > fileSize) {
1741                /* Double it to avoid potentially continually
1742                   increasing it by 1 */
1743                fileSize = fileNameSize * 2;
1744                file = stgReallocBytes(file, fileSize, "loadArchive(file)");
1745            }
1746            n = fread ( file, 1, fileNameSize, f );
1747            if (n != (int)fileNameSize)
1748                barf("loadArchive: Failed reading filename from `%s'", path);
1749        }
1750        else {
1751            fileNameSize = 16;
1752        }
1753
1754        IF_DEBUG(linker, debugBelch("loadArchive: Found member file `%s'\n", file));
1755
1756        isObject = 0;
1757        for (n = 0; n < (int)fileNameSize - 1; n++) {
1758            if ((file[n] == '.') && (file[n + 1] == 'o')) {
1759                isObject = 1;
1760                break;
1761            }
1762        }
1763
1764        if (isObject) {
1765            char *archiveMemberName;
1766
1767            IF_DEBUG(linker, debugBelch("loadArchive: Member is an object file...loading...\n"));
1768
1769            /* We can't mmap from the archive directly, as object
1770               files need to be 8-byte aligned but files in .ar
1771               archives are 2-byte aligned. When possible we use mmap
1772               to get some anonymous memory, as on 64-bit platforms if
1773               we use malloc then we can be given memory above 2^32.
1774               In the mmap case we're probably wasting lots of space;
1775               we could do better. */
1776 #ifdef USE_MMAP
1777            image = mmapForLinker(imageSize, MAP_ANONYMOUS, -1);
1778 #else
1779            image = stgMallocBytes(imageSize, "loadArchive(image)");
1780 #endif
1781            n = fread ( image, 1, imageSize, f );
1782            if (n != imageSize)
1783                barf("loadObj: error whilst reading `%s'", path);
1784
1785            archiveMemberName = stgMallocBytes(strlen(path) + fileNameSize + 3, "loadArchive(file)");
1786            sprintf(archiveMemberName, "%s(%.*s)", path, (int)fileNameSize, file);
1787
1788            oc = mkOc(path, image, imageSize, archiveMemberName
1789 #ifndef USE_MMAP
1790 #ifdef darwin_HOST_OS
1791                     , 0
1792 #endif
1793 #endif
1794                     );
1795
1796            stgFree(archiveMemberName);
1797
1798            if (0 == loadOc(oc)) {
1799                stgFree(file);
1800                return 0;
1801            }
1802        }
1803        else {
1804            n = fseek(f, imageSize, SEEK_CUR);
1805            if (n != 0)
1806                barf("loadArchive: error whilst seeking by %d in `%s'",
1807                     imageSize, path);
1808        }
1809        /* .ar files are 2-byte aligned */
1810        if (imageSize % 2) {
1811            n = fread ( tmp, 1, 1, f );
1812            if (n != 1) {
1813                if (feof(f)) {
1814                    break;
1815                }
1816                else {
1817                    barf("loadArchive: Failed reading padding from `%s'", path);
1818                }
1819            }
1820        }
1821    }
1822
1823    fclose(f);
1824
1825    stgFree(file);
1826    return 1;
1827 }
1828
1829 /* -----------------------------------------------------------------------------
1830  * Load an obj (populate the global symbol table, but don't resolve yet)
1831  *
1832  * Returns: 1 if ok, 0 on error.
1833  */
1834 HsInt
1835 loadObj( char *path )
1836 {
1837    ObjectCode* oc;
1838    char *image;
1839    int fileSize;
1840    struct stat st;
1841    int r;
1842 #ifdef USE_MMAP
1843    int fd;
1844 #else
1845    FILE *f;
1846 #endif
1847    IF_DEBUG(linker, debugBelch("loadObj %s\n", path));
1848
1849    initLinker();
1850
1851    /* debugBelch("loadObj %s\n", path ); */
1852
1853    /* Check that we haven't already loaded this object.
1854       Ignore requests to load multiple times */
1855    {
1856        ObjectCode *o;
1857        int is_dup = 0;
1858        for (o = objects; o; o = o->next) {
1859           if (0 == strcmp(o->fileName, path)) {
1860              is_dup = 1;
1861              break; /* don't need to search further */
1862           }
1863        }
1864        if (is_dup) {
1865           IF_DEBUG(linker, debugBelch(
1866             "GHCi runtime linker: warning: looks like you're trying to load the\n"
1867             "same object file twice:\n"
1868             "   %s\n"
1869             "GHCi will ignore this, but be warned.\n"
1870             , path));
1871           return 1; /* success */
1872        }
1873    }
1874
1875    r = stat(path, &st);
1876    if (r == -1) {
1877        IF_DEBUG(linker, debugBelch("File doesn't exist\n"));
1878        return 0;
1879    }
1880
1881    fileSize = st.st_size;
1882
1883 #ifdef USE_MMAP
1884    /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
1885
1886 #if defined(openbsd_HOST_OS)
1887    fd = open(path, O_RDONLY, S_IRUSR);
1888 #else
1889    fd = open(path, O_RDONLY);
1890 #endif
1891    if (fd == -1)
1892       barf("loadObj: can't open `%s'", path);
1893
1894    image = mmapForLinker(fileSize, 0, fd);
1895
1896    close(fd);
1897
1898 #else /* !USE_MMAP */
1899    /* load the image into memory */
1900    f = fopen(path, "rb");
1901    if (!f)
1902        barf("loadObj: can't read `%s'", path);
1903
1904 #   if defined(mingw32_HOST_OS)
1905         // TODO: We would like to use allocateExec here, but allocateExec
1906         //       cannot currently allocate blocks large enough.
1907     image = VirtualAlloc(NULL, fileSize, MEM_RESERVE | MEM_COMMIT,
1908                              PAGE_EXECUTE_READWRITE);
1909 #   elif defined(darwin_HOST_OS)
1910     // In a Mach-O .o file, all sections can and will be misaligned
1911     // if the total size of the headers is not a multiple of the
1912     // desired alignment. This is fine for .o files that only serve
1913     // as input for the static linker, but it's not fine for us,
1914     // as SSE (used by gcc for floating point) and Altivec require
1915     // 16-byte alignment.
1916     // We calculate the correct alignment from the header before
1917     // reading the file, and then we misalign image on purpose so
1918     // that the actual sections end up aligned again.
1919    misalignment = machoGetMisalignment(f);
1920    image = stgMallocBytes(fileSize + misalignment, "loadObj(image)");
1921    image += misalignment;
1922 #  else
1923    image = stgMallocBytes(fileSize, "loadObj(image)");
1924 #  endif
1925
1926    {
1927        int n;
1928        n = fread ( image, 1, fileSize, f );
1929        if (n != fileSize)
1930            barf("loadObj: error whilst reading `%s'", path);
1931    }
1932    fclose(f);
1933 #endif /* USE_MMAP */
1934
1935    oc = mkOc(path, image, fileSize, NULL
1936 #ifndef USE_MMAP
1937 #ifdef darwin_HOST_OS
1938             , misalignment
1939 #endif
1940 #endif
1941             );
1942
1943    return loadOc(oc);
1944 }
1945
1946 static HsInt
1947 loadOc( ObjectCode* oc ) {
1948    int r;
1949
1950    IF_DEBUG(linker, debugBelch("loadOc\n"));
1951
1952 #  if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1953    r = ocAllocateSymbolExtras_MachO ( oc );
1954    if (!r) {
1955        IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO failed\n"));
1956        return r;
1957    }
1958 #  elif defined(OBJFORMAT_ELF) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1959    r = ocAllocateSymbolExtras_ELF ( oc );
1960    if (!r) {
1961        IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_ELF failed\n"));
1962        return r;
1963    }
1964 #endif
1965
1966    /* verify the in-memory image */
1967 #  if defined(OBJFORMAT_ELF)
1968    r = ocVerifyImage_ELF ( oc );
1969 #  elif defined(OBJFORMAT_PEi386)
1970    r = ocVerifyImage_PEi386 ( oc );
1971 #  elif defined(OBJFORMAT_MACHO)
1972    r = ocVerifyImage_MachO ( oc );
1973 #  else
1974    barf("loadObj: no verify method");
1975 #  endif
1976    if (!r) {
1977        IF_DEBUG(linker, debugBelch("ocVerifyImage_* failed\n"));
1978        return r;
1979    }
1980
1981    /* build the symbol list for this image */
1982 #  if defined(OBJFORMAT_ELF)
1983    r = ocGetNames_ELF ( oc );
1984 #  elif defined(OBJFORMAT_PEi386)
1985    r = ocGetNames_PEi386 ( oc );
1986 #  elif defined(OBJFORMAT_MACHO)
1987    r = ocGetNames_MachO ( oc );
1988 #  else
1989    barf("loadObj: no getNames method");
1990 #  endif
1991    if (!r) {
1992        IF_DEBUG(linker, debugBelch("ocGetNames_* failed\n"));
1993        return r;
1994    }
1995
1996    /* loaded, but not resolved yet */
1997    oc->status = OBJECT_LOADED;
1998    IF_DEBUG(linker, debugBelch("loadObj done.\n"));
1999
2000    return 1;
2001 }
2002
2003 /* -----------------------------------------------------------------------------
2004  * resolve all the currently unlinked objects in memory
2005  *
2006  * Returns: 1 if ok, 0 on error.
2007  */
2008 HsInt
2009 resolveObjs( void )
2010 {
2011     ObjectCode *oc;
2012     int r;
2013
2014     IF_DEBUG(linker, debugBelch("resolveObjs: start\n"));
2015     initLinker();
2016
2017     for (oc = objects; oc; oc = oc->next) {
2018         if (oc->status != OBJECT_RESOLVED) {
2019 #           if defined(OBJFORMAT_ELF)
2020             r = ocResolve_ELF ( oc );
2021 #           elif defined(OBJFORMAT_PEi386)
2022             r = ocResolve_PEi386 ( oc );
2023 #           elif defined(OBJFORMAT_MACHO)
2024             r = ocResolve_MachO ( oc );
2025 #           else
2026             barf("resolveObjs: not implemented on this platform");
2027 #           endif
2028             if (!r) { return r; }
2029             oc->status = OBJECT_RESOLVED;
2030         }
2031     }
2032     IF_DEBUG(linker, debugBelch("resolveObjs: done\n"));
2033     return 1;
2034 }
2035
2036 /* -----------------------------------------------------------------------------
2037  * delete an object from the pool
2038  */
2039 HsInt
2040 unloadObj( char *path )
2041 {
2042     ObjectCode *oc, *prev;
2043     HsBool unloadedAnyObj = HS_BOOL_FALSE;
2044
2045     ASSERT(symhash != NULL);
2046     ASSERT(objects != NULL);
2047
2048     initLinker();
2049
2050     prev = NULL;
2051     for (oc = objects; oc; prev = oc, oc = oc->next) {
2052         if (!strcmp(oc->fileName,path)) {
2053
2054             /* Remove all the mappings for the symbols within this
2055              * object..
2056              */
2057             {
2058                 int i;
2059                 for (i = 0; i < oc->n_symbols; i++) {
2060                    if (oc->symbols[i] != NULL) {
2061                        removeStrHashTable(symhash, oc->symbols[i], NULL);
2062                    }
2063                 }
2064             }
2065
2066             if (prev == NULL) {
2067                 objects = oc->next;
2068             } else {
2069                 prev->next = oc->next;
2070             }
2071
2072             // We're going to leave this in place, in case there are
2073             // any pointers from the heap into it:
2074                 // #ifdef mingw32_HOST_OS
2075                 //  VirtualFree(oc->image);
2076                 // #else
2077             //  stgFree(oc->image);
2078             // #endif
2079             stgFree(oc->fileName);
2080             stgFree(oc->symbols);
2081             stgFree(oc->sections);
2082             stgFree(oc);
2083
2084             /* This could be a member of an archive so continue
2085              * unloading other members. */
2086             unloadedAnyObj = HS_BOOL_TRUE;
2087         }
2088     }
2089
2090     if (unloadedAnyObj) {
2091         return 1;
2092     }
2093     else {
2094         errorBelch("unloadObj: can't find `%s' to unload", path);
2095         return 0;
2096     }
2097 }
2098
2099 /* -----------------------------------------------------------------------------
2100  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
2101  * which may be prodded during relocation, and abort if we try and write
2102  * outside any of these.
2103  */
2104 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
2105 {
2106    ProddableBlock* pb
2107       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
2108    IF_DEBUG(linker, debugBelch("addProddableBlock %p %p %d\n", oc, start, size));
2109    ASSERT(size > 0);
2110    pb->start      = start;
2111    pb->size       = size;
2112    pb->next       = oc->proddables;
2113    oc->proddables = pb;
2114 }
2115
2116 static void checkProddableBlock ( ObjectCode* oc, void* addr )
2117 {
2118    ProddableBlock* pb;
2119    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
2120       char* s = (char*)(pb->start);
2121       char* e = s + pb->size - 1;
2122       char* a = (char*)addr;
2123       /* Assumes that the biggest fixup involves a 4-byte write.  This
2124          probably needs to be changed to 8 (ie, +7) on 64-bit
2125          plats. */
2126       if (a >= s && (a+3) <= e) return;
2127    }
2128    barf("checkProddableBlock: invalid fixup in runtime linker");
2129 }
2130
2131 /* -----------------------------------------------------------------------------
2132  * Section management.
2133  */
2134 static void addSection ( ObjectCode* oc, SectionKind kind,
2135                          void* start, void* end )
2136 {
2137    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
2138    s->start     = start;
2139    s->end       = end;
2140    s->kind      = kind;
2141    s->next      = oc->sections;
2142    oc->sections = s;
2143    /*
2144    debugBelch("addSection: %p-%p (size %d), kind %d\n",
2145                    start, ((char*)end)-1, end - start + 1, kind );
2146    */
2147 }
2148
2149
2150 /* --------------------------------------------------------------------------
2151  * Symbol Extras.
2152  * This is about allocating a small chunk of memory for every symbol in the
2153  * object file. We make sure that the SymboLExtras are always "in range" of
2154  * limited-range PC-relative instructions on various platforms by allocating
2155  * them right next to the object code itself.
2156  */
2157
2158 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
2159
2160 /*
2161   ocAllocateSymbolExtras
2162
2163   Allocate additional space at the end of the object file image to make room
2164   for jump islands (powerpc, x86_64) and GOT entries (x86_64).
2165
2166   PowerPC relative branch instructions have a 24 bit displacement field.
2167   As PPC code is always 4-byte-aligned, this yields a +-32MB range.
2168   If a particular imported symbol is outside this range, we have to redirect
2169   the jump to a short piece of new code that just loads the 32bit absolute
2170   address and jumps there.
2171   On x86_64, PC-relative jumps and PC-relative accesses to the GOT are limited
2172   to 32 bits (+-2GB).
2173
2174   This function just allocates space for one SymbolExtra for every
2175   undefined symbol in the object file. The code for the jump islands is
2176   filled in by makeSymbolExtra below.
2177 */
2178
2179 static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first )
2180 {
2181 #ifdef USE_MMAP
2182   int pagesize, n, m;
2183 #endif
2184   int aligned;
2185 #ifndef USE_MMAP
2186   int misalignment = 0;
2187 #ifdef darwin_HOST_OS
2188   misalignment = oc->misalignment;
2189 #endif
2190 #endif
2191
2192   if( count > 0 )
2193   {
2194     // round up to the nearest 4
2195     aligned = (oc->fileSize + 3) & ~3;
2196
2197 #ifdef USE_MMAP
2198     pagesize = getpagesize();
2199     n = ROUND_UP( oc->fileSize, pagesize );
2200     m = ROUND_UP( aligned + sizeof (SymbolExtra) * count, pagesize );
2201
2202     /* we try to use spare space at the end of the last page of the
2203      * image for the jump islands, but if there isn't enough space
2204      * then we have to map some (anonymously, remembering MAP_32BIT).
2205      */
2206     if( m > n ) // we need to allocate more pages
2207     {
2208         oc->symbol_extras = mmapForLinker(sizeof(SymbolExtra) * count,
2209                                           MAP_ANONYMOUS, -1);
2210     }
2211     else
2212     {
2213         oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
2214     }
2215 #else
2216     oc->image -= misalignment;
2217     oc->image = stgReallocBytes( oc->image,
2218                                  misalignment +
2219                                  aligned + sizeof (SymbolExtra) * count,
2220                                  "ocAllocateSymbolExtras" );
2221     oc->image += misalignment;
2222
2223     oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
2224 #endif /* USE_MMAP */
2225
2226     memset( oc->symbol_extras, 0, sizeof (SymbolExtra) * count );
2227   }
2228   else
2229     oc->symbol_extras = NULL;
2230
2231   oc->first_symbol_extra = first;
2232   oc->n_symbol_extras = count;
2233
2234   return 1;
2235 }
2236
2237 static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
2238                                      unsigned long symbolNumber,
2239                                      unsigned long target )
2240 {
2241   SymbolExtra *extra;
2242
2243   ASSERT( symbolNumber >= oc->first_symbol_extra
2244         && symbolNumber - oc->first_symbol_extra < oc->n_symbol_extras);
2245
2246   extra = &oc->symbol_extras[symbolNumber - oc->first_symbol_extra];
2247
2248 #ifdef powerpc_HOST_ARCH
2249   // lis r12, hi16(target)
2250   extra->jumpIsland.lis_r12     = 0x3d80;
2251   extra->jumpIsland.hi_addr     = target >> 16;
2252
2253   // ori r12, r12, lo16(target)
2254   extra->jumpIsland.ori_r12_r12 = 0x618c;
2255   extra->jumpIsland.lo_addr     = target & 0xffff;
2256
2257   // mtctr r12
2258   extra->jumpIsland.mtctr_r12   = 0x7d8903a6;
2259
2260   // bctr
2261   extra->jumpIsland.bctr        = 0x4e800420;
2262 #endif
2263 #ifdef x86_64_HOST_ARCH
2264         // jmp *-14(%rip)
2265   static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
2266   extra->addr = target;
2267   memcpy(extra->jumpIsland, jmp, 6);
2268 #endif
2269
2270   return extra;
2271 }
2272
2273 #endif
2274
2275 /* --------------------------------------------------------------------------
2276  * PowerPC specifics (instruction cache flushing)
2277  * ------------------------------------------------------------------------*/
2278
2279 #ifdef powerpc_HOST_ARCH
2280 /*
2281    ocFlushInstructionCache
2282
2283    Flush the data & instruction caches.
2284    Because the PPC has split data/instruction caches, we have to
2285    do that whenever we modify code at runtime.
2286  */
2287
2288 static void ocFlushInstructionCache( ObjectCode *oc )
2289 {
2290     int n = (oc->fileSize + sizeof( SymbolExtra ) * oc->n_symbol_extras + 3) / 4;
2291     unsigned long *p = (unsigned long *) oc->image;
2292
2293     while( n-- )
2294     {
2295         __asm__ volatile ( "dcbf 0,%0\n\t"
2296                            "sync\n\t"
2297                            "icbi 0,%0"
2298                            :
2299                            : "r" (p)
2300                          );
2301         p++;
2302     }
2303     __asm__ volatile ( "sync\n\t"
2304                        "isync"
2305                      );
2306 }
2307 #endif
2308
2309 /* --------------------------------------------------------------------------
2310  * PEi386 specifics (Win32 targets)
2311  * ------------------------------------------------------------------------*/
2312
2313 /* The information for this linker comes from
2314       Microsoft Portable Executable
2315       and Common Object File Format Specification
2316       revision 5.1 January 1998
2317    which SimonM says comes from the MS Developer Network CDs.
2318
2319    It can be found there (on older CDs), but can also be found
2320    online at:
2321
2322       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
2323
2324    (this is Rev 6.0 from February 1999).
2325
2326    Things move, so if that fails, try searching for it via
2327
2328       http://www.google.com/search?q=PE+COFF+specification
2329
2330    The ultimate reference for the PE format is the Winnt.h
2331    header file that comes with the Platform SDKs; as always,
2332    implementations will drift wrt their documentation.
2333
2334    A good background article on the PE format is Matt Pietrek's
2335    March 1994 article in Microsoft System Journal (MSJ)
2336    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
2337    Win32 Portable Executable File Format." The info in there
2338    has recently been updated in a two part article in
2339    MSDN magazine, issues Feb and March 2002,
2340    "Inside Windows: An In-Depth Look into the Win32 Portable
2341    Executable File Format"
2342
2343    John Levine's book "Linkers and Loaders" contains useful
2344    info on PE too.
2345 */
2346
2347
2348 #if defined(OBJFORMAT_PEi386)
2349
2350
2351
2352 typedef unsigned char  UChar;
2353 typedef unsigned short UInt16;
2354 typedef unsigned int   UInt32;
2355 typedef          int   Int32;
2356
2357
2358 typedef
2359    struct {
2360       UInt16 Machine;
2361       UInt16 NumberOfSections;
2362       UInt32 TimeDateStamp;
2363       UInt32 PointerToSymbolTable;
2364       UInt32 NumberOfSymbols;
2365       UInt16 SizeOfOptionalHeader;
2366       UInt16 Characteristics;
2367    }
2368    COFF_header;
2369
2370 #define sizeof_COFF_header 20
2371
2372
2373 typedef
2374    struct {
2375       UChar  Name[8];
2376       UInt32 VirtualSize;
2377       UInt32 VirtualAddress;
2378       UInt32 SizeOfRawData;
2379       UInt32 PointerToRawData;
2380       UInt32 PointerToRelocations;
2381       UInt32 PointerToLinenumbers;
2382       UInt16 NumberOfRelocations;
2383       UInt16 NumberOfLineNumbers;
2384       UInt32 Characteristics;
2385    }
2386    COFF_section;
2387
2388 #define sizeof_COFF_section 40
2389
2390
2391 typedef
2392    struct {
2393       UChar  Name[8];
2394       UInt32 Value;
2395       UInt16 SectionNumber;
2396       UInt16 Type;
2397       UChar  StorageClass;
2398       UChar  NumberOfAuxSymbols;
2399    }
2400    COFF_symbol;
2401
2402 #define sizeof_COFF_symbol 18
2403
2404
2405 typedef
2406    struct {
2407       UInt32 VirtualAddress;
2408       UInt32 SymbolTableIndex;
2409       UInt16 Type;
2410    }
2411    COFF_reloc;
2412
2413 #define sizeof_COFF_reloc 10
2414
2415
2416 /* From PE spec doc, section 3.3.2 */
2417 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
2418    windows.h -- for the same purpose, but I want to know what I'm
2419    getting, here. */
2420 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
2421 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
2422 #define MYIMAGE_FILE_DLL                 0x2000
2423 #define MYIMAGE_FILE_SYSTEM              0x1000
2424 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
2425 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
2426 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
2427
2428 /* From PE spec doc, section 5.4.2 and 5.4.4 */
2429 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
2430 #define MYIMAGE_SYM_CLASS_STATIC         3
2431 #define MYIMAGE_SYM_UNDEFINED            0
2432
2433 /* From PE spec doc, section 4.1 */
2434 #define MYIMAGE_SCN_CNT_CODE             0x00000020
2435 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
2436 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
2437
2438 /* From PE spec doc, section 5.2.1 */
2439 #define MYIMAGE_REL_I386_DIR32           0x0006
2440 #define MYIMAGE_REL_I386_REL32           0x0014
2441
2442
2443 /* We use myindex to calculate array addresses, rather than
2444    simply doing the normal subscript thing.  That's because
2445    some of the above structs have sizes which are not
2446    a whole number of words.  GCC rounds their sizes up to a
2447    whole number of words, which means that the address calcs
2448    arising from using normal C indexing or pointer arithmetic
2449    are just plain wrong.  Sigh.
2450 */
2451 static UChar *
2452 myindex ( int scale, void* base, int index )
2453 {
2454    return
2455       ((UChar*)base) + scale * index;
2456 }
2457
2458
2459 static void
2460 printName ( UChar* name, UChar* strtab )
2461 {
2462    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2463       UInt32 strtab_offset = * (UInt32*)(name+4);
2464       debugBelch("%s", strtab + strtab_offset );
2465    } else {
2466       int i;
2467       for (i = 0; i < 8; i++) {
2468          if (name[i] == 0) break;
2469          debugBelch("%c", name[i] );
2470       }
2471    }
2472 }
2473
2474
2475 static void
2476 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
2477 {
2478    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2479       UInt32 strtab_offset = * (UInt32*)(name+4);
2480       strncpy ( (char*)dst, (char*)strtab+strtab_offset, dstSize );
2481       dst[dstSize-1] = 0;
2482    } else {
2483       int i = 0;
2484       while (1) {
2485          if (i >= 8) break;
2486          if (name[i] == 0) break;
2487          dst[i] = name[i];
2488          i++;
2489       }
2490       dst[i] = 0;
2491    }
2492 }
2493
2494
2495 static UChar *
2496 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
2497 {
2498    UChar* newstr;
2499    /* If the string is longer than 8 bytes, look in the
2500       string table for it -- this will be correctly zero terminated.
2501    */
2502    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2503       UInt32 strtab_offset = * (UInt32*)(name+4);
2504       return ((UChar*)strtab) + strtab_offset;
2505    }
2506    /* Otherwise, if shorter than 8 bytes, return the original,
2507       which by defn is correctly terminated.
2508    */
2509    if (name[7]==0) return name;
2510    /* The annoying case: 8 bytes.  Copy into a temporary
2511       (XXX which is never freed ...)
2512    */
2513    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
2514    ASSERT(newstr);
2515    strncpy((char*)newstr,(char*)name,8);
2516    newstr[8] = 0;
2517    return newstr;
2518 }
2519
2520 /* Getting the name of a section is mildly tricky, so we make a
2521    function for it.  Sadly, in one case we have to copy the string
2522    (when it is exactly 8 bytes long there's no trailing '\0'), so for
2523    consistency we *always* copy the string; the caller must free it
2524 */
2525 static char *
2526 cstring_from_section_name (UChar* name, UChar* strtab)
2527 {
2528     char *newstr;
2529
2530     if (name[0]=='/') {
2531         int strtab_offset = strtol((char*)name+1,NULL,10);
2532         int len = strlen(((char*)strtab) + strtab_offset);
2533
2534         newstr = stgMallocBytes(len, "cstring_from_section_symbol_name");
2535         strcpy((char*)newstr, (char*)((UChar*)strtab) + strtab_offset);
2536         return newstr;
2537     }
2538     else
2539     {
2540         newstr = stgMallocBytes(9, "cstring_from_section_symbol_name");
2541         ASSERT(newstr);
2542         strncpy((char*)newstr,(char*)name,8);
2543         newstr[8] = 0;
2544         return newstr;
2545     }
2546 }
2547
2548 /* Just compares the short names (first 8 chars) */
2549 static COFF_section *
2550 findPEi386SectionCalled ( ObjectCode* oc,  UChar* name )
2551 {
2552    int i;
2553    COFF_header* hdr
2554       = (COFF_header*)(oc->image);
2555    COFF_section* sectab
2556       = (COFF_section*) (
2557            ((UChar*)(oc->image))
2558            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2559         );
2560    for (i = 0; i < hdr->NumberOfSections; i++) {
2561       UChar* n1;
2562       UChar* n2;
2563       COFF_section* section_i
2564          = (COFF_section*)
2565            myindex ( sizeof_COFF_section, sectab, i );
2566       n1 = (UChar*) &(section_i->Name);
2567       n2 = name;
2568       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
2569           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
2570           n1[6]==n2[6] && n1[7]==n2[7])
2571          return section_i;
2572    }
2573
2574    return NULL;
2575 }
2576
2577
2578 static void
2579 zapTrailingAtSign ( UChar* sym )
2580 {
2581 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
2582    int i, j;
2583    if (sym[0] == 0) return;
2584    i = 0;
2585    while (sym[i] != 0) i++;
2586    i--;
2587    j = i;
2588    while (j > 0 && my_isdigit(sym[j])) j--;
2589    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
2590 #  undef my_isdigit
2591 }
2592
2593 static void *
2594 lookupSymbolInDLLs ( UChar *lbl )
2595 {
2596     OpenedDLL* o_dll;
2597     void *sym;
2598
2599     for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
2600         /* debugBelch("look in %s for %s\n", o_dll->name, lbl); */
2601
2602         if (lbl[0] == '_') {
2603             /* HACK: if the name has an initial underscore, try stripping
2604                it off & look that up first. I've yet to verify whether there's
2605                a Rule that governs whether an initial '_' *should always* be
2606                stripped off when mapping from import lib name to the DLL name.
2607             */
2608             sym = GetProcAddress(o_dll->instance, (char*)(lbl+1));
2609             if (sym != NULL) {
2610                 /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
2611                 return sym;
2612             }
2613         }
2614         sym = GetProcAddress(o_dll->instance, (char*)lbl);
2615         if (sym != NULL) {
2616             /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
2617             return sym;
2618            }
2619     }
2620     return NULL;
2621 }
2622
2623
2624 static int
2625 ocVerifyImage_PEi386 ( ObjectCode* oc )
2626 {
2627    int i;
2628    UInt32 j, noRelocs;
2629    COFF_header*  hdr;
2630    COFF_section* sectab;
2631    COFF_symbol*  symtab;
2632    UChar*        strtab;
2633    /* debugBelch("\nLOADING %s\n", oc->fileName); */
2634    hdr = (COFF_header*)(oc->image);
2635    sectab = (COFF_section*) (
2636                ((UChar*)(oc->image))
2637                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2638             );
2639    symtab = (COFF_symbol*) (
2640                ((UChar*)(oc->image))
2641                + hdr->PointerToSymbolTable
2642             );
2643    strtab = ((UChar*)symtab)
2644             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2645
2646    if (hdr->Machine != 0x14c) {
2647       errorBelch("%s: Not x86 PEi386", oc->fileName);
2648       return 0;
2649    }
2650    if (hdr->SizeOfOptionalHeader != 0) {
2651       errorBelch("%s: PEi386 with nonempty optional header", oc->fileName);
2652       return 0;
2653    }
2654    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
2655         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
2656         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
2657         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
2658       errorBelch("%s: Not a PEi386 object file", oc->fileName);
2659       return 0;
2660    }
2661    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
2662         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
2663       errorBelch("%s: Invalid PEi386 word size or endiannness: %d",
2664                  oc->fileName,
2665                  (int)(hdr->Characteristics));
2666       return 0;
2667    }
2668    /* If the string table size is way crazy, this might indicate that
2669       there are more than 64k relocations, despite claims to the
2670       contrary.  Hence this test. */
2671    /* debugBelch("strtab size %d\n", * (UInt32*)strtab); */
2672 #if 0
2673    if ( (*(UInt32*)strtab) > 600000 ) {
2674       /* Note that 600k has no special significance other than being
2675          big enough to handle the almost-2MB-sized lumps that
2676          constitute HSwin32*.o. */
2677       debugBelch("PEi386 object has suspiciously large string table; > 64k relocs?");
2678       return 0;
2679    }
2680 #endif
2681
2682    /* No further verification after this point; only debug printing. */
2683    i = 0;
2684    IF_DEBUG(linker, i=1);
2685    if (i == 0) return 1;
2686
2687    debugBelch( "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
2688    debugBelch( "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
2689    debugBelch( "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
2690
2691    debugBelch("\n" );
2692    debugBelch( "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
2693    debugBelch( "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
2694    debugBelch( "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
2695    debugBelch( "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
2696    debugBelch( "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
2697    debugBelch( "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
2698    debugBelch( "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
2699
2700    /* Print the section table. */
2701    debugBelch("\n" );
2702    for (i = 0; i < hdr->NumberOfSections; i++) {
2703       COFF_reloc* reltab;
2704       COFF_section* sectab_i
2705          = (COFF_section*)
2706            myindex ( sizeof_COFF_section, sectab, i );
2707       debugBelch(
2708                 "\n"
2709                 "section %d\n"
2710                 "     name `",
2711                 i
2712               );
2713       printName ( sectab_i->Name, strtab );
2714       debugBelch(
2715                 "'\n"
2716                 "    vsize %d\n"
2717                 "    vaddr %d\n"
2718                 "  data sz %d\n"
2719                 " data off %d\n"
2720                 "  num rel %d\n"
2721                 "  off rel %d\n"
2722                 "  ptr raw 0x%x\n",
2723                 sectab_i->VirtualSize,
2724                 sectab_i->VirtualAddress,
2725                 sectab_i->SizeOfRawData,
2726                 sectab_i->PointerToRawData,
2727                 sectab_i->NumberOfRelocations,
2728                 sectab_i->PointerToRelocations,
2729                 sectab_i->PointerToRawData
2730               );
2731       reltab = (COFF_reloc*) (
2732                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2733                );
2734
2735       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2736         /* If the relocation field (a short) has overflowed, the
2737          * real count can be found in the first reloc entry.
2738          *
2739          * See Section 4.1 (last para) of the PE spec (rev6.0).
2740          */
2741         COFF_reloc* rel = (COFF_reloc*)
2742                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2743         noRelocs = rel->VirtualAddress;
2744         j = 1;
2745       } else {
2746         noRelocs = sectab_i->NumberOfRelocations;
2747         j = 0;
2748       }
2749
2750       for (; j < noRelocs; j++) {
2751          COFF_symbol* sym;
2752          COFF_reloc* rel = (COFF_reloc*)
2753                            myindex ( sizeof_COFF_reloc, reltab, j );
2754          debugBelch(
2755                    "        type 0x%-4x   vaddr 0x%-8x   name `",
2756                    (UInt32)rel->Type,
2757                    rel->VirtualAddress );
2758          sym = (COFF_symbol*)
2759                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
2760          /* Hmm..mysterious looking offset - what's it for? SOF */
2761          printName ( sym->Name, strtab -10 );
2762          debugBelch("'\n" );
2763       }
2764
2765       debugBelch("\n" );
2766    }
2767    debugBelch("\n" );
2768    debugBelch("string table has size 0x%x\n", * (UInt32*)strtab );
2769    debugBelch("---START of string table---\n");
2770    for (i = 4; i < *(Int32*)strtab; i++) {
2771       if (strtab[i] == 0)
2772          debugBelch("\n"); else
2773          debugBelch("%c", strtab[i] );
2774    }
2775    debugBelch("--- END  of string table---\n");
2776
2777    debugBelch("\n" );
2778    i = 0;
2779    while (1) {
2780       COFF_symbol* symtab_i;
2781       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2782       symtab_i = (COFF_symbol*)
2783                  myindex ( sizeof_COFF_symbol, symtab, i );
2784       debugBelch(
2785                 "symbol %d\n"
2786                 "     name `",
2787                 i
2788               );
2789       printName ( symtab_i->Name, strtab );
2790       debugBelch(
2791                 "'\n"
2792                 "    value 0x%x\n"
2793                 "   1+sec# %d\n"
2794                 "     type 0x%x\n"
2795                 "   sclass 0x%x\n"
2796                 "     nAux %d\n",
2797                 symtab_i->Value,
2798                 (Int32)(symtab_i->SectionNumber),
2799                 (UInt32)symtab_i->Type,
2800                 (UInt32)symtab_i->StorageClass,
2801                 (UInt32)symtab_i->NumberOfAuxSymbols
2802               );
2803       i += symtab_i->NumberOfAuxSymbols;
2804       i++;
2805    }
2806
2807    debugBelch("\n" );
2808    return 1;
2809 }
2810
2811
2812 static int
2813 ocGetNames_PEi386 ( ObjectCode* oc )
2814 {
2815    COFF_header*  hdr;
2816    COFF_section* sectab;
2817    COFF_symbol*  symtab;
2818    UChar*        strtab;
2819
2820    UChar* sname;
2821    void*  addr;
2822    int    i;
2823
2824    hdr = (COFF_header*)(oc->image);
2825    sectab = (COFF_section*) (
2826                ((UChar*)(oc->image))
2827                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2828             );
2829    symtab = (COFF_symbol*) (
2830                ((UChar*)(oc->image))
2831                + hdr->PointerToSymbolTable
2832             );
2833    strtab = ((UChar*)(oc->image))
2834             + hdr->PointerToSymbolTable
2835             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2836
2837    /* Allocate space for any (local, anonymous) .bss sections. */
2838
2839    for (i = 0; i < hdr->NumberOfSections; i++) {
2840       UInt32 bss_sz;
2841       UChar* zspace;
2842       COFF_section* sectab_i
2843          = (COFF_section*)
2844            myindex ( sizeof_COFF_section, sectab, i );
2845
2846       char *secname = cstring_from_section_name(sectab_i->Name, strtab);
2847
2848       if (0 != strcmp(secname, ".bss")) {
2849           stgFree(secname);
2850           continue;
2851       }
2852
2853       stgFree(secname);
2854
2855       /* sof 10/05: the PE spec text isn't too clear regarding what
2856        * the SizeOfRawData field is supposed to hold for object
2857        * file sections containing just uninitialized data -- for executables,
2858        * it is supposed to be zero; unclear what it's supposed to be
2859        * for object files. However, VirtualSize is guaranteed to be
2860        * zero for object files, which definitely suggests that SizeOfRawData
2861        * will be non-zero (where else would the size of this .bss section be
2862        * stored?) Looking at the COFF_section info for incoming object files,
2863        * this certainly appears to be the case.
2864        *
2865        * => I suspect we've been incorrectly handling .bss sections in (relocatable)
2866        * object files up until now. This turned out to bite us with ghc-6.4.1's use
2867        * of gcc-3.4.x, which has started to emit initially-zeroed-out local 'static'
2868        * variable decls into to the .bss section. (The specific function in Q which
2869        * triggered this is libraries/base/cbits/dirUtils.c:__hscore_getFolderPath())
2870        */
2871       if (sectab_i->VirtualSize == 0 && sectab_i->SizeOfRawData == 0) continue;
2872       /* This is a non-empty .bss section.  Allocate zeroed space for
2873          it, and set its PointerToRawData field such that oc->image +
2874          PointerToRawData == addr_of_zeroed_space.  */
2875       bss_sz = sectab_i->VirtualSize;
2876       if ( bss_sz < sectab_i->SizeOfRawData) { bss_sz = sectab_i->SizeOfRawData; }
2877       zspace = stgCallocBytes(1, bss_sz, "ocGetNames_PEi386(anonymous bss)");
2878       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
2879       addProddableBlock(oc, zspace, bss_sz);
2880       /* debugBelch("BSS anon section at 0x%x\n", zspace); */
2881    }
2882
2883    /* Copy section information into the ObjectCode. */
2884
2885    for (i = 0; i < hdr->NumberOfSections; i++) {
2886       UChar* start;
2887       UChar* end;
2888       UInt32 sz;
2889
2890       SectionKind kind
2891          = SECTIONKIND_OTHER;
2892       COFF_section* sectab_i
2893          = (COFF_section*)
2894            myindex ( sizeof_COFF_section, sectab, i );
2895
2896       char *secname = cstring_from_section_name(sectab_i->Name, strtab);
2897
2898       IF_DEBUG(linker, debugBelch("section name = %s\n", secname ));
2899
2900 #     if 0
2901       /* I'm sure this is the Right Way to do it.  However, the
2902          alternative of testing the sectab_i->Name field seems to
2903          work ok with Cygwin.
2904       */
2905       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
2906           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
2907          kind = SECTIONKIND_CODE_OR_RODATA;
2908 #     endif
2909
2910       if (0==strcmp(".text",(char*)secname) ||
2911           0==strcmp(".rdata",(char*)secname)||
2912           0==strcmp(".rodata",(char*)secname))
2913          kind = SECTIONKIND_CODE_OR_RODATA;
2914       if (0==strcmp(".data",(char*)secname) ||
2915           0==strcmp(".bss",(char*)secname))
2916          kind = SECTIONKIND_RWDATA;
2917
2918       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
2919       sz = sectab_i->SizeOfRawData;
2920       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
2921
2922       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
2923       end   = start + sz - 1;
2924
2925       if (kind == SECTIONKIND_OTHER
2926           /* Ignore sections called which contain stabs debugging
2927              information. */
2928           && 0 != strcmp(".stab", (char*)secname)
2929           && 0 != strcmp(".stabstr", (char*)secname)
2930           /* ignore constructor section for now */
2931           && 0 != strcmp(".ctors", (char*)secname)
2932           /* ignore section generated from .ident */
2933           && 0!= strncmp(".debug", (char*)secname, 6)
2934           /* ignore unknown section that appeared in gcc 3.4.5(?) */
2935           && 0!= strcmp(".reloc", (char*)secname)
2936           && 0 != strcmp(".rdata$zzz", (char*)secname)
2937          ) {
2938          errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", secname, oc->fileName);
2939          stgFree(secname);
2940          return 0;
2941       }
2942
2943       if (kind != SECTIONKIND_OTHER && end >= start) {
2944          addSection(oc, kind, start, end);
2945          addProddableBlock(oc, start, end - start + 1);
2946       }
2947
2948       stgFree(secname);
2949    }
2950
2951    /* Copy exported symbols into the ObjectCode. */
2952
2953    oc->n_symbols = hdr->NumberOfSymbols;
2954    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
2955                                   "ocGetNames_PEi386(oc->symbols)");
2956    /* Call me paranoid; I don't care. */
2957    for (i = 0; i < oc->n_symbols; i++)
2958       oc->symbols[i] = NULL;
2959
2960    i = 0;
2961    while (1) {
2962       COFF_symbol* symtab_i;
2963       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2964       symtab_i = (COFF_symbol*)
2965                  myindex ( sizeof_COFF_symbol, symtab, i );
2966
2967       addr  = NULL;
2968
2969       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
2970           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
2971          /* This symbol is global and defined, viz, exported */
2972          /* for MYIMAGE_SYMCLASS_EXTERNAL
2973                 && !MYIMAGE_SYM_UNDEFINED,
2974             the address of the symbol is:
2975                 address of relevant section + offset in section
2976          */
2977          COFF_section* sectabent
2978             = (COFF_section*) myindex ( sizeof_COFF_section,
2979                                         sectab,
2980                                         symtab_i->SectionNumber-1 );
2981          addr = ((UChar*)(oc->image))
2982                 + (sectabent->PointerToRawData
2983                    + symtab_i->Value);
2984       }
2985       else
2986       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
2987           && symtab_i->Value > 0) {
2988          /* This symbol isn't in any section at all, ie, global bss.
2989             Allocate zeroed space for it. */
2990          addr = stgCallocBytes(1, symtab_i->Value,
2991                                "ocGetNames_PEi386(non-anonymous bss)");
2992          addSection(oc, SECTIONKIND_RWDATA, addr,
2993                         ((UChar*)addr) + symtab_i->Value - 1);
2994          addProddableBlock(oc, addr, symtab_i->Value);
2995          /* debugBelch("BSS      section at 0x%x\n", addr); */
2996       }
2997
2998       if (addr != NULL ) {
2999          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
3000          /* debugBelch("addSymbol %p `%s \n", addr,sname);  */
3001          IF_DEBUG(linker, debugBelch("addSymbol %p `%s'\n", addr,sname);)
3002          ASSERT(i >= 0 && i < oc->n_symbols);
3003          /* cstring_from_COFF_symbol_name always succeeds. */
3004          oc->symbols[i] = (char*)sname;
3005          ghciInsertStrHashTable(oc->fileName, symhash, (char*)sname, addr);
3006       } else {
3007 #        if 0
3008          debugBelch(
3009                    "IGNORING symbol %d\n"
3010                    "     name `",
3011                    i
3012                  );
3013          printName ( symtab_i->Name, strtab );
3014          debugBelch(
3015                    "'\n"
3016                    "    value 0x%x\n"
3017                    "   1+sec# %d\n"
3018                    "     type 0x%x\n"
3019                    "   sclass 0x%x\n"
3020                    "     nAux %d\n",
3021                    symtab_i->Value,
3022                    (Int32)(symtab_i->SectionNumber),
3023                    (UInt32)symtab_i->Type,
3024                    (UInt32)symtab_i->StorageClass,
3025                    (UInt32)symtab_i->NumberOfAuxSymbols
3026                  );
3027 #        endif
3028       }
3029
3030       i += symtab_i->NumberOfAuxSymbols;
3031       i++;
3032    }
3033
3034    return 1;
3035 }
3036
3037
3038 static int
3039 ocResolve_PEi386 ( ObjectCode* oc )
3040 {
3041    COFF_header*  hdr;
3042    COFF_section* sectab;
3043    COFF_symbol*  symtab;
3044    UChar*        strtab;
3045
3046    UInt32        A;
3047    UInt32        S;
3048    UInt32*       pP;
3049
3050    int i;
3051    UInt32 j, noRelocs;
3052
3053    /* ToDo: should be variable-sized?  But is at least safe in the
3054       sense of buffer-overrun-proof. */
3055    UChar symbol[1000];
3056    /* debugBelch("resolving for %s\n", oc->fileName); */
3057
3058    hdr = (COFF_header*)(oc->image);
3059    sectab = (COFF_section*) (
3060                ((UChar*)(oc->image))
3061                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
3062             );
3063    symtab = (COFF_symbol*) (
3064                ((UChar*)(oc->image))
3065                + hdr->PointerToSymbolTable
3066             );
3067    strtab = ((UChar*)(oc->image))
3068             + hdr->PointerToSymbolTable
3069             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
3070
3071    for (i = 0; i < hdr->NumberOfSections; i++) {
3072       COFF_section* sectab_i
3073          = (COFF_section*)
3074            myindex ( sizeof_COFF_section, sectab, i );
3075       COFF_reloc* reltab
3076          = (COFF_reloc*) (
3077               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
3078            );
3079
3080       char *secname = cstring_from_section_name(sectab_i->Name, strtab);
3081
3082       /* Ignore sections called which contain stabs debugging
3083          information. */
3084       if (0 == strcmp(".stab", (char*)secname)
3085           || 0 == strcmp(".stabstr", (char*)secname)
3086           || 0 == strcmp(".ctors", (char*)secname)
3087           || 0 == strncmp(".debug", (char*)secname, 6)
3088           || 0 == strcmp(".rdata$zzz", (char*)secname)) {
3089           stgFree(secname);
3090           continue;
3091       }
3092
3093       stgFree(secname);
3094
3095       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
3096         /* If the relocation field (a short) has overflowed, the
3097          * real count can be found in the first reloc entry.
3098          *
3099          * See Section 4.1 (last para) of the PE spec (rev6.0).
3100          *
3101          * Nov2003 update: the GNU linker still doesn't correctly
3102          * handle the generation of relocatable object files with
3103          * overflown relocations. Hence the output to warn of potential
3104          * troubles.
3105          */
3106         COFF_reloc* rel = (COFF_reloc*)
3107                            myindex ( sizeof_COFF_reloc, reltab, 0 );
3108         noRelocs = rel->VirtualAddress;
3109
3110         /* 10/05: we now assume (and check for) a GNU ld that is capable
3111          * of handling object files with (>2^16) of relocs.
3112          */
3113 #if 0
3114         debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
3115                    noRelocs);
3116 #endif
3117         j = 1;
3118       } else {
3119         noRelocs = sectab_i->NumberOfRelocations;
3120         j = 0;
3121       }
3122
3123
3124       for (; j < noRelocs; j++) {
3125          COFF_symbol* sym;
3126          COFF_reloc* reltab_j
3127             = (COFF_reloc*)
3128               myindex ( sizeof_COFF_reloc, reltab, j );
3129
3130          /* the location to patch */
3131          pP = (UInt32*)(
3132                  ((UChar*)(oc->image))
3133                  + (sectab_i->PointerToRawData
3134                     + reltab_j->VirtualAddress
3135                     - sectab_i->VirtualAddress )
3136               );
3137          /* the existing contents of pP */
3138          A = *pP;
3139          /* the symbol to connect to */
3140          sym = (COFF_symbol*)
3141                myindex ( sizeof_COFF_symbol,
3142                          symtab, reltab_j->SymbolTableIndex );
3143          IF_DEBUG(linker,
3144                   debugBelch(
3145                             "reloc sec %2d num %3d:  type 0x%-4x   "
3146                             "vaddr 0x%-8x   name `",
3147                             i, j,
3148                             (UInt32)reltab_j->Type,
3149                             reltab_j->VirtualAddress );
3150                             printName ( sym->Name, strtab );
3151                             debugBelch("'\n" ));
3152
3153          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
3154             COFF_section* section_sym
3155                = findPEi386SectionCalled ( oc, sym->Name );
3156             if (!section_sym) {
3157                errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
3158                return 0;
3159             }
3160             S = ((UInt32)(oc->image))
3161                 + (section_sym->PointerToRawData
3162                    + sym->Value);
3163          } else {
3164             copyName ( sym->Name, strtab, symbol, 1000-1 );
3165             S = (UInt32) lookupSymbol( (char*)symbol );
3166             if ((void*)S != NULL) goto foundit;
3167             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3168             return 0;
3169            foundit:;
3170          }
3171          checkProddableBlock(oc, pP);
3172          switch (reltab_j->Type) {
3173             case MYIMAGE_REL_I386_DIR32:
3174                *pP = A + S;
3175                break;
3176             case MYIMAGE_REL_I386_REL32:
3177                /* Tricky.  We have to insert a displacement at
3178                   pP which, when added to the PC for the _next_
3179                   insn, gives the address of the target (S).
3180                   Problem is to know the address of the next insn
3181                   when we only know pP.  We assume that this
3182                   literal field is always the last in the insn,
3183                   so that the address of the next insn is pP+4
3184                   -- hence the constant 4.
3185                   Also I don't know if A should be added, but so
3186                   far it has always been zero.
3187
3188                   SOF 05/2005: 'A' (old contents of *pP) have been observed
3189                   to contain values other than zero (the 'wx' object file
3190                   that came with wxhaskell-0.9.4; dunno how it was compiled..).
3191                   So, add displacement to old value instead of asserting
3192                   A to be zero. Fixes wxhaskell-related crashes, and no other
3193                   ill effects have been observed.
3194
3195                   Update: the reason why we're seeing these more elaborate
3196                   relocations is due to a switch in how the NCG compiles SRTs
3197                   and offsets to them from info tables. SRTs live in .(ro)data,
3198                   while info tables live in .text, causing GAS to emit REL32/DISP32
3199                   relocations with non-zero values. Adding the displacement is
3200                   the right thing to do.
3201                */
3202                *pP = S - ((UInt32)pP) - 4 + A;
3203                break;
3204             default:
3205                debugBelch("%s: unhandled PEi386 relocation type %d",
3206                      oc->fileName, reltab_j->Type);
3207                return 0;
3208          }
3209
3210       }
3211    }
3212
3213    IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
3214    return 1;
3215 }
3216
3217 #endif /* defined(OBJFORMAT_PEi386) */
3218
3219
3220 /* --------------------------------------------------------------------------
3221  * ELF specifics
3222  * ------------------------------------------------------------------------*/
3223
3224 #if defined(OBJFORMAT_ELF)
3225
3226 #define FALSE 0
3227 #define TRUE  1
3228
3229 #if defined(sparc_HOST_ARCH)
3230 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
3231 #elif defined(i386_HOST_ARCH)
3232 #  define ELF_TARGET_386    /* Used inside <elf.h> */
3233 #elif defined(x86_64_HOST_ARCH)
3234 #  define ELF_TARGET_X64_64
3235 #  define ELF_64BIT
3236 #endif
3237
3238 #if !defined(openbsd_HOST_OS)
3239 #  include <elf.h>
3240 #else
3241 /* openbsd elf has things in different places, with diff names */
3242 #  include <elf_abi.h>
3243 #  include <machine/reloc.h>
3244 #  define R_386_32    RELOC_32
3245 #  define R_386_PC32  RELOC_PC32
3246 #endif
3247
3248 /* If elf.h doesn't define it */
3249 #  ifndef R_X86_64_PC64
3250 #    define R_X86_64_PC64 24
3251 #  endif
3252
3253 /*
3254  * Define a set of types which can be used for both ELF32 and ELF64
3255  */
3256
3257 #ifdef ELF_64BIT
3258 #define ELFCLASS    ELFCLASS64
3259 #define Elf_Addr    Elf64_Addr
3260 #define Elf_Word    Elf64_Word
3261 #define Elf_Sword   Elf64_Sword
3262 #define Elf_Ehdr    Elf64_Ehdr
3263 #define Elf_Phdr    Elf64_Phdr
3264 #define Elf_Shdr    Elf64_Shdr
3265 #define Elf_Sym     Elf64_Sym
3266 #define Elf_Rel     Elf64_Rel
3267 #define Elf_Rela    Elf64_Rela
3268 #ifndef ELF_ST_TYPE
3269 #define ELF_ST_TYPE ELF64_ST_TYPE
3270 #endif
3271 #ifndef ELF_ST_BIND
3272 #define ELF_ST_BIND ELF64_ST_BIND
3273 #endif
3274 #ifndef ELF_R_TYPE
3275 #define ELF_R_TYPE  ELF64_R_TYPE
3276 #endif
3277 #ifndef ELF_R_SYM
3278 #define ELF_R_SYM   ELF64_R_SYM
3279 #endif
3280 #else
3281 #define ELFCLASS    ELFCLASS32
3282 #define Elf_Addr    Elf32_Addr
3283 #define Elf_Word    Elf32_Word
3284 #define Elf_Sword   Elf32_Sword
3285 #define Elf_Ehdr    Elf32_Ehdr
3286 #define Elf_Phdr    Elf32_Phdr
3287 #define Elf_Shdr    Elf32_Shdr
3288 #define Elf_Sym     Elf32_Sym
3289 #define Elf_Rel     Elf32_Rel
3290 #define Elf_Rela    Elf32_Rela
3291 #ifndef ELF_ST_TYPE
3292 #define ELF_ST_TYPE ELF32_ST_TYPE
3293 #endif
3294 #ifndef ELF_ST_BIND
3295 #define ELF_ST_BIND ELF32_ST_BIND
3296 #endif
3297 #ifndef ELF_R_TYPE
3298 #define ELF_R_TYPE  ELF32_R_TYPE
3299 #endif
3300 #ifndef ELF_R_SYM
3301 #define ELF_R_SYM   ELF32_R_SYM
3302 #endif
3303 #endif
3304
3305
3306 /*
3307  * Functions to allocate entries in dynamic sections.  Currently we simply
3308  * preallocate a large number, and we don't check if a entry for the given
3309  * target already exists (a linear search is too slow).  Ideally these
3310  * entries would be associated with symbols.
3311  */
3312
3313 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
3314 #define GOT_SIZE            0x20000
3315 #define FUNCTION_TABLE_SIZE 0x10000
3316 #define PLT_SIZE            0x08000
3317
3318 #ifdef ELF_NEED_GOT
3319 static Elf_Addr got[GOT_SIZE];
3320 static unsigned int gotIndex;
3321 static Elf_Addr gp_val = (Elf_Addr)got;
3322
3323 static Elf_Addr
3324 allocateGOTEntry(Elf_Addr target)
3325 {
3326    Elf_Addr *entry;
3327
3328    if (gotIndex >= GOT_SIZE)
3329       barf("Global offset table overflow");
3330
3331    entry = &got[gotIndex++];
3332    *entry = target;
3333    return (Elf_Addr)entry;
3334 }
3335 #endif
3336
3337 #ifdef ELF_FUNCTION_DESC
3338 typedef struct {
3339    Elf_Addr ip;
3340    Elf_Addr gp;
3341 } FunctionDesc;
3342
3343 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
3344 static unsigned int functionTableIndex;
3345
3346 static Elf_Addr
3347 allocateFunctionDesc(Elf_Addr target)
3348 {
3349    FunctionDesc *entry;
3350
3351    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
3352       barf("Function table overflow");
3353
3354    entry = &functionTable[functionTableIndex++];
3355    entry->ip = target;
3356    entry->gp = (Elf_Addr)gp_val;
3357    return (Elf_Addr)entry;
3358 }
3359
3360 static Elf_Addr
3361 copyFunctionDesc(Elf_Addr target)
3362 {
3363    FunctionDesc *olddesc = (FunctionDesc *)target;
3364    FunctionDesc *newdesc;
3365
3366    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
3367    newdesc->gp = olddesc->gp;
3368    return (Elf_Addr)newdesc;
3369 }
3370 #endif
3371
3372 #ifdef ELF_NEED_PLT
3373
3374 typedef struct {
3375    unsigned char code[sizeof(plt_code)];
3376 } PLTEntry;
3377
3378 static Elf_Addr
3379 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
3380 {
3381    PLTEntry *plt = (PLTEntry *)oc->plt;
3382    PLTEntry *entry;
3383
3384    if (oc->pltIndex >= PLT_SIZE)
3385       barf("Procedure table overflow");
3386
3387    entry = &plt[oc->pltIndex++];
3388    memcpy(entry->code, plt_code, sizeof(entry->code));
3389    PLT_RELOC(entry->code, target);
3390    return (Elf_Addr)entry;
3391 }
3392
3393 static unsigned int
3394 PLTSize(void)
3395 {
3396    return (PLT_SIZE * sizeof(PLTEntry));
3397 }
3398 #endif
3399
3400
3401 /*
3402  * Generic ELF functions
3403  */
3404
3405 static char *
3406 findElfSection ( void* objImage, Elf_Word sh_type )
3407 {
3408    char* ehdrC = (char*)objImage;
3409    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
3410    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
3411    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
3412    char* ptr = NULL;
3413    int i;
3414
3415    for (i = 0; i < ehdr->e_shnum; i++) {
3416       if (shdr[i].sh_type == sh_type
3417           /* Ignore the section header's string table. */
3418           && i != ehdr->e_shstrndx
3419           /* Ignore string tables named .stabstr, as they contain
3420              debugging info. */
3421           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
3422          ) {
3423          ptr = ehdrC + shdr[i].sh_offset;
3424          break;
3425       }
3426    }
3427    return ptr;
3428 }
3429
3430 static int
3431 ocVerifyImage_ELF ( ObjectCode* oc )
3432 {
3433    Elf_Shdr* shdr;
3434    Elf_Sym*  stab;
3435    int i, j, nent, nstrtab, nsymtabs;
3436    char* sh_strtab;
3437    char* strtab;
3438
3439    char*     ehdrC = (char*)(oc->image);
3440    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
3441
3442    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
3443        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
3444        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
3445        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
3446       errorBelch("%s: not an ELF object", oc->fileName);
3447       return 0;
3448    }
3449
3450    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
3451       errorBelch("%s: unsupported ELF format", oc->fileName);
3452       return 0;
3453    }
3454
3455    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
3456        IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
3457    } else
3458    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
3459        IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
3460    } else {
3461        errorBelch("%s: unknown endiannness", oc->fileName);
3462        return 0;
3463    }
3464
3465    if (ehdr->e_type != ET_REL) {
3466       errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
3467       return 0;
3468    }
3469    IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
3470
3471    IF_DEBUG(linker,debugBelch( "Architecture is " ));
3472    switch (ehdr->e_machine) {
3473       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
3474 #ifdef EM_SPARC32PLUS
3475       case EM_SPARC32PLUS:
3476 #endif
3477       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
3478 #ifdef EM_IA_64
3479       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
3480 #endif
3481       case EM_PPC:   IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
3482 #ifdef EM_X86_64
3483       case EM_X86_64: IF_DEBUG(linker,debugBelch( "x86_64" )); break;
3484 #elif defined(EM_AMD64)
3485       case EM_AMD64: IF_DEBUG(linker,debugBelch( "amd64" )); break;
3486 #endif
3487       default:       IF_DEBUG(linker,debugBelch( "unknown" ));
3488                      errorBelch("%s: unknown architecture (e_machine == %d)"
3489                                 , oc->fileName, ehdr->e_machine);
3490                      return 0;
3491    }
3492
3493    IF_DEBUG(linker,debugBelch(
3494              "\nSection header table: start %ld, n_entries %d, ent_size %d\n",
3495              (long)ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
3496
3497    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
3498
3499    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3500
3501    if (ehdr->e_shstrndx == SHN_UNDEF) {
3502       errorBelch("%s: no section header string table", oc->fileName);
3503       return 0;
3504    } else {
3505       IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
3506                           ehdr->e_shstrndx));
3507       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
3508    }
3509
3510    for (i = 0; i < ehdr->e_shnum; i++) {
3511       IF_DEBUG(linker,debugBelch("%2d:  ", i ));
3512       IF_DEBUG(linker,debugBelch("type=%2d  ", (int)shdr[i].sh_type ));
3513       IF_DEBUG(linker,debugBelch("size=%4d  ", (int)shdr[i].sh_size ));
3514       IF_DEBUG(linker,debugBelch("offs=%4d  ", (int)shdr[i].sh_offset ));
3515       IF_DEBUG(linker,debugBelch("  (%p .. %p)  ",
3516                ehdrC + shdr[i].sh_offset,
3517                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
3518
3519       if (shdr[i].sh_type == SHT_REL) {
3520           IF_DEBUG(linker,debugBelch("Rel  " ));
3521       } else if (shdr[i].sh_type == SHT_RELA) {
3522           IF_DEBUG(linker,debugBelch("RelA " ));
3523       } else {
3524           IF_DEBUG(linker,debugBelch("     "));
3525       }
3526       if (sh_strtab) {
3527           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
3528       }
3529    }
3530
3531    IF_DEBUG(linker,debugBelch( "\nString tables" ));
3532    strtab = NULL;
3533    nstrtab = 0;
3534    for (i = 0; i < ehdr->e_shnum; i++) {
3535       if (shdr[i].sh_type == SHT_STRTAB
3536           /* Ignore the section header's string table. */
3537           && i != ehdr->e_shstrndx
3538           /* Ignore string tables named .stabstr, as they contain
3539              debugging info. */
3540           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
3541          ) {
3542          IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
3543          strtab = ehdrC + shdr[i].sh_offset;
3544          nstrtab++;
3545       }
3546    }
3547    if (nstrtab != 1) {
3548       errorBelch("%s: no string tables, or too many", oc->fileName);
3549       return 0;
3550    }
3551
3552    nsymtabs = 0;
3553    IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
3554    for (i = 0; i < ehdr->e_shnum; i++) {
3555       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3556       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
3557       nsymtabs++;
3558       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3559       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3560       IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%ld rem)\n",
3561                nent,
3562                (long)shdr[i].sh_size % sizeof(Elf_Sym)
3563              ));
3564       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
3565          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
3566          return 0;
3567       }
3568       for (j = 0; j < nent; j++) {
3569          IF_DEBUG(linker,debugBelch("   %2d  ", j ));
3570          IF_DEBUG(linker,debugBelch("  sec=%-5d  size=%-3d  val=%5p  ",
3571                              (int)stab[j].st_shndx,
3572                              (int)stab[j].st_size,
3573                              (char*)stab[j].st_value ));
3574
3575          IF_DEBUG(linker,debugBelch("type=" ));
3576          switch (ELF_ST_TYPE(stab[j].st_info)) {
3577             case STT_NOTYPE:  IF_DEBUG(linker,debugBelch("notype " )); break;
3578             case STT_OBJECT:  IF_DEBUG(linker,debugBelch("object " )); break;
3579             case STT_FUNC  :  IF_DEBUG(linker,debugBelch("func   " )); break;
3580             case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
3581             case STT_FILE:    IF_DEBUG(linker,debugBelch("file   " )); break;
3582             default:          IF_DEBUG(linker,debugBelch("?      " )); break;
3583          }
3584          IF_DEBUG(linker,debugBelch("  " ));
3585
3586          IF_DEBUG(linker,debugBelch("bind=" ));
3587          switch (ELF_ST_BIND(stab[j].st_info)) {
3588             case STB_LOCAL :  IF_DEBUG(linker,debugBelch("local " )); break;
3589             case STB_GLOBAL:  IF_DEBUG(linker,debugBelch("global" )); break;
3590             case STB_WEAK  :  IF_DEBUG(linker,debugBelch("weak  " )); break;
3591             default:          IF_DEBUG(linker,debugBelch("?     " )); break;
3592          }
3593          IF_DEBUG(linker,debugBelch("  " ));
3594
3595          IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
3596       }
3597    }
3598
3599    if (nsymtabs == 0) {
3600       errorBelch("%s: didn't find any symbol tables", oc->fileName);
3601       return 0;
3602    }
3603
3604    return 1;
3605 }
3606
3607 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
3608 {
3609     *is_bss = FALSE;
3610
3611     if (hdr->sh_type == SHT_PROGBITS
3612         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
3613         /* .text-style section */
3614         return SECTIONKIND_CODE_OR_RODATA;
3615     }
3616
3617     if (hdr->sh_type == SHT_PROGBITS
3618             && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3619             /* .data-style section */
3620             return SECTIONKIND_RWDATA;
3621     }
3622
3623     if (hdr->sh_type == SHT_PROGBITS
3624         && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
3625         /* .rodata-style section */
3626         return SECTIONKIND_CODE_OR_RODATA;
3627     }
3628
3629     if (hdr->sh_type == SHT_NOBITS
3630         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3631         /* .bss-style section */
3632         *is_bss = TRUE;
3633         return SECTIONKIND_RWDATA;
3634     }
3635
3636     return SECTIONKIND_OTHER;
3637 }
3638
3639
3640 static int
3641 ocGetNames_ELF ( ObjectCode* oc )
3642 {
3643    int i, j, k, nent;
3644    Elf_Sym* stab;
3645
3646    char*     ehdrC    = (char*)(oc->image);
3647    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
3648    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
3649    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3650
3651    ASSERT(symhash != NULL);
3652
3653    if (!strtab) {
3654       errorBelch("%s: no strtab", oc->fileName);
3655       return 0;
3656    }
3657
3658    k = 0;
3659    for (i = 0; i < ehdr->e_shnum; i++) {
3660       /* Figure out what kind of section it is.  Logic derived from
3661          Figure 1.14 ("Special Sections") of the ELF document
3662          ("Portable Formats Specification, Version 1.1"). */
3663       int         is_bss = FALSE;
3664       SectionKind kind   = getSectionKind_ELF(&shdr[i], &is_bss);
3665
3666       if (is_bss && shdr[i].sh_size > 0) {
3667          /* This is a non-empty .bss section.  Allocate zeroed space for
3668             it, and set its .sh_offset field such that
3669             ehdrC + .sh_offset == addr_of_zeroed_space.  */
3670          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
3671                                        "ocGetNames_ELF(BSS)");
3672          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
3673          /*
3674          debugBelch("BSS section at 0x%x, size %d\n",
3675                          zspace, shdr[i].sh_size);
3676          */
3677       }
3678
3679       /* fill in the section info */
3680       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
3681          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
3682          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
3683                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
3684       }
3685
3686       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3687
3688       /* copy stuff into this module's object symbol table */
3689       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3690       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3691
3692       oc->n_symbols = nent;
3693       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3694                                    "ocGetNames_ELF(oc->symbols)");
3695
3696       for (j = 0; j < nent; j++) {
3697
3698          char  isLocal = FALSE; /* avoids uninit-var warning */
3699          char* ad      = NULL;
3700          char* nm      = strtab + stab[j].st_name;
3701          int   secno   = stab[j].st_shndx;
3702
3703          /* Figure out if we want to add it; if so, set ad to its
3704             address.  Otherwise leave ad == NULL. */
3705
3706          if (secno == SHN_COMMON) {
3707             isLocal = FALSE;
3708             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
3709             /*
3710             debugBelch("COMMON symbol, size %d name %s\n",
3711                             stab[j].st_size, nm);
3712             */
3713             /* Pointless to do addProddableBlock() for this area,
3714                since the linker should never poke around in it. */
3715          }
3716          else
3717          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
3718                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
3719               )
3720               /* and not an undefined symbol */
3721               && stab[j].st_shndx != SHN_UNDEF
3722               /* and not in a "special section" */
3723               && stab[j].st_shndx < SHN_LORESERVE
3724               &&
3725               /* and it's a not a section or string table or anything silly */
3726               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
3727                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
3728                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
3729               )
3730             ) {
3731             /* Section 0 is the undefined section, hence > and not >=. */
3732             ASSERT(secno > 0 && secno < ehdr->e_shnum);
3733             /*
3734             if (shdr[secno].sh_type == SHT_NOBITS) {
3735                debugBelch("   BSS symbol, size %d off %d name %s\n",
3736                                stab[j].st_size, stab[j].st_value, nm);
3737             }
3738             */
3739             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
3740             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
3741                isLocal = TRUE;
3742             } else {
3743 #ifdef ELF_FUNCTION_DESC
3744                /* dlsym() and the initialisation table both give us function
3745                 * descriptors, so to be consistent we store function descriptors
3746                 * in the symbol table */
3747                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
3748                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
3749 #endif
3750                IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p  %s %s\n",
3751                                       ad, oc->fileName, nm ));
3752                isLocal = FALSE;
3753             }
3754          }
3755
3756          /* And the decision is ... */
3757
3758          if (ad != NULL) {
3759             ASSERT(nm != NULL);
3760             oc->symbols[j] = nm;
3761             /* Acquire! */
3762             if (isLocal) {
3763                /* Ignore entirely. */
3764             } else {
3765                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
3766             }
3767          } else {
3768             /* Skip. */
3769             IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
3770                                    strtab + stab[j].st_name ));
3771             /*
3772             debugBelch(
3773                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
3774                     (int)ELF_ST_BIND(stab[j].st_info),
3775                     (int)ELF_ST_TYPE(stab[j].st_info),
3776                     (int)stab[j].st_shndx,
3777                     strtab + stab[j].st_name
3778                    );
3779             */
3780             oc->symbols[j] = NULL;
3781          }
3782
3783       }
3784    }
3785
3786    return 1;
3787 }
3788
3789 /* Do ELF relocations which lack an explicit addend.  All x86-linux
3790    relocations appear to be of this form. */
3791 static int
3792 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
3793                          Elf_Shdr* shdr, int shnum,
3794                          Elf_Sym*  stab, char* strtab )
3795 {
3796    int j;
3797    char *symbol;
3798    Elf_Word* targ;
3799    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
3800    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
3801    int target_shndx = shdr[shnum].sh_info;
3802    int symtab_shndx = shdr[shnum].sh_link;
3803
3804    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3805    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
3806    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3807                           target_shndx, symtab_shndx ));
3808
3809    /* Skip sections that we're not interested in. */
3810    {
3811        int is_bss;
3812        SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
3813        if (kind == SECTIONKIND_OTHER) {
3814            IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
3815            return 1;
3816        }
3817    }
3818
3819    for (j = 0; j < nent; j++) {
3820       Elf_Addr offset = rtab[j].r_offset;
3821       Elf_Addr info   = rtab[j].r_info;
3822
3823       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
3824       Elf_Word* pP = (Elf_Word*)P;
3825       Elf_Addr  A  = *pP;
3826       Elf_Addr  S;
3827       void*     S_tmp;
3828       Elf_Addr  value;
3829       StgStablePtr stablePtr;
3830       StgPtr stableVal;
3831
3832       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
3833                              j, (void*)offset, (void*)info ));
3834       if (!info) {
3835          IF_DEBUG(linker,debugBelch( " ZERO" ));
3836          S = 0;
3837       } else {
3838          Elf_Sym sym = stab[ELF_R_SYM(info)];
3839          /* First see if it is a local symbol. */
3840          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3841             /* Yes, so we can get the address directly from the ELF symbol
3842                table. */
3843             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3844             S = (Elf_Addr)
3845                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3846                        + stab[ELF_R_SYM(info)].st_value);
3847
3848          } else {
3849             symbol = strtab + sym.st_name;
3850             stablePtr = (StgStablePtr)lookupHashTable(stablehash, (StgWord)symbol);
3851             if (NULL == stablePtr) {
3852               /* No, so look up the name in our global table. */
3853               S_tmp = lookupSymbol( symbol );
3854               S = (Elf_Addr)S_tmp;
3855             } else {
3856               stableVal = deRefStablePtr( stablePtr );
3857               S_tmp = stableVal;
3858               S = (Elf_Addr)S_tmp;
3859             }
3860          }
3861          if (!S) {
3862             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3863             return 0;
3864          }
3865          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n", symbol, (void*)S ));
3866       }
3867
3868       IF_DEBUG(linker,debugBelch( "Reloc: P = %p   S = %p   A = %p\n",
3869                              (void*)P, (void*)S, (void*)A ));
3870       checkProddableBlock ( oc, pP );
3871
3872       value = S + A;
3873
3874       switch (ELF_R_TYPE(info)) {
3875 #        ifdef i386_HOST_ARCH
3876          case R_386_32:   *pP = value;     break;
3877          case R_386_PC32: *pP = value - P; break;
3878 #        endif
3879          default:
3880             errorBelch("%s: unhandled ELF relocation(Rel) type %lu\n",
3881                   oc->fileName, (lnat)ELF_R_TYPE(info));
3882             return 0;
3883       }
3884
3885    }
3886    return 1;
3887 }
3888
3889 /* Do ELF relocations for which explicit addends are supplied.
3890    sparc-solaris relocations appear to be of this form. */
3891 static int
3892 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
3893                           Elf_Shdr* shdr, int shnum,
3894                           Elf_Sym*  stab, char* strtab )
3895 {
3896    int j;
3897    char *symbol = NULL;
3898    Elf_Addr targ;
3899    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
3900    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
3901    int target_shndx = shdr[shnum].sh_info;
3902    int symtab_shndx = shdr[shnum].sh_link;
3903
3904    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3905    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
3906    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3907                           target_shndx, symtab_shndx ));
3908
3909    for (j = 0; j < nent; j++) {
3910 #if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3911       /* This #ifdef only serves to avoid unused-var warnings. */
3912       Elf_Addr  offset = rtab[j].r_offset;
3913       Elf_Addr  P      = targ + offset;
3914 #endif
3915       Elf_Addr  info   = rtab[j].r_info;
3916       Elf_Addr  A      = rtab[j].r_addend;
3917       Elf_Addr  S;
3918       void*     S_tmp;
3919       Elf_Addr  value;
3920 #     if defined(sparc_HOST_ARCH)
3921       Elf_Word* pP = (Elf_Word*)P;
3922       Elf_Word  w1, w2;
3923 #     elif defined(powerpc_HOST_ARCH)
3924       Elf_Sword delta;
3925 #     endif
3926
3927       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p %6p)   ",
3928                              j, (void*)offset, (void*)info,
3929                                 (void*)A ));
3930       if (!info) {
3931          IF_DEBUG(linker,debugBelch( " ZERO" ));
3932          S = 0;
3933       } else {
3934          Elf_Sym sym = stab[ELF_R_SYM(info)];
3935          /* First see if it is a local symbol. */
3936          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3937             /* Yes, so we can get the address directly from the ELF symbol
3938                table. */
3939             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3940             S = (Elf_Addr)
3941                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3942                        + stab[ELF_R_SYM(info)].st_value);
3943 #ifdef ELF_FUNCTION_DESC
3944             /* Make a function descriptor for this function */
3945             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
3946                S = allocateFunctionDesc(S + A);
3947                A = 0;
3948             }
3949 #endif
3950          } else {
3951             /* No, so look up the name in our global table. */
3952             symbol = strtab + sym.st_name;
3953             S_tmp = lookupSymbol( symbol );
3954             S = (Elf_Addr)S_tmp;
3955
3956 #ifdef ELF_FUNCTION_DESC
3957             /* If a function, already a function descriptor - we would
3958                have to copy it to add an offset. */
3959             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
3960                errorBelch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
3961 #endif
3962          }
3963          if (!S) {
3964            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3965            return 0;
3966          }
3967          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p", symbol, (void*)S ));
3968       }
3969
3970       IF_DEBUG(linker,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
3971                                         (void*)P, (void*)S, (void*)A ));
3972       /* checkProddableBlock ( oc, (void*)P ); */
3973
3974       value = S + A;
3975
3976       switch (ELF_R_TYPE(info)) {
3977 #        if defined(sparc_HOST_ARCH)
3978          case R_SPARC_WDISP30:
3979             w1 = *pP & 0xC0000000;
3980             w2 = (Elf_Word)((value - P) >> 2);
3981             ASSERT((w2 & 0xC0000000) == 0);
3982             w1 |= w2;
3983             *pP = w1;
3984             break;
3985          case R_SPARC_HI22:
3986             w1 = *pP & 0xFFC00000;
3987             w2 = (Elf_Word)(value >> 10);
3988             ASSERT((w2 & 0xFFC00000) == 0);
3989             w1 |= w2;
3990             *pP = w1;
3991             break;
3992          case R_SPARC_LO10:
3993             w1 = *pP & ~0x3FF;
3994             w2 = (Elf_Word)(value & 0x3FF);
3995             ASSERT((w2 & ~0x3FF) == 0);
3996             w1 |= w2;
3997             *pP = w1;
3998             break;
3999
4000          /* According to the Sun documentation:
4001             R_SPARC_UA32
4002             This relocation type resembles R_SPARC_32, except it refers to an
4003             unaligned word. That is, the word to be relocated must be treated
4004             as four separate bytes with arbitrary alignment, not as a word
4005             aligned according to the architecture requirements.
4006          */
4007          case R_SPARC_UA32:
4008             w2  = (Elf_Word)value;
4009
4010             // SPARC doesn't do misaligned writes of 32 bit words,
4011             //       so we have to do this one byte-at-a-time.
4012             char *pPc   = (char*)pP;
4013             pPc[0]      = (char) ((Elf_Word)(w2 & 0xff000000) >> 24);
4014             pPc[1]      = (char) ((Elf_Word)(w2 & 0x00ff0000) >> 16);
4015             pPc[2]      = (char) ((Elf_Word)(w2 & 0x0000ff00) >> 8);
4016             pPc[3]      = (char) ((Elf_Word)(w2 & 0x000000ff));
4017             break;
4018
4019          case R_SPARC_32:
4020             w2 = (Elf_Word)value;
4021             *pP = w2;
4022             break;
4023 #        elif defined(powerpc_HOST_ARCH)
4024          case R_PPC_ADDR16_LO:
4025             *(Elf32_Half*) P = value;
4026             break;
4027
4028          case R_PPC_ADDR16_HI:
4029             *(Elf32_Half*) P = value >> 16;
4030             break;
4031
4032          case R_PPC_ADDR16_HA:
4033             *(Elf32_Half*) P = (value + 0x8000) >> 16;
4034             break;
4035
4036          case R_PPC_ADDR32:
4037             *(Elf32_Word *) P = value;
4038             break;
4039
4040          case R_PPC_REL32:
4041             *(Elf32_Word *) P = value - P;
4042             break;
4043
4044          case R_PPC_REL24:
4045             delta = value - P;
4046
4047             if( delta << 6 >> 6 != delta )
4048             {
4049                value = (Elf_Addr) (&makeSymbolExtra( oc, ELF_R_SYM(info), value )
4050                                         ->jumpIsland);
4051                delta = value - P;
4052
4053                if( value == 0 || delta << 6 >> 6 != delta )
4054                {
4055                   barf( "Unable to make SymbolExtra for #%d",
4056                         ELF_R_SYM(info) );
4057                   return 0;
4058                }
4059             }
4060
4061             *(Elf_Word *) P = (*(Elf_Word *) P & 0xfc000003)
4062                                           | (delta & 0x3fffffc);
4063             break;
4064 #        endif
4065
4066 #if x86_64_HOST_ARCH
4067       case R_X86_64_64:
4068           *(Elf64_Xword *)P = value;
4069           break;
4070
4071       case R_X86_64_PC32:
4072       {
4073 #if defined(ALWAYS_PIC)
4074           barf("R_X86_64_PC32 relocation, but ALWAYS_PIC.");
4075 #else
4076           StgInt64 off = value - P;
4077           if (off >= 0x7fffffffL || off < -0x80000000L) {
4078 #if X86_64_ELF_NONPIC_HACK
4079               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
4080                                                 -> jumpIsland;
4081               off = pltAddress + A - P;
4082 #else
4083               barf("R_X86_64_PC32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
4084                    symbol, off, oc->fileName );
4085 #endif
4086           }
4087           *(Elf64_Word *)P = (Elf64_Word)off;
4088 #endif
4089           break;
4090       }
4091
4092       case R_X86_64_PC64:
4093       {
4094           StgInt64 off = value - P;
4095           *(Elf64_Word *)P = (Elf64_Word)off;
4096           break;
4097       }
4098
4099       case R_X86_64_32:
4100 #if defined(ALWAYS_PIC)
4101           barf("R_X86_64_32 relocation, but ALWAYS_PIC.");
4102 #else
4103           if (value >= 0x7fffffffL) {
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_32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
4110                    symbol, value, oc->fileName );
4111 #endif
4112           }
4113           *(Elf64_Word *)P = (Elf64_Word)value;
4114 #endif
4115           break;
4116
4117       case R_X86_64_32S:
4118 #if defined(ALWAYS_PIC)
4119           barf("R_X86_64_32S relocation, but ALWAYS_PIC.");
4120 #else
4121           if ((StgInt64)value > 0x7fffffffL || (StgInt64)value < -0x80000000L) {
4122 #if X86_64_ELF_NONPIC_HACK
4123               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
4124                                                 -> jumpIsland;
4125               value = pltAddress + A;
4126 #else
4127               barf("R_X86_64_32S relocation out of range: %s = %p\nRecompile %s with -fPIC.",
4128                    symbol, value, oc->fileName );
4129 #endif
4130           }
4131           *(Elf64_Sword *)P = (Elf64_Sword)value;
4132 #endif
4133           break;
4134
4135       case R_X86_64_GOTPCREL:
4136       {
4137           StgInt64 gotAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)->addr;
4138           StgInt64 off = gotAddress + A - P;
4139           *(Elf64_Word *)P = (Elf64_Word)off;
4140           break;
4141       }
4142
4143       case R_X86_64_PLT32:
4144       {
4145 #if defined(ALWAYS_PIC)
4146           barf("R_X86_64_PLT32 relocation, but ALWAYS_PIC.");
4147 #else
4148           StgInt64 off = value - P;
4149           if (off >= 0x7fffffffL || off < -0x80000000L) {
4150               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
4151                                                     -> jumpIsland;
4152               off = pltAddress + A - P;
4153           }
4154           *(Elf64_Word *)P = (Elf64_Word)off;
4155 #endif
4156           break;
4157       }
4158 #endif
4159
4160          default:
4161             errorBelch("%s: unhandled ELF relocation(RelA) type %lu\n",
4162                   oc->fileName, (lnat)ELF_R_TYPE(info));
4163             return 0;
4164       }
4165
4166    }
4167    return 1;
4168 }
4169
4170 static int
4171 ocResolve_ELF ( ObjectCode* oc )
4172 {
4173    char *strtab;
4174    int   shnum, ok;
4175    Elf_Sym*  stab  = NULL;
4176    char*     ehdrC = (char*)(oc->image);
4177    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
4178    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
4179
4180    /* first find "the" symbol table */
4181    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
4182
4183    /* also go find the string table */
4184    strtab = findElfSection ( ehdrC, SHT_STRTAB );
4185
4186    if (stab == NULL || strtab == NULL) {
4187       errorBelch("%s: can't find string or symbol table", oc->fileName);
4188       return 0;
4189    }
4190
4191    /* Process the relocation sections. */
4192    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
4193       if (shdr[shnum].sh_type == SHT_REL) {
4194          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
4195                                        shnum, stab, strtab );
4196          if (!ok) return ok;
4197       }
4198       else
4199       if (shdr[shnum].sh_type == SHT_RELA) {
4200          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
4201                                         shnum, stab, strtab );
4202          if (!ok) return ok;
4203       }
4204    }
4205
4206 #if defined(powerpc_HOST_ARCH)
4207    ocFlushInstructionCache( oc );
4208 #endif
4209
4210    return 1;
4211 }
4212
4213 /*
4214  * PowerPC & X86_64 ELF specifics
4215  */
4216
4217 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
4218
4219 static int ocAllocateSymbolExtras_ELF( ObjectCode *oc )
4220 {
4221   Elf_Ehdr *ehdr;
4222   Elf_Shdr* shdr;
4223   int i;
4224
4225   ehdr = (Elf_Ehdr *) oc->image;
4226   shdr = (Elf_Shdr *) ( ((char *)oc->image) + ehdr->e_shoff );
4227
4228   for( i = 0; i < ehdr->e_shnum; i++ )
4229     if( shdr[i].sh_type == SHT_SYMTAB )
4230       break;
4231
4232   if( i == ehdr->e_shnum )
4233   {
4234     errorBelch( "This ELF file contains no symtab" );
4235     return 0;
4236   }
4237
4238   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
4239   {
4240     errorBelch( "The entry size (%d) of the symtab isn't %d\n",
4241       (int) shdr[i].sh_entsize, (int) sizeof( Elf_Sym ) );
4242
4243     return 0;
4244   }
4245
4246   return ocAllocateSymbolExtras( oc, shdr[i].sh_size / sizeof( Elf_Sym ), 0 );
4247 }
4248
4249 #endif /* powerpc */
4250
4251 #endif /* ELF */
4252
4253 /* --------------------------------------------------------------------------
4254  * Mach-O specifics
4255  * ------------------------------------------------------------------------*/
4256
4257 #if defined(OBJFORMAT_MACHO)
4258
4259 /*
4260   Support for MachO linking on Darwin/MacOS X
4261   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
4262
4263   I hereby formally apologize for the hackish nature of this code.
4264   Things that need to be done:
4265   *) implement ocVerifyImage_MachO
4266   *) add still more sanity checks.
4267 */
4268
4269 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
4270 #define mach_header mach_header_64
4271 #define segment_command segment_command_64
4272 #define section section_64
4273 #define nlist nlist_64
4274 #endif
4275
4276 #ifdef powerpc_HOST_ARCH
4277 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
4278 {
4279     struct mach_header *header = (struct mach_header *) oc->image;
4280     struct load_command *lc = (struct load_command *) (header + 1);
4281     unsigned i;
4282
4283     for( i = 0; i < header->ncmds; i++ )
4284     {
4285         if( lc->cmd == LC_SYMTAB )
4286         {
4287                 // Find out the first and last undefined external
4288                 // symbol, so we don't have to allocate too many
4289                 // jump islands.
4290             struct symtab_command *symLC = (struct symtab_command *) lc;
4291             unsigned min = symLC->nsyms, max = 0;
4292             struct nlist *nlist =
4293                 symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
4294                       : NULL;
4295             for(i=0;i<symLC->nsyms;i++)
4296             {
4297                 if(nlist[i].n_type & N_STAB)
4298                     ;
4299                 else if(nlist[i].n_type & N_EXT)
4300                 {
4301                     if((nlist[i].n_type & N_TYPE) == N_UNDF
4302                         && (nlist[i].n_value == 0))
4303                     {
4304                         if(i < min)
4305                             min = i;
4306                         if(i > max)
4307                             max = i;
4308                     }
4309                 }
4310             }
4311             if(max >= min)
4312                 return ocAllocateSymbolExtras(oc, max - min + 1, min);
4313
4314             break;
4315         }
4316
4317         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
4318     }
4319     return ocAllocateSymbolExtras(oc,0,0);
4320 }
4321 #endif
4322 #ifdef x86_64_HOST_ARCH
4323 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
4324 {
4325     struct mach_header *header = (struct mach_header *) oc->image;
4326     struct load_command *lc = (struct load_command *) (header + 1);
4327     unsigned i;
4328
4329     for( i = 0; i < header->ncmds; i++ )
4330     {
4331         if( lc->cmd == LC_SYMTAB )
4332         {
4333                 // Just allocate one entry for every symbol
4334             struct symtab_command *symLC = (struct symtab_command *) lc;
4335
4336             return ocAllocateSymbolExtras(oc, symLC->nsyms, 0);
4337         }
4338
4339         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
4340     }
4341     return ocAllocateSymbolExtras(oc,0,0);
4342 }
4343 #endif
4344
4345 static int ocVerifyImage_MachO(ObjectCode* oc)
4346 {
4347     char *image = (char*) oc->image;
4348     struct mach_header *header = (struct mach_header*) image;
4349
4350 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
4351     if(header->magic != MH_MAGIC_64) {
4352         errorBelch("%s: Bad magic. Expected: %08x, got: %08x.\n",
4353                    oc->fileName, MH_MAGIC_64, header->magic);
4354         return 0;
4355     }
4356 #else
4357     if(header->magic != MH_MAGIC) {
4358         errorBelch("%s: Bad magic. Expected: %08x, got: %08x.\n",
4359                    oc->fileName, MH_MAGIC, header->magic);
4360         return 0;
4361     }
4362 #endif
4363     // FIXME: do some more verifying here
4364     return 1;
4365 }
4366
4367 static int resolveImports(
4368     ObjectCode* oc,
4369     char *image,
4370     struct symtab_command *symLC,
4371     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
4372     unsigned long *indirectSyms,
4373     struct nlist *nlist)
4374 {
4375     unsigned i;
4376     size_t itemSize = 4;
4377
4378     IF_DEBUG(linker, debugBelch("resolveImports: start\n"));
4379
4380 #if i386_HOST_ARCH
4381     int isJumpTable = 0;
4382     if(!strcmp(sect->sectname,"__jump_table"))
4383     {
4384         isJumpTable = 1;
4385         itemSize = 5;
4386         ASSERT(sect->reserved2 == itemSize);
4387     }
4388 #endif
4389
4390     for(i=0; i*itemSize < sect->size;i++)
4391     {
4392         // according to otool, reserved1 contains the first index into the indirect symbol table
4393         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
4394         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4395         void *addr = NULL;
4396
4397         IF_DEBUG(linker, debugBelch("resolveImports: resolving %s\n", nm));
4398         if ((symbol->n_type & N_TYPE) == N_UNDF
4399             && (symbol->n_type & N_EXT) && (symbol->n_value != 0)) {
4400             addr = (void*) (symbol->n_value);
4401             IF_DEBUG(linker, debugBelch("resolveImports: undefined external %s has value %p\n", nm, addr));
4402         } else {
4403             addr = lookupSymbol(nm);
4404             IF_DEBUG(linker, debugBelch("resolveImports: looking up %s, %p\n", nm, addr));
4405         }
4406         if (!addr)
4407         {
4408             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
4409             return 0;
4410         }
4411         ASSERT(addr);
4412
4413 #if i386_HOST_ARCH
4414         if(isJumpTable)
4415         {
4416             checkProddableBlock(oc,image + sect->offset + i*itemSize);
4417             *(image + sect->offset + i*itemSize) = 0xe9; // jmp
4418             *(unsigned*)(image + sect->offset + i*itemSize + 1)
4419                 = (char*)addr - (image + sect->offset + i*itemSize + 5);
4420         }
4421         else
4422 #endif
4423         {
4424             checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
4425             ((void**)(image + sect->offset))[i] = addr;
4426         }
4427     }
4428
4429     IF_DEBUG(linker, debugBelch("resolveImports: done\n"));
4430     return 1;
4431 }
4432
4433 static unsigned long relocateAddress(
4434     ObjectCode* oc,
4435     int nSections,
4436     struct section* sections,
4437     unsigned long address)
4438 {
4439     int i;
4440     IF_DEBUG(linker, debugBelch("relocateAddress: start\n"));
4441     for (i = 0; i < nSections; i++)
4442     {
4443             IF_DEBUG(linker, debugBelch("    relocating address in section %d\n", i));
4444         if (sections[i].addr <= address
4445             && address < sections[i].addr + sections[i].size)
4446         {
4447             return (unsigned long)oc->image
4448                     + sections[i].offset + address - sections[i].addr;
4449         }
4450     }
4451     barf("Invalid Mach-O file:"
4452          "Address out of bounds while relocating object file");
4453     return 0;
4454 }
4455
4456 static int relocateSection(
4457     ObjectCode* oc,
4458     char *image,
4459     struct symtab_command *symLC, struct nlist *nlist,
4460     int nSections, struct section* sections, struct section *sect)
4461 {
4462     struct relocation_info *relocs;
4463     int i, n;
4464
4465     IF_DEBUG(linker, debugBelch("relocateSection: start\n"));
4466
4467     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
4468         return 1;
4469     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
4470         return 1;
4471     else if(!strcmp(sect->sectname,"__la_sym_ptr2"))
4472         return 1;
4473     else if(!strcmp(sect->sectname,"__la_sym_ptr3"))
4474         return 1;
4475
4476     n = sect->nreloc;
4477     IF_DEBUG(linker, debugBelch("relocateSection: number of relocations: %d\n", n));
4478
4479     relocs = (struct relocation_info*) (image + sect->reloff);
4480
4481     for(i=0;i<n;i++)
4482     {
4483 #ifdef x86_64_HOST_ARCH
4484         struct relocation_info *reloc = &relocs[i];
4485
4486         char    *thingPtr = image + sect->offset + reloc->r_address;
4487         uint64_t thing;
4488         /* We shouldn't need to initialise this, but gcc on OS X 64 bit
4489            complains that it may be used uninitialized if we don't */
4490         uint64_t value = 0;
4491         uint64_t baseValue;
4492         int type = reloc->r_type;
4493
4494         checkProddableBlock(oc,thingPtr);
4495         switch(reloc->r_length)
4496         {
4497             case 0:
4498                 thing = *(uint8_t*)thingPtr;
4499                 baseValue = (uint64_t)thingPtr + 1;
4500                 break;
4501             case 1:
4502                 thing = *(uint16_t*)thingPtr;
4503                 baseValue = (uint64_t)thingPtr + 2;
4504                 break;
4505             case 2:
4506                 thing = *(uint32_t*)thingPtr;
4507                 baseValue = (uint64_t)thingPtr + 4;
4508                 break;
4509             case 3:
4510                 thing = *(uint64_t*)thingPtr;
4511                 baseValue = (uint64_t)thingPtr + 8;
4512                 break;
4513             default:
4514                 barf("Unknown size.");
4515         }
4516
4517         IF_DEBUG(linker,
4518                  debugBelch("relocateSection: length = %d, thing = %d, baseValue = %p\n",
4519                             reloc->r_length, thing, baseValue));
4520
4521         if (type == X86_64_RELOC_GOT
4522            || type == X86_64_RELOC_GOT_LOAD)
4523         {
4524             struct nlist *symbol = &nlist[reloc->r_symbolnum];
4525             char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4526
4527             IF_DEBUG(linker, debugBelch("relocateSection: making jump island for %s, extern = %d, X86_64_RELOC_GOT\n", nm, reloc->r_extern));
4528             ASSERT(reloc->r_extern);
4529             value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, (unsigned long)lookupSymbol(nm))->addr;
4530
4531             type = X86_64_RELOC_SIGNED;
4532         }
4533         else if(reloc->r_extern)
4534         {
4535             struct nlist *symbol = &nlist[reloc->r_symbolnum];
4536             char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4537
4538             IF_DEBUG(linker, debugBelch("relocateSection: looking up external symbol %s\n", nm));
4539             IF_DEBUG(linker, debugBelch("               : type  = %d\n", symbol->n_type));
4540             IF_DEBUG(linker, debugBelch("               : sect  = %d\n", symbol->n_sect));
4541             IF_DEBUG(linker, debugBelch("               : desc  = %d\n", symbol->n_desc));
4542             IF_DEBUG(linker, debugBelch("               : value = %d\n", symbol->n_value));
4543             if ((symbol->n_type & N_TYPE) == N_SECT) {
4544                 value = relocateAddress(oc, nSections, sections,
4545                                         symbol->n_value);
4546                 IF_DEBUG(linker, debugBelch("relocateSection, defined external symbol %s, relocated address %p\n", nm, value));
4547             }
4548             else {
4549                 value = (uint64_t) lookupSymbol(nm);
4550                 IF_DEBUG(linker, debugBelch("relocateSection: external symbol %s, address %p\n", nm, value));
4551             }
4552         }
4553         else
4554         {
4555             value = sections[reloc->r_symbolnum-1].offset
4556                   - sections[reloc->r_symbolnum-1].addr
4557                   + (uint64_t) image;
4558         }
4559
4560         IF_DEBUG(linker, debugBelch("relocateSection: value = %p\n", value));
4561
4562         if (type == X86_64_RELOC_BRANCH)
4563         {
4564             if((int32_t)(value - baseValue) != (int64_t)(value - baseValue))
4565             {
4566                 ASSERT(reloc->r_extern);
4567                 value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)
4568                                         -> jumpIsland;
4569             }
4570             ASSERT((int32_t)(value - baseValue) == (int64_t)(value - baseValue));
4571             type = X86_64_RELOC_SIGNED;
4572         }
4573
4574         switch(type)
4575         {
4576             case X86_64_RELOC_UNSIGNED:
4577                 ASSERT(!reloc->r_pcrel);
4578                 thing += value;
4579                 break;
4580             case X86_64_RELOC_SIGNED:
4581             case X86_64_RELOC_SIGNED_1:
4582             case X86_64_RELOC_SIGNED_2:
4583             case X86_64_RELOC_SIGNED_4:
4584                 ASSERT(reloc->r_pcrel);
4585                 thing += value - baseValue;
4586                 break;
4587             case X86_64_RELOC_SUBTRACTOR:
4588                 ASSERT(!reloc->r_pcrel);
4589                 thing -= value;
4590                 break;
4591             default:
4592                 barf("unkown relocation");
4593         }
4594
4595         switch(reloc->r_length)
4596         {
4597             case 0:
4598                 *(uint8_t*)thingPtr = thing;
4599                 break;
4600             case 1:
4601                 *(uint16_t*)thingPtr = thing;
4602                 break;
4603             case 2:
4604                 *(uint32_t*)thingPtr = thing;
4605                 break;
4606             case 3:
4607                 *(uint64_t*)thingPtr = thing;
4608                 break;
4609         }
4610 #else
4611         if(relocs[i].r_address & R_SCATTERED)
4612         {
4613             struct scattered_relocation_info *scat =
4614                 (struct scattered_relocation_info*) &relocs[i];
4615
4616             if(!scat->r_pcrel)
4617             {
4618                 if(scat->r_length == 2)
4619                 {
4620                     unsigned long word = 0;
4621                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
4622                     checkProddableBlock(oc,wordPtr);
4623
4624                     // Note on relocation types:
4625                     // i386 uses the GENERIC_RELOC_* types,
4626                     // while ppc uses special PPC_RELOC_* types.
4627                     // *_RELOC_VANILLA and *_RELOC_PAIR have the same value
4628                     // in both cases, all others are different.
4629                     // Therefore, we use GENERIC_RELOC_VANILLA
4630                     // and GENERIC_RELOC_PAIR instead of the PPC variants,
4631                     // and use #ifdefs for the other types.
4632
4633                     // Step 1: Figure out what the relocated value should be
4634                     if(scat->r_type == GENERIC_RELOC_VANILLA)
4635                     {
4636                         word = *wordPtr + (unsigned long) relocateAddress(
4637                                                                 oc,
4638                                                                 nSections,
4639                                                                 sections,
4640                                                                 scat->r_value)
4641                                         - scat->r_value;
4642                     }
4643 #ifdef powerpc_HOST_ARCH
4644                     else if(scat->r_type == PPC_RELOC_SECTDIFF
4645                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
4646                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
4647                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF
4648                         || scat->r_type == PPC_RELOC_LOCAL_SECTDIFF)
4649 #else
4650                     else if(scat->r_type == GENERIC_RELOC_SECTDIFF
4651                         || scat->r_type == GENERIC_RELOC_LOCAL_SECTDIFF)
4652 #endif
4653                     {
4654                         struct scattered_relocation_info *pair =
4655                                 (struct scattered_relocation_info*) &relocs[i+1];
4656
4657                         if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR)
4658                             barf("Invalid Mach-O file: "
4659                                  "RELOC_*_SECTDIFF not followed by RELOC_PAIR");
4660
4661                         word = (unsigned long)
4662                                (relocateAddress(oc, nSections, sections, scat->r_value)
4663                               - relocateAddress(oc, nSections, sections, pair->r_value));
4664                         i++;
4665                     }
4666 #ifdef powerpc_HOST_ARCH
4667                     else if(scat->r_type == PPC_RELOC_HI16
4668                          || scat->r_type == PPC_RELOC_LO16
4669                          || scat->r_type == PPC_RELOC_HA16
4670                          || scat->r_type == PPC_RELOC_LO14)
4671                     {   // these are generated by label+offset things
4672                         struct relocation_info *pair = &relocs[i+1];
4673                         if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
4674                             barf("Invalid Mach-O file: "
4675                                  "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
4676
4677                         if(scat->r_type == PPC_RELOC_LO16)
4678                         {
4679                             word = ((unsigned short*) wordPtr)[1];
4680                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4681                         }
4682                         else if(scat->r_type == PPC_RELOC_LO14)
4683                         {
4684                             barf("Unsupported Relocation: PPC_RELOC_LO14");
4685                             word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
4686                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4687                         }
4688                         else if(scat->r_type == PPC_RELOC_HI16)
4689                         {
4690                             word = ((unsigned short*) wordPtr)[1] << 16;
4691                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4692                         }
4693                         else if(scat->r_type == PPC_RELOC_HA16)
4694                         {
4695                             word = ((unsigned short*) wordPtr)[1] << 16;
4696                             word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4697                         }
4698
4699
4700                         word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
4701                                                 - scat->r_value;
4702
4703                         i++;
4704                     }
4705  #endif
4706                     else
4707                     {
4708                         barf ("Don't know how to handle this Mach-O "
4709                               "scattered relocation entry: "
4710                               "object file %s; entry type %ld; "
4711                               "address %#lx\n",
4712                               OC_INFORMATIVE_FILENAME(oc),
4713                               scat->r_type,
4714                               scat->r_address);
4715                         return 0;
4716                      }
4717
4718 #ifdef powerpc_HOST_ARCH
4719                     if(scat->r_type == GENERIC_RELOC_VANILLA
4720                         || scat->r_type == PPC_RELOC_SECTDIFF)
4721 #else
4722                     if(scat->r_type == GENERIC_RELOC_VANILLA
4723                         || scat->r_type == GENERIC_RELOC_SECTDIFF
4724                         || scat->r_type == GENERIC_RELOC_LOCAL_SECTDIFF)
4725 #endif
4726                     {
4727                         *wordPtr = word;
4728                     }
4729 #ifdef powerpc_HOST_ARCH
4730                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
4731                     {
4732                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4733                     }
4734                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
4735                     {
4736                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4737                     }
4738                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
4739                     {
4740                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4741                             + ((word & (1<<15)) ? 1 : 0);
4742                     }
4743 #endif
4744                 }
4745                 else
4746                 {
4747                     barf("Can't handle Mach-O scattered relocation entry "
4748                          "with this r_length tag: "
4749                          "object file %s; entry type %ld; "
4750                          "r_length tag %ld; address %#lx\n",
4751                          OC_INFORMATIVE_FILENAME(oc),
4752                          scat->r_type,
4753                          scat->r_length,
4754                          scat->r_address);
4755                     return 0;
4756                 }
4757             }
4758             else /* scat->r_pcrel */
4759             {
4760                 barf("Don't know how to handle *PC-relative* Mach-O "
4761                      "scattered relocation entry: "
4762                      "object file %s; entry type %ld; address %#lx\n",
4763                      OC_INFORMATIVE_FILENAME(oc),
4764                      scat->r_type,
4765                      scat->r_address);
4766                return 0;
4767             }
4768
4769         }
4770         else /* !(relocs[i].r_address & R_SCATTERED) */
4771         {
4772             struct relocation_info *reloc = &relocs[i];
4773             if(reloc->r_pcrel && !reloc->r_extern)
4774                 continue;
4775
4776             if(reloc->r_length == 2)
4777             {
4778                 unsigned long word = 0;
4779 #ifdef powerpc_HOST_ARCH
4780                 unsigned long jumpIsland = 0;
4781                 long offsetToJumpIsland = 0xBADBAD42; // initialise to bad value
4782                                                       // to avoid warning and to catch
4783                                                       // bugs.
4784 #endif
4785
4786                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
4787                 checkProddableBlock(oc,wordPtr);
4788
4789                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4790                 {
4791                     word = *wordPtr;
4792                 }
4793 #ifdef powerpc_HOST_ARCH
4794                 else if(reloc->r_type == PPC_RELOC_LO16)
4795                 {
4796                     word = ((unsigned short*) wordPtr)[1];
4797                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4798                 }
4799                 else if(reloc->r_type == PPC_RELOC_HI16)
4800                 {
4801                     word = ((unsigned short*) wordPtr)[1] << 16;
4802                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4803                 }
4804                 else if(reloc->r_type == PPC_RELOC_HA16)
4805                 {
4806                     word = ((unsigned short*) wordPtr)[1] << 16;
4807                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4808                 }
4809                 else if(reloc->r_type == PPC_RELOC_BR24)
4810                 {
4811                     word = *wordPtr;
4812                     word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0);
4813                 }
4814 #endif
4815                 else
4816                 {
4817                     barf("Can't handle this Mach-O relocation entry "
4818                          "(not scattered): "
4819                          "object file %s; entry type %ld; address %#lx\n",
4820                          OC_INFORMATIVE_FILENAME(oc),
4821                          reloc->r_type,
4822                          reloc->r_address);
4823                     return 0;
4824                 }
4825
4826                 if(!reloc->r_extern)
4827                 {
4828                     long delta =
4829                         sections[reloc->r_symbolnum-1].offset
4830                         - sections[reloc->r_symbolnum-1].addr
4831                         + ((long) image);
4832
4833                     word += delta;
4834                 }
4835                 else
4836                 {
4837                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
4838                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4839                     void *symbolAddress = lookupSymbol(nm);
4840                     if(!symbolAddress)
4841                     {
4842                         errorBelch("\nunknown symbol `%s'", nm);
4843                         return 0;
4844                     }
4845
4846                     if(reloc->r_pcrel)
4847                     {
4848 #ifdef powerpc_HOST_ARCH
4849                             // In the .o file, this should be a relative jump to NULL
4850                             // and we'll change it to a relative jump to the symbol
4851                         ASSERT(word + reloc->r_address == 0);
4852                         jumpIsland = (unsigned long)
4853                                         &makeSymbolExtra(oc,
4854                                                          reloc->r_symbolnum,
4855                                                          (unsigned long) symbolAddress)
4856                                          -> jumpIsland;
4857                         if(jumpIsland != 0)
4858                         {
4859                             offsetToJumpIsland = word + jumpIsland
4860                                 - (((long)image) + sect->offset - sect->addr);
4861                         }
4862 #endif
4863                         word += (unsigned long) symbolAddress
4864                                 - (((long)image) + sect->offset - sect->addr);
4865                     }
4866                     else
4867                     {
4868                         word += (unsigned long) symbolAddress;
4869                     }
4870                 }
4871
4872                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4873                 {
4874                     *wordPtr = word;
4875                     continue;
4876                 }
4877 #ifdef powerpc_HOST_ARCH
4878                 else if(reloc->r_type == PPC_RELOC_LO16)
4879                 {
4880                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4881                     i++; continue;
4882                 }
4883                 else if(reloc->r_type == PPC_RELOC_HI16)
4884                 {
4885                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4886                     i++; continue;
4887                 }
4888                 else if(reloc->r_type == PPC_RELOC_HA16)
4889                 {
4890                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4891                         + ((word & (1<<15)) ? 1 : 0);
4892                     i++; continue;
4893                 }
4894                 else if(reloc->r_type == PPC_RELOC_BR24)
4895                 {
4896                     if((word & 0x03) != 0)
4897                         barf("%s: unconditional relative branch with a displacement "
4898                              "which isn't a multiple of 4 bytes: %#lx",
4899                              OC_INFORMATIVE_FILENAME(oc),
4900                              word);
4901
4902                     if((word & 0xFE000000) != 0xFE000000 &&
4903                        (word & 0xFE000000) != 0x00000000)
4904                     {
4905                         // The branch offset is too large.
4906                         // Therefore, we try to use a jump island.
4907                         if(jumpIsland == 0)
4908                         {
4909                             barf("%s: unconditional relative branch out of range: "
4910                                  "no jump island available: %#lx",
4911                                  OC_INFORMATIVE_FILENAME(oc),
4912                                  word);
4913                         }
4914
4915                         word = offsetToJumpIsland;
4916                         if((word & 0xFE000000) != 0xFE000000 &&
4917                            (word & 0xFE000000) != 0x00000000)
4918                             barf("%s: unconditional relative branch out of range: "
4919                                  "jump island out of range: %#lx",
4920                                  OC_INFORMATIVE_FILENAME(oc),
4921                                  word);
4922                     }
4923                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
4924                     continue;
4925                 }
4926 #endif
4927             }
4928             else
4929             {
4930                  barf("Can't handle Mach-O relocation entry (not scattered) "
4931                       "with this r_length tag: "
4932                       "object file %s; entry type %ld; "
4933                       "r_length tag %ld; address %#lx\n",
4934                       OC_INFORMATIVE_FILENAME(oc),
4935                       reloc->r_type,
4936                       reloc->r_length,
4937                       reloc->r_address);
4938                  return 0;
4939             }
4940         }
4941 #endif
4942     }
4943     IF_DEBUG(linker, debugBelch("relocateSection: done\n"));
4944     return 1;
4945 }
4946
4947 static int ocGetNames_MachO(ObjectCode* oc)
4948 {
4949     char *image = (char*) oc->image;
4950     struct mach_header *header = (struct mach_header*) image;
4951     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4952     unsigned i,curSymbol = 0;
4953     struct segment_command *segLC = NULL;
4954     struct section *sections;
4955     struct symtab_command *symLC = NULL;
4956     struct nlist *nlist;
4957     unsigned long commonSize = 0;
4958     char    *commonStorage = NULL;
4959     unsigned long commonCounter;
4960
4961     IF_DEBUG(linker,debugBelch("ocGetNames_MachO: start\n"));
4962
4963     for(i=0;i<header->ncmds;i++)
4964     {
4965         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4966             segLC = (struct segment_command*) lc;
4967         else if(lc->cmd == LC_SYMTAB)
4968             symLC = (struct symtab_command*) lc;
4969         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4970     }
4971
4972     sections = (struct section*) (segLC+1);
4973     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4974                   : NULL;
4975
4976     if(!segLC)
4977         barf("ocGetNames_MachO: no segment load command");
4978
4979     for(i=0;i<segLC->nsects;i++)
4980     {
4981         IF_DEBUG(linker, debugBelch("ocGetNames_MachO: segment %d\n", i));
4982         if (sections[i].size == 0)
4983             continue;
4984
4985         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
4986         {
4987             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
4988                                       "ocGetNames_MachO(common symbols)");
4989             sections[i].offset = zeroFillArea - image;
4990         }
4991
4992         if(!strcmp(sections[i].sectname,"__text"))
4993             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
4994                 (void*) (image + sections[i].offset),
4995                 (void*) (image + sections[i].offset + sections[i].size));
4996         else if(!strcmp(sections[i].sectname,"__const"))
4997             addSection(oc, SECTIONKIND_RWDATA,
4998                 (void*) (image + sections[i].offset),
4999                 (void*) (image + sections[i].offset + sections[i].size));
5000         else if(!strcmp(sections[i].sectname,"__data"))
5001             addSection(oc, SECTIONKIND_RWDATA,
5002                 (void*) (image + sections[i].offset),
5003                 (void*) (image + sections[i].offset + sections[i].size));
5004         else if(!strcmp(sections[i].sectname,"__bss")
5005                 || !strcmp(sections[i].sectname,"__common"))
5006             addSection(oc, SECTIONKIND_RWDATA,
5007                 (void*) (image + sections[i].offset),
5008                 (void*) (image + sections[i].offset + sections[i].size));
5009
5010         addProddableBlock(oc, (void*) (image + sections[i].offset),
5011                                         sections[i].size);
5012     }
5013
5014         // count external symbols defined here
5015     oc->n_symbols = 0;
5016     if(symLC)
5017     {
5018         for(i=0;i<symLC->nsyms;i++)
5019         {
5020             if(nlist[i].n_type & N_STAB)
5021                 ;
5022             else if(nlist[i].n_type & N_EXT)
5023             {
5024                 if((nlist[i].n_type & N_TYPE) == N_UNDF
5025                     && (nlist[i].n_value != 0))
5026                 {
5027                     commonSize += nlist[i].n_value;
5028                     oc->n_symbols++;
5029                 }
5030                 else if((nlist[i].n_type & N_TYPE) == N_SECT)
5031                     oc->n_symbols++;
5032             }
5033         }
5034     }
5035     IF_DEBUG(linker, debugBelch("ocGetNames_MachO: %d external symbols\n", oc->n_symbols));
5036     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
5037                                    "ocGetNames_MachO(oc->symbols)");
5038
5039     if(symLC)
5040     {
5041         for(i=0;i<symLC->nsyms;i++)
5042         {
5043             if(nlist[i].n_type & N_STAB)
5044                 ;
5045             else if((nlist[i].n_type & N_TYPE) == N_SECT)
5046             {
5047                 if(nlist[i].n_type & N_EXT)
5048                 {
5049                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
5050                     if ((nlist[i].n_desc & N_WEAK_DEF) && lookupSymbol(nm)) {
5051                         // weak definition, and we already have a definition
5052                         IF_DEBUG(linker, debugBelch("    weak: %s\n", nm));
5053                     }
5054                     else
5055                     {
5056                             IF_DEBUG(linker, debugBelch("ocGetNames_MachO: inserting %s\n", nm));
5057                             ghciInsertStrHashTable(oc->fileName, symhash, nm,
5058                                                     image
5059                                                     + sections[nlist[i].n_sect-1].offset
5060                                                     - sections[nlist[i].n_sect-1].addr
5061                                                     + nlist[i].n_value);
5062                             oc->symbols[curSymbol++] = nm;
5063                     }
5064                 }
5065             }
5066         }
5067     }
5068
5069     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
5070     commonCounter = (unsigned long)commonStorage;
5071     if(symLC)
5072     {
5073         for(i=0;i<symLC->nsyms;i++)
5074         {
5075             if((nlist[i].n_type & N_TYPE) == N_UNDF
5076                     && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
5077             {
5078                 char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
5079                 unsigned long sz = nlist[i].n_value;
5080
5081                 nlist[i].n_value = commonCounter;
5082
5083                 IF_DEBUG(linker, debugBelch("ocGetNames_MachO: inserting common symbol: %s\n", nm));
5084                 ghciInsertStrHashTable(oc->fileName, symhash, nm,
5085                                        (void*)commonCounter);
5086                 oc->symbols[curSymbol++] = nm;
5087
5088                 commonCounter += sz;
5089             }
5090         }
5091     }
5092     return 1;
5093 }
5094
5095 static int ocResolve_MachO(ObjectCode* oc)
5096 {
5097     char *image = (char*) oc->image;
5098     struct mach_header *header = (struct mach_header*) image;
5099     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
5100     unsigned i;
5101     struct segment_command *segLC = NULL;
5102     struct section *sections;
5103     struct symtab_command *symLC = NULL;
5104     struct dysymtab_command *dsymLC = NULL;
5105     struct nlist *nlist;
5106
5107     IF_DEBUG(linker, debugBelch("ocResolve_MachO: start\n"));
5108     for (i = 0; i < header->ncmds; i++)
5109     {
5110         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
5111             segLC = (struct segment_command*) lc;
5112         else if(lc->cmd == LC_SYMTAB)
5113             symLC = (struct symtab_command*) lc;
5114         else if(lc->cmd == LC_DYSYMTAB)
5115             dsymLC = (struct dysymtab_command*) lc;
5116         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
5117     }
5118
5119     sections = (struct section*) (segLC+1);
5120     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
5121                   : NULL;
5122
5123     if(dsymLC)
5124     {
5125         unsigned long *indirectSyms
5126             = (unsigned long*) (image + dsymLC->indirectsymoff);
5127
5128         IF_DEBUG(linker, debugBelch("ocResolve_MachO: resolving dsymLC\n"));
5129         for (i = 0; i < segLC->nsects; i++)
5130         {
5131             if(    !strcmp(sections[i].sectname,"__la_symbol_ptr")
5132                 || !strcmp(sections[i].sectname,"__la_sym_ptr2")
5133                 || !strcmp(sections[i].sectname,"__la_sym_ptr3"))
5134             {
5135                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
5136                     return 0;
5137             }
5138             else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr")
5139                 ||  !strcmp(sections[i].sectname,"__pointers"))
5140             {
5141                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
5142                     return 0;
5143             }
5144             else if(!strcmp(sections[i].sectname,"__jump_table"))
5145             {
5146                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
5147                     return 0;
5148             }
5149             else
5150             {
5151                 IF_DEBUG(linker, debugBelch("ocResolve_MachO: unknown section\n"));
5152             }
5153         }
5154     }
5155
5156     for(i=0;i<segLC->nsects;i++)
5157     {
5158             IF_DEBUG(linker, debugBelch("ocResolve_MachO: relocating section %d\n", i));
5159
5160         if (!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
5161             return 0;
5162     }
5163
5164 #if defined (powerpc_HOST_ARCH)
5165     ocFlushInstructionCache( oc );
5166 #endif
5167
5168     return 1;
5169 }
5170
5171 #ifdef powerpc_HOST_ARCH
5172 /*
5173  * The Mach-O object format uses leading underscores. But not everywhere.
5174  * There is a small number of runtime support functions defined in
5175  * libcc_dynamic.a whose name does not have a leading underscore.
5176  * As a consequence, we can't get their address from C code.
5177  * We have to use inline assembler just to take the address of a function.
5178  * Yuck.
5179  */
5180
5181 extern void* symbolsWithoutUnderscore[];
5182
5183 static void machoInitSymbolsWithoutUnderscore()
5184 {
5185     void **p = symbolsWithoutUnderscore;
5186     __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:");
5187
5188 #undef SymI_NeedsProto
5189 #define SymI_NeedsProto(x)  \
5190     __asm__ volatile(".long " # x);
5191
5192     RTS_MACHO_NOUNDERLINE_SYMBOLS
5193
5194     __asm__ volatile(".text");
5195
5196 #undef SymI_NeedsProto
5197 #define SymI_NeedsProto(x)  \
5198     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
5199
5200     RTS_MACHO_NOUNDERLINE_SYMBOLS
5201
5202 #undef SymI_NeedsProto
5203 }
5204 #endif
5205
5206 #ifndef USE_MMAP
5207 /*
5208  * Figure out by how much to shift the entire Mach-O file in memory
5209  * when loading so that its single segment ends up 16-byte-aligned
5210  */
5211 static int machoGetMisalignment( FILE * f )
5212 {
5213     struct mach_header header;
5214     int misalignment;
5215
5216     fread(&header, sizeof(header), 1, f);
5217     rewind(f);
5218
5219 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
5220     if(header.magic != MH_MAGIC_64) {
5221         errorBelch("Bad magic. Expected: %08x, got: %08x.\n",
5222                    MH_MAGIC_64, header->magic);
5223         return 0;
5224     }
5225 #else
5226     if(header.magic != MH_MAGIC) {
5227         errorBelch("Bad magic. Expected: %08x, got: %08x.\n",
5228                    MH_MAGIC, header->magic);
5229         return 0;
5230     }
5231 #endif
5232
5233     misalignment = (header.sizeofcmds + sizeof(header))
5234                     & 0xF;
5235
5236     return misalignment ? (16 - misalignment) : 0;
5237 }
5238 #endif
5239
5240 #endif