rts/Linker.c

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