rts/Linker.c

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