rts/Linker.c

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