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