rts/Linker.c

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