rts/Linker.c

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