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