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