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