rts/Linker.c

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