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    IF_DEBUG(linker, debugBelch("loadArchive `%s'\n", path));
1673
1674    fileSize = 32;
1675    file = stgMallocBytes(fileSize, "loadArchive(file)");
1676
1677    f = fopen(path, "rb");
1678    if (!f)
1679        barf("loadObj: can't read `%s'", path);
1680
1681    n = fread ( tmp, 1, 8, f );
1682    if (strncmp(tmp, "!<arch>\n", 8) != 0)
1683        barf("loadArchive: Not an archive: `%s'", path);
1684
1685    while(1) {
1686        n = fread ( file, 1, 16, f );
1687        if (n != 16) {
1688            if (feof(f)) {
1689                break;
1690            }
1691            else {
1692                barf("loadArchive: Failed reading file name from `%s'", path);
1693            }
1694        }
1695        n = fread ( tmp, 1, 12, f );
1696        if (n != 12)
1697            barf("loadArchive: Failed reading mod time from `%s'", path);
1698        n = fread ( tmp, 1, 6, f );
1699        if (n != 6)
1700            barf("loadArchive: Failed reading owner from `%s'", path);
1701        n = fread ( tmp, 1, 6, f );
1702        if (n != 6)
1703            barf("loadArchive: Failed reading group from `%s'", path);
1704        n = fread ( tmp, 1, 8, f );
1705        if (n != 8)
1706            barf("loadArchive: Failed reading mode from `%s'", path);
1707        n = fread ( tmp, 1, 10, f );
1708        if (n != 10)
1709            barf("loadArchive: Failed reading size from `%s'", path);
1710        tmp[10] = '\0';
1711        for (n = 0; isdigit(tmp[n]); n++);
1712        tmp[n] = '\0';
1713        imageSize = atoi(tmp);
1714        n = fread ( tmp, 1, 2, f );
1715        if (strncmp(tmp, "\x60\x0A", 2) != 0)
1716            barf("loadArchive: Failed reading magic from `%s' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]);
1717
1718        /* Check for BSD-variant large filenames */
1719        if (0 == strncmp(file, "#1/", 3)) {
1720            file[16] = '\0';
1721            for (n = 3; isdigit(file[n]); n++);
1722            file[n] = '\0';
1723            fileNameSize = atoi(file + 3);
1724            imageSize -= fileNameSize;
1725            if (fileNameSize > fileSize) {
1726                /* Double it to avoid potentially continually
1727                   increasing it by 1 */
1728                fileSize = fileNameSize * 2;
1729                file = stgReallocBytes(file, fileSize, "loadArchive(file)");
1730            }
1731            n = fread ( file, 1, fileNameSize, f );
1732            if (n != (int)fileNameSize)
1733                barf("loadArchive: Failed reading filename from `%s'", path);
1734        }
1735        else {
1736            fileNameSize = 16;
1737        }
1738
1739        isObject = 0;
1740        for (n = 0; n < (int)fileNameSize - 1; n++) {
1741            if ((file[n] == '.') && (file[n] == 'o')) {
1742                isObject = 1;
1743                break;
1744            }
1745        }
1746
1747        if (isObject) {
1748            /* We can't mmap from the archive directly, as object
1749               files need to be 8-byte aligned but files in .ar
1750               archives are 2-byte aligned, and if we malloc the
1751               memory then we can be given memory above 2^32, so we
1752               mmap some anonymous memory and use that. We could
1753               do better here. */
1754            image = mmapForLinker(imageSize, MAP_ANONYMOUS, -1);
1755            n = fread ( image, 1, imageSize, f );
1756            if (n != imageSize)
1757                barf("loadObj: error whilst reading `%s'", path);
1758            oc = mkOc(path, image, imageSize
1759 #ifndef USE_MMAP
1760 #ifdef darwin_HOST_OS
1761                     , 0
1762 #endif
1763 #endif
1764                     );
1765            if (0 == loadOc(oc)) {
1766                stgFree(file);
1767                return 0;
1768            }
1769        }
1770        else {
1771            n = fseek(f, imageSize, SEEK_CUR);
1772            if (n != 0)
1773                barf("loadArchive: error whilst seeking by %d in `%s'",
1774                     imageSize, path);
1775        }
1776        /* .ar files are 2-byte aligned */
1777        if (imageSize % 2) {
1778            n = fread ( tmp, 1, 1, f );
1779            if (n != 1) {
1780                if (feof(f)) {
1781                    break;
1782                }
1783                else {
1784                    barf("loadArchive: Failed reading padding from `%s'", path);
1785                }
1786            }
1787        }
1788    }
1789
1790    fclose(f);
1791
1792    stgFree(file);
1793    return 1;
1794 }
1795 #else
1796 HsInt GNU_ATTRIBUTE(__noreturn__)
1797 loadArchive( char *path STG_UNUSED ) {
1798     barf("loadArchive: not enabled");
1799 }
1800 #endif
1801
1802 /* -----------------------------------------------------------------------------
1803  * Load an obj (populate the global symbol table, but don't resolve yet)
1804  *
1805  * Returns: 1 if ok, 0 on error.
1806  */
1807 HsInt
1808 loadObj( char *path )
1809 {
1810    ObjectCode* oc;
1811    char *image;
1812    int fileSize;
1813    struct stat st;
1814    int r;
1815 #ifdef USE_MMAP
1816    int fd;
1817 #else
1818    FILE *f;
1819 #endif
1820    IF_DEBUG(linker, debugBelch("loadObj %s\n", path));
1821
1822    initLinker();
1823
1824    /* debugBelch("loadObj %s\n", path ); */
1825
1826    /* Check that we haven't already loaded this object.
1827       Ignore requests to load multiple times */
1828    {
1829        ObjectCode *o;
1830        int is_dup = 0;
1831        for (o = objects; o; o = o->next) {
1832           if (0 == strcmp(o->fileName, path)) {
1833              is_dup = 1;
1834              break; /* don't need to search further */
1835           }
1836        }
1837        if (is_dup) {
1838           IF_DEBUG(linker, debugBelch(
1839             "GHCi runtime linker: warning: looks like you're trying to load the\n"
1840             "same object file twice:\n"
1841             "   %s\n"
1842             "GHCi will ignore this, but be warned.\n"
1843             , path));
1844           return 1; /* success */
1845        }
1846    }
1847
1848    r = stat(path, &st);
1849    if (r == -1) {
1850        IF_DEBUG(linker, debugBelch("File doesn't exist\n"));
1851        return 0;
1852    }
1853
1854    fileSize = st.st_size;
1855
1856 #ifdef USE_MMAP
1857    /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
1858
1859 #if defined(openbsd_HOST_OS)
1860    fd = open(path, O_RDONLY, S_IRUSR);
1861 #else
1862    fd = open(path, O_RDONLY);
1863 #endif
1864    if (fd == -1)
1865       barf("loadObj: can't open `%s'", path);
1866
1867    image = mmapForLinker(fileSize, 0, fd);
1868
1869    close(fd);
1870
1871 #else /* !USE_MMAP */
1872    /* load the image into memory */
1873    f = fopen(path, "rb");
1874    if (!f)
1875        barf("loadObj: can't read `%s'", path);
1876
1877 #   if defined(mingw32_HOST_OS)
1878         // TODO: We would like to use allocateExec here, but allocateExec
1879         //       cannot currently allocate blocks large enough.
1880     image = VirtualAlloc(NULL, fileSize, MEM_RESERVE | MEM_COMMIT,
1881                              PAGE_EXECUTE_READWRITE);
1882 #   elif defined(darwin_HOST_OS)
1883     // In a Mach-O .o file, all sections can and will be misaligned
1884     // if the total size of the headers is not a multiple of the
1885     // desired alignment. This is fine for .o files that only serve
1886     // as input for the static linker, but it's not fine for us,
1887     // as SSE (used by gcc for floating point) and Altivec require
1888     // 16-byte alignment.
1889     // We calculate the correct alignment from the header before
1890     // reading the file, and then we misalign image on purpose so
1891     // that the actual sections end up aligned again.
1892    misalignment = machoGetMisalignment(f);
1893    image = stgMallocBytes(fileSize + misalignment, "loadObj(image)");
1894    image += misalignment;
1895 #  else
1896    image = stgMallocBytes(fileSize, "loadObj(image)");
1897 #  endif
1898
1899    {
1900        int n;
1901        n = fread ( image, 1, fileSize, f );
1902        if (n != fileSize)
1903            barf("loadObj: error whilst reading `%s'", path);
1904    }
1905    fclose(f);
1906 #endif /* USE_MMAP */
1907
1908    oc = mkOc(path, image, fileSize
1909 #ifndef USE_MMAP
1910 #ifdef darwin_HOST_OS
1911             , misalignment
1912 #endif
1913 #endif
1914             );
1915
1916    return loadOc(oc);
1917 }
1918
1919 static HsInt
1920 loadOc( ObjectCode* oc ) {
1921    int r;
1922
1923    IF_DEBUG(linker, debugBelch("loadOc\n"));
1924
1925 #  if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1926    r = ocAllocateSymbolExtras_MachO ( oc );
1927    if (!r) {
1928        IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO failed\n"));
1929        return r;
1930    }
1931 #  elif defined(OBJFORMAT_ELF) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1932    r = ocAllocateSymbolExtras_ELF ( oc );
1933    if (!r) {
1934        IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_ELF failed\n"));
1935        return r;
1936    }
1937 #endif
1938
1939    /* verify the in-memory image */
1940 #  if defined(OBJFORMAT_ELF)
1941    r = ocVerifyImage_ELF ( oc );
1942 #  elif defined(OBJFORMAT_PEi386)
1943    r = ocVerifyImage_PEi386 ( oc );
1944 #  elif defined(OBJFORMAT_MACHO)
1945    r = ocVerifyImage_MachO ( oc );
1946 #  else
1947    barf("loadObj: no verify method");
1948 #  endif
1949    if (!r) {
1950        IF_DEBUG(linker, debugBelch("ocVerifyImage_* failed\n"));
1951        return r;
1952    }
1953
1954    /* build the symbol list for this image */
1955 #  if defined(OBJFORMAT_ELF)
1956    r = ocGetNames_ELF ( oc );
1957 #  elif defined(OBJFORMAT_PEi386)
1958    r = ocGetNames_PEi386 ( oc );
1959 #  elif defined(OBJFORMAT_MACHO)
1960    r = ocGetNames_MachO ( oc );
1961 #  else
1962    barf("loadObj: no getNames method");
1963 #  endif
1964    if (!r) {
1965        IF_DEBUG(linker, debugBelch("ocGetNames_* failed\n"));
1966        return r;
1967    }
1968
1969    /* loaded, but not resolved yet */
1970    oc->status = OBJECT_LOADED;
1971
1972    return 1;
1973 }
1974
1975 /* -----------------------------------------------------------------------------
1976  * resolve all the currently unlinked objects in memory
1977  *
1978  * Returns: 1 if ok, 0 on error.
1979  */
1980 HsInt
1981 resolveObjs( void )
1982 {
1983     ObjectCode *oc;
1984     int r;
1985
1986     initLinker();
1987
1988     for (oc = objects; oc; oc = oc->next) {
1989         if (oc->status != OBJECT_RESOLVED) {
1990 #           if defined(OBJFORMAT_ELF)
1991             r = ocResolve_ELF ( oc );
1992 #           elif defined(OBJFORMAT_PEi386)
1993             r = ocResolve_PEi386 ( oc );
1994 #           elif defined(OBJFORMAT_MACHO)
1995             r = ocResolve_MachO ( oc );
1996 #           else
1997             barf("resolveObjs: not implemented on this platform");
1998 #           endif
1999             if (!r) { return r; }
2000             oc->status = OBJECT_RESOLVED;
2001         }
2002     }
2003     return 1;
2004 }
2005
2006 /* -----------------------------------------------------------------------------
2007  * delete an object from the pool
2008  */
2009 HsInt
2010 unloadObj( char *path )
2011 {
2012     ObjectCode *oc, *prev;
2013
2014     ASSERT(symhash != NULL);
2015     ASSERT(objects != NULL);
2016
2017     initLinker();
2018
2019     prev = NULL;
2020     for (oc = objects; oc; prev = oc, oc = oc->next) {
2021         if (!strcmp(oc->fileName,path)) {
2022
2023             /* Remove all the mappings for the symbols within this
2024              * object..
2025              */
2026             {
2027                 int i;
2028                 for (i = 0; i < oc->n_symbols; i++) {
2029                    if (oc->symbols[i] != NULL) {
2030                        removeStrHashTable(symhash, oc->symbols[i], NULL);
2031                    }
2032                 }
2033             }
2034
2035             if (prev == NULL) {
2036                 objects = oc->next;
2037             } else {
2038                 prev->next = oc->next;
2039             }
2040
2041             // We're going to leave this in place, in case there are
2042             // any pointers from the heap into it:
2043                 // #ifdef mingw32_HOST_OS
2044                 //  VirtualFree(oc->image);
2045                 // #else
2046             //  stgFree(oc->image);
2047             // #endif
2048             stgFree(oc->fileName);
2049             stgFree(oc->symbols);
2050             stgFree(oc->sections);
2051             stgFree(oc);
2052             return 1;
2053         }
2054     }
2055
2056     errorBelch("unloadObj: can't find `%s' to unload", path);
2057     return 0;
2058 }
2059
2060 /* -----------------------------------------------------------------------------
2061  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
2062  * which may be prodded during relocation, and abort if we try and write
2063  * outside any of these.
2064  */
2065 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
2066 {
2067    ProddableBlock* pb
2068       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
2069    /* debugBelch("aPB %p %p %d\n", oc, start, size); */
2070    ASSERT(size > 0);
2071    pb->start      = start;
2072    pb->size       = size;
2073    pb->next       = oc->proddables;
2074    oc->proddables = pb;
2075 }
2076
2077 static void checkProddableBlock ( ObjectCode* oc, void* addr )
2078 {
2079    ProddableBlock* pb;
2080    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
2081       char* s = (char*)(pb->start);
2082       char* e = s + pb->size - 1;
2083       char* a = (char*)addr;
2084       /* Assumes that the biggest fixup involves a 4-byte write.  This
2085          probably needs to be changed to 8 (ie, +7) on 64-bit
2086          plats. */
2087       if (a >= s && (a+3) <= e) return;
2088    }
2089    barf("checkProddableBlock: invalid fixup in runtime linker");
2090 }
2091
2092 /* -----------------------------------------------------------------------------
2093  * Section management.
2094  */
2095 static void addSection ( ObjectCode* oc, SectionKind kind,
2096                          void* start, void* end )
2097 {
2098    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
2099    s->start     = start;
2100    s->end       = end;
2101    s->kind      = kind;
2102    s->next      = oc->sections;
2103    oc->sections = s;
2104    /*
2105    debugBelch("addSection: %p-%p (size %d), kind %d\n",
2106                    start, ((char*)end)-1, end - start + 1, kind );
2107    */
2108 }
2109
2110
2111 /* --------------------------------------------------------------------------
2112  * Symbol Extras.
2113  * This is about allocating a small chunk of memory for every symbol in the
2114  * object file. We make sure that the SymboLExtras are always "in range" of
2115  * limited-range PC-relative instructions on various platforms by allocating
2116  * them right next to the object code itself.
2117  */
2118
2119 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
2120
2121 /*
2122   ocAllocateSymbolExtras
2123
2124   Allocate additional space at the end of the object file image to make room
2125   for jump islands (powerpc, x86_64) and GOT entries (x86_64).
2126
2127   PowerPC relative branch instructions have a 24 bit displacement field.
2128   As PPC code is always 4-byte-aligned, this yields a +-32MB range.
2129   If a particular imported symbol is outside this range, we have to redirect
2130   the jump to a short piece of new code that just loads the 32bit absolute
2131   address and jumps there.
2132   On x86_64, PC-relative jumps and PC-relative accesses to the GOT are limited
2133   to 32 bits (+-2GB).
2134
2135   This function just allocates space for one SymbolExtra for every
2136   undefined symbol in the object file. The code for the jump islands is
2137   filled in by makeSymbolExtra below.
2138 */
2139
2140 static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first )
2141 {
2142 #ifdef USE_MMAP
2143   int pagesize, n, m;
2144 #endif
2145   int aligned;
2146 #ifndef USE_MMAP
2147   int misalignment = 0;
2148 #ifdef darwin_HOST_OS
2149   misalignment = oc->misalignment;
2150 #endif
2151 #endif
2152
2153   if( count > 0 )
2154   {
2155     // round up to the nearest 4
2156     aligned = (oc->fileSize + 3) & ~3;
2157
2158 #ifdef USE_MMAP
2159     pagesize = getpagesize();
2160     n = ROUND_UP( oc->fileSize, pagesize );
2161     m = ROUND_UP( aligned + sizeof (SymbolExtra) * count, pagesize );
2162
2163     /* we try to use spare space at the end of the last page of the
2164      * image for the jump islands, but if there isn't enough space
2165      * then we have to map some (anonymously, remembering MAP_32BIT).
2166      */
2167     if( m > n ) // we need to allocate more pages
2168     {
2169         oc->symbol_extras = mmapForLinker(sizeof(SymbolExtra) * count,
2170                                           MAP_ANONYMOUS, -1);
2171     }
2172     else
2173     {
2174         oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
2175     }
2176 #else
2177     oc->image -= misalignment;
2178     oc->image = stgReallocBytes( oc->image,
2179                                  misalignment +
2180                                  aligned + sizeof (SymbolExtra) * count,
2181                                  "ocAllocateSymbolExtras" );
2182     oc->image += misalignment;
2183
2184     oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
2185 #endif /* USE_MMAP */
2186
2187     memset( oc->symbol_extras, 0, sizeof (SymbolExtra) * count );
2188   }
2189   else
2190     oc->symbol_extras = NULL;
2191
2192   oc->first_symbol_extra = first;
2193   oc->n_symbol_extras = count;
2194
2195   return 1;
2196 }
2197
2198 static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
2199                                      unsigned long symbolNumber,
2200                                      unsigned long target )
2201 {
2202   SymbolExtra *extra;
2203
2204   ASSERT( symbolNumber >= oc->first_symbol_extra
2205         && symbolNumber - oc->first_symbol_extra < oc->n_symbol_extras);
2206
2207   extra = &oc->symbol_extras[symbolNumber - oc->first_symbol_extra];
2208
2209 #ifdef powerpc_HOST_ARCH
2210   // lis r12, hi16(target)
2211   extra->jumpIsland.lis_r12     = 0x3d80;
2212   extra->jumpIsland.hi_addr     = target >> 16;
2213
2214   // ori r12, r12, lo16(target)
2215   extra->jumpIsland.ori_r12_r12 = 0x618c;
2216   extra->jumpIsland.lo_addr     = target & 0xffff;
2217
2218   // mtctr r12
2219   extra->jumpIsland.mtctr_r12   = 0x7d8903a6;
2220
2221   // bctr
2222   extra->jumpIsland.bctr        = 0x4e800420;
2223 #endif
2224 #ifdef x86_64_HOST_ARCH
2225         // jmp *-14(%rip)
2226   static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
2227   extra->addr = target;
2228   memcpy(extra->jumpIsland, jmp, 6);
2229 #endif
2230
2231   return extra;
2232 }
2233
2234 #endif
2235
2236 /* --------------------------------------------------------------------------
2237  * PowerPC specifics (instruction cache flushing)
2238  * ------------------------------------------------------------------------*/
2239
2240 #ifdef powerpc_HOST_ARCH
2241 /*
2242    ocFlushInstructionCache
2243
2244    Flush the data & instruction caches.
2245    Because the PPC has split data/instruction caches, we have to
2246    do that whenever we modify code at runtime.
2247  */
2248
2249 static void ocFlushInstructionCache( ObjectCode *oc )
2250 {
2251     int n = (oc->fileSize + sizeof( SymbolExtra ) * oc->n_symbol_extras + 3) / 4;
2252     unsigned long *p = (unsigned long *) oc->image;
2253
2254     while( n-- )
2255     {
2256         __asm__ volatile ( "dcbf 0,%0\n\t"
2257                            "sync\n\t"
2258                            "icbi 0,%0"
2259                            :
2260                            : "r" (p)
2261                          );
2262         p++;
2263     }
2264     __asm__ volatile ( "sync\n\t"
2265                        "isync"
2266                      );
2267 }
2268 #endif
2269
2270 /* --------------------------------------------------------------------------
2271  * PEi386 specifics (Win32 targets)
2272  * ------------------------------------------------------------------------*/
2273
2274 /* The information for this linker comes from
2275       Microsoft Portable Executable
2276       and Common Object File Format Specification
2277       revision 5.1 January 1998
2278    which SimonM says comes from the MS Developer Network CDs.
2279
2280    It can be found there (on older CDs), but can also be found
2281    online at:
2282
2283       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
2284
2285    (this is Rev 6.0 from February 1999).
2286
2287    Things move, so if that fails, try searching for it via
2288
2289       http://www.google.com/search?q=PE+COFF+specification
2290
2291    The ultimate reference for the PE format is the Winnt.h
2292    header file that comes with the Platform SDKs; as always,
2293    implementations will drift wrt their documentation.
2294
2295    A good background article on the PE format is Matt Pietrek's
2296    March 1994 article in Microsoft System Journal (MSJ)
2297    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
2298    Win32 Portable Executable File Format." The info in there
2299    has recently been updated in a two part article in
2300    MSDN magazine, issues Feb and March 2002,
2301    "Inside Windows: An In-Depth Look into the Win32 Portable
2302    Executable File Format"
2303
2304    John Levine's book "Linkers and Loaders" contains useful
2305    info on PE too.
2306 */
2307
2308
2309 #if defined(OBJFORMAT_PEi386)
2310
2311
2312
2313 typedef unsigned char  UChar;
2314 typedef unsigned short UInt16;
2315 typedef unsigned int   UInt32;
2316 typedef          int   Int32;
2317
2318
2319 typedef
2320    struct {
2321       UInt16 Machine;
2322       UInt16 NumberOfSections;
2323       UInt32 TimeDateStamp;
2324       UInt32 PointerToSymbolTable;
2325       UInt32 NumberOfSymbols;
2326       UInt16 SizeOfOptionalHeader;
2327       UInt16 Characteristics;
2328    }
2329    COFF_header;
2330
2331 #define sizeof_COFF_header 20
2332
2333
2334 typedef
2335    struct {
2336       UChar  Name[8];
2337       UInt32 VirtualSize;
2338       UInt32 VirtualAddress;
2339       UInt32 SizeOfRawData;
2340       UInt32 PointerToRawData;
2341       UInt32 PointerToRelocations;
2342       UInt32 PointerToLinenumbers;
2343       UInt16 NumberOfRelocations;
2344       UInt16 NumberOfLineNumbers;
2345       UInt32 Characteristics;
2346    }
2347    COFF_section;
2348
2349 #define sizeof_COFF_section 40
2350
2351
2352 typedef
2353    struct {
2354       UChar  Name[8];
2355       UInt32 Value;
2356       UInt16 SectionNumber;
2357       UInt16 Type;
2358       UChar  StorageClass;
2359       UChar  NumberOfAuxSymbols;
2360    }
2361    COFF_symbol;
2362
2363 #define sizeof_COFF_symbol 18
2364
2365
2366 typedef
2367    struct {
2368       UInt32 VirtualAddress;
2369       UInt32 SymbolTableIndex;
2370       UInt16 Type;
2371    }
2372    COFF_reloc;
2373
2374 #define sizeof_COFF_reloc 10
2375
2376
2377 /* From PE spec doc, section 3.3.2 */
2378 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
2379    windows.h -- for the same purpose, but I want to know what I'm
2380    getting, here. */
2381 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
2382 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
2383 #define MYIMAGE_FILE_DLL                 0x2000
2384 #define MYIMAGE_FILE_SYSTEM              0x1000
2385 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
2386 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
2387 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
2388
2389 /* From PE spec doc, section 5.4.2 and 5.4.4 */
2390 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
2391 #define MYIMAGE_SYM_CLASS_STATIC         3
2392 #define MYIMAGE_SYM_UNDEFINED            0
2393
2394 /* From PE spec doc, section 4.1 */
2395 #define MYIMAGE_SCN_CNT_CODE             0x00000020
2396 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
2397 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
2398
2399 /* From PE spec doc, section 5.2.1 */
2400 #define MYIMAGE_REL_I386_DIR32           0x0006
2401 #define MYIMAGE_REL_I386_REL32           0x0014
2402
2403
2404 /* We use myindex to calculate array addresses, rather than
2405    simply doing the normal subscript thing.  That's because
2406    some of the above structs have sizes which are not
2407    a whole number of words.  GCC rounds their sizes up to a
2408    whole number of words, which means that the address calcs
2409    arising from using normal C indexing or pointer arithmetic
2410    are just plain wrong.  Sigh.
2411 */
2412 static UChar *
2413 myindex ( int scale, void* base, int index )
2414 {
2415    return
2416       ((UChar*)base) + scale * index;
2417 }
2418
2419
2420 static void
2421 printName ( UChar* name, UChar* strtab )
2422 {
2423    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2424       UInt32 strtab_offset = * (UInt32*)(name+4);
2425       debugBelch("%s", strtab + strtab_offset );
2426    } else {
2427       int i;
2428       for (i = 0; i < 8; i++) {
2429          if (name[i] == 0) break;
2430          debugBelch("%c", name[i] );
2431       }
2432    }
2433 }
2434
2435
2436 static void
2437 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
2438 {
2439    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2440       UInt32 strtab_offset = * (UInt32*)(name+4);
2441       strncpy ( (char*)dst, (char*)strtab+strtab_offset, dstSize );
2442       dst[dstSize-1] = 0;
2443    } else {
2444       int i = 0;
2445       while (1) {
2446          if (i >= 8) break;
2447          if (name[i] == 0) break;
2448          dst[i] = name[i];
2449          i++;
2450       }
2451       dst[i] = 0;
2452    }
2453 }
2454
2455
2456 static UChar *
2457 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
2458 {
2459    UChar* newstr;
2460    /* If the string is longer than 8 bytes, look in the
2461       string table for it -- this will be correctly zero terminated.
2462    */
2463    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
2464       UInt32 strtab_offset = * (UInt32*)(name+4);
2465       return ((UChar*)strtab) + strtab_offset;
2466    }
2467    /* Otherwise, if shorter than 8 bytes, return the original,
2468       which by defn is correctly terminated.
2469    */
2470    if (name[7]==0) return name;
2471    /* The annoying case: 8 bytes.  Copy into a temporary
2472       (XXX which is never freed ...)
2473    */
2474    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
2475    ASSERT(newstr);
2476    strncpy((char*)newstr,(char*)name,8);
2477    newstr[8] = 0;
2478    return newstr;
2479 }
2480
2481 /* Getting the name of a section is mildly tricky, so we make a
2482    function for it.  Sadly, in one case we have to copy the string
2483    (when it is exactly 8 bytes long there's no trailing '\0'), so for
2484    consistency we *always* copy the string; the caller must free it
2485 */
2486 static char *
2487 cstring_from_section_name (UChar* name, UChar* strtab)
2488 {
2489     char *newstr;
2490
2491     if (name[0]=='/') {
2492         int strtab_offset = strtol((char*)name+1,NULL,10);
2493         int len = strlen(((char*)strtab) + strtab_offset);
2494
2495         newstr = stgMallocBytes(len, "cstring_from_section_symbol_name");
2496         strcpy((char*)newstr, (char*)((UChar*)strtab) + strtab_offset);
2497         return newstr;
2498     }
2499     else
2500     {
2501         newstr = stgMallocBytes(9, "cstring_from_section_symbol_name");
2502         ASSERT(newstr);
2503         strncpy((char*)newstr,(char*)name,8);
2504         newstr[8] = 0;
2505         return newstr;
2506     }
2507 }
2508
2509 /* Just compares the short names (first 8 chars) */
2510 static COFF_section *
2511 findPEi386SectionCalled ( ObjectCode* oc,  UChar* name )
2512 {
2513    int i;
2514    COFF_header* hdr
2515       = (COFF_header*)(oc->image);
2516    COFF_section* sectab
2517       = (COFF_section*) (
2518            ((UChar*)(oc->image))
2519            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2520         );
2521    for (i = 0; i < hdr->NumberOfSections; i++) {
2522       UChar* n1;
2523       UChar* n2;
2524       COFF_section* section_i
2525          = (COFF_section*)
2526            myindex ( sizeof_COFF_section, sectab, i );
2527       n1 = (UChar*) &(section_i->Name);
2528       n2 = name;
2529       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
2530           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
2531           n1[6]==n2[6] && n1[7]==n2[7])
2532          return section_i;
2533    }
2534
2535    return NULL;
2536 }
2537
2538
2539 static void
2540 zapTrailingAtSign ( UChar* sym )
2541 {
2542 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
2543    int i, j;
2544    if (sym[0] == 0) return;
2545    i = 0;
2546    while (sym[i] != 0) i++;
2547    i--;
2548    j = i;
2549    while (j > 0 && my_isdigit(sym[j])) j--;
2550    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
2551 #  undef my_isdigit
2552 }
2553
2554 static void *
2555 lookupSymbolInDLLs ( UChar *lbl )
2556 {
2557     OpenedDLL* o_dll;
2558     void *sym;
2559
2560     for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
2561         /* debugBelch("look in %s for %s\n", o_dll->name, lbl); */
2562
2563         if (lbl[0] == '_') {
2564             /* HACK: if the name has an initial underscore, try stripping
2565                it off & look that up first. I've yet to verify whether there's
2566                a Rule that governs whether an initial '_' *should always* be
2567                stripped off when mapping from import lib name to the DLL name.
2568             */
2569             sym = GetProcAddress(o_dll->instance, (char*)(lbl+1));
2570             if (sym != NULL) {
2571                 /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
2572                 return sym;
2573             }
2574         }
2575         sym = GetProcAddress(o_dll->instance, (char*)lbl);
2576         if (sym != NULL) {
2577             /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
2578             return sym;
2579            }
2580     }
2581     return NULL;
2582 }
2583
2584
2585 static int
2586 ocVerifyImage_PEi386 ( ObjectCode* oc )
2587 {
2588    int i;
2589    UInt32 j, noRelocs;
2590    COFF_header*  hdr;
2591    COFF_section* sectab;
2592    COFF_symbol*  symtab;
2593    UChar*        strtab;
2594    /* debugBelch("\nLOADING %s\n", oc->fileName); */
2595    hdr = (COFF_header*)(oc->image);
2596    sectab = (COFF_section*) (
2597                ((UChar*)(oc->image))
2598                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2599             );
2600    symtab = (COFF_symbol*) (
2601                ((UChar*)(oc->image))
2602                + hdr->PointerToSymbolTable
2603             );
2604    strtab = ((UChar*)symtab)
2605             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2606
2607    if (hdr->Machine != 0x14c) {
2608       errorBelch("%s: Not x86 PEi386", oc->fileName);
2609       return 0;
2610    }
2611    if (hdr->SizeOfOptionalHeader != 0) {
2612       errorBelch("%s: PEi386 with nonempty optional header", oc->fileName);
2613       return 0;
2614    }
2615    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
2616         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
2617         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
2618         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
2619       errorBelch("%s: Not a PEi386 object file", oc->fileName);
2620       return 0;
2621    }
2622    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
2623         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
2624       errorBelch("%s: Invalid PEi386 word size or endiannness: %d",
2625                  oc->fileName,
2626                  (int)(hdr->Characteristics));
2627       return 0;
2628    }
2629    /* If the string table size is way crazy, this might indicate that
2630       there are more than 64k relocations, despite claims to the
2631       contrary.  Hence this test. */
2632    /* debugBelch("strtab size %d\n", * (UInt32*)strtab); */
2633 #if 0
2634    if ( (*(UInt32*)strtab) > 600000 ) {
2635       /* Note that 600k has no special significance other than being
2636          big enough to handle the almost-2MB-sized lumps that
2637          constitute HSwin32*.o. */
2638       debugBelch("PEi386 object has suspiciously large string table; > 64k relocs?");
2639       return 0;
2640    }
2641 #endif
2642
2643    /* No further verification after this point; only debug printing. */
2644    i = 0;
2645    IF_DEBUG(linker, i=1);
2646    if (i == 0) return 1;
2647
2648    debugBelch( "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
2649    debugBelch( "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
2650    debugBelch( "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
2651
2652    debugBelch("\n" );
2653    debugBelch( "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
2654    debugBelch( "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
2655    debugBelch( "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
2656    debugBelch( "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
2657    debugBelch( "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
2658    debugBelch( "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
2659    debugBelch( "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
2660
2661    /* Print the section table. */
2662    debugBelch("\n" );
2663    for (i = 0; i < hdr->NumberOfSections; i++) {
2664       COFF_reloc* reltab;
2665       COFF_section* sectab_i
2666          = (COFF_section*)
2667            myindex ( sizeof_COFF_section, sectab, i );
2668       debugBelch(
2669                 "\n"
2670                 "section %d\n"
2671                 "     name `",
2672                 i
2673               );
2674       printName ( sectab_i->Name, strtab );
2675       debugBelch(
2676                 "'\n"
2677                 "    vsize %d\n"
2678                 "    vaddr %d\n"
2679                 "  data sz %d\n"
2680                 " data off %d\n"
2681                 "  num rel %d\n"
2682                 "  off rel %d\n"
2683                 "  ptr raw 0x%x\n",
2684                 sectab_i->VirtualSize,
2685                 sectab_i->VirtualAddress,
2686                 sectab_i->SizeOfRawData,
2687                 sectab_i->PointerToRawData,
2688                 sectab_i->NumberOfRelocations,
2689                 sectab_i->PointerToRelocations,
2690                 sectab_i->PointerToRawData
2691               );
2692       reltab = (COFF_reloc*) (
2693                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2694                );
2695
2696       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2697         /* If the relocation field (a short) has overflowed, the
2698          * real count can be found in the first reloc entry.
2699          *
2700          * See Section 4.1 (last para) of the PE spec (rev6.0).
2701          */
2702         COFF_reloc* rel = (COFF_reloc*)
2703                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2704         noRelocs = rel->VirtualAddress;
2705         j = 1;
2706       } else {
2707         noRelocs = sectab_i->NumberOfRelocations;
2708         j = 0;
2709       }
2710
2711       for (; j < noRelocs; j++) {
2712          COFF_symbol* sym;
2713          COFF_reloc* rel = (COFF_reloc*)
2714                            myindex ( sizeof_COFF_reloc, reltab, j );
2715          debugBelch(
2716                    "        type 0x%-4x   vaddr 0x%-8x   name `",
2717                    (UInt32)rel->Type,
2718                    rel->VirtualAddress );
2719          sym = (COFF_symbol*)
2720                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
2721          /* Hmm..mysterious looking offset - what's it for? SOF */
2722          printName ( sym->Name, strtab -10 );
2723          debugBelch("'\n" );
2724       }
2725
2726       debugBelch("\n" );
2727    }
2728    debugBelch("\n" );
2729    debugBelch("string table has size 0x%x\n", * (UInt32*)strtab );
2730    debugBelch("---START of string table---\n");
2731    for (i = 4; i < *(Int32*)strtab; i++) {
2732       if (strtab[i] == 0)
2733          debugBelch("\n"); else
2734          debugBelch("%c", strtab[i] );
2735    }
2736    debugBelch("--- END  of string table---\n");
2737
2738    debugBelch("\n" );
2739    i = 0;
2740    while (1) {
2741       COFF_symbol* symtab_i;
2742       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2743       symtab_i = (COFF_symbol*)
2744                  myindex ( sizeof_COFF_symbol, symtab, i );
2745       debugBelch(
2746                 "symbol %d\n"
2747                 "     name `",
2748                 i
2749               );
2750       printName ( symtab_i->Name, strtab );
2751       debugBelch(
2752                 "'\n"
2753                 "    value 0x%x\n"
2754                 "   1+sec# %d\n"
2755                 "     type 0x%x\n"
2756                 "   sclass 0x%x\n"
2757                 "     nAux %d\n",
2758                 symtab_i->Value,
2759                 (Int32)(symtab_i->SectionNumber),
2760                 (UInt32)symtab_i->Type,
2761                 (UInt32)symtab_i->StorageClass,
2762                 (UInt32)symtab_i->NumberOfAuxSymbols
2763               );
2764       i += symtab_i->NumberOfAuxSymbols;
2765       i++;
2766    }
2767
2768    debugBelch("\n" );
2769    return 1;
2770 }
2771
2772
2773 static int
2774 ocGetNames_PEi386 ( ObjectCode* oc )
2775 {
2776    COFF_header*  hdr;
2777    COFF_section* sectab;
2778    COFF_symbol*  symtab;
2779    UChar*        strtab;
2780
2781    UChar* sname;
2782    void*  addr;
2783    int    i;
2784
2785    hdr = (COFF_header*)(oc->image);
2786    sectab = (COFF_section*) (
2787                ((UChar*)(oc->image))
2788                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2789             );
2790    symtab = (COFF_symbol*) (
2791                ((UChar*)(oc->image))
2792                + hdr->PointerToSymbolTable
2793             );
2794    strtab = ((UChar*)(oc->image))
2795             + hdr->PointerToSymbolTable
2796             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2797
2798    /* Allocate space for any (local, anonymous) .bss sections. */
2799
2800    for (i = 0; i < hdr->NumberOfSections; i++) {
2801       UInt32 bss_sz;
2802       UChar* zspace;
2803       COFF_section* sectab_i
2804          = (COFF_section*)
2805            myindex ( sizeof_COFF_section, sectab, i );
2806
2807       char *secname = cstring_from_section_name(sectab_i->Name, strtab);
2808
2809       if (0 != strcmp(secname, ".bss")) {
2810           stgFree(secname);
2811           continue;
2812       }
2813
2814       stgFree(secname);
2815
2816       /* sof 10/05: the PE spec text isn't too clear regarding what
2817        * the SizeOfRawData field is supposed to hold for object
2818        * file sections containing just uninitialized data -- for executables,
2819        * it is supposed to be zero; unclear what it's supposed to be
2820        * for object files. However, VirtualSize is guaranteed to be
2821        * zero for object files, which definitely suggests that SizeOfRawData
2822        * will be non-zero (where else would the size of this .bss section be
2823        * stored?) Looking at the COFF_section info for incoming object files,
2824        * this certainly appears to be the case.
2825        *
2826        * => I suspect we've been incorrectly handling .bss sections in (relocatable)
2827        * object files up until now. This turned out to bite us with ghc-6.4.1's use
2828        * of gcc-3.4.x, which has started to emit initially-zeroed-out local 'static'
2829        * variable decls into to the .bss section. (The specific function in Q which
2830        * triggered this is libraries/base/cbits/dirUtils.c:__hscore_getFolderPath())
2831        */
2832       if (sectab_i->VirtualSize == 0 && sectab_i->SizeOfRawData == 0) continue;
2833       /* This is a non-empty .bss section.  Allocate zeroed space for
2834          it, and set its PointerToRawData field such that oc->image +
2835          PointerToRawData == addr_of_zeroed_space.  */
2836       bss_sz = sectab_i->VirtualSize;
2837       if ( bss_sz < sectab_i->SizeOfRawData) { bss_sz = sectab_i->SizeOfRawData; }
2838       zspace = stgCallocBytes(1, bss_sz, "ocGetNames_PEi386(anonymous bss)");
2839       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
2840       addProddableBlock(oc, zspace, bss_sz);
2841       /* debugBelch("BSS anon section at 0x%x\n", zspace); */
2842    }
2843
2844    /* Copy section information into the ObjectCode. */
2845
2846    for (i = 0; i < hdr->NumberOfSections; i++) {
2847       UChar* start;
2848       UChar* end;
2849       UInt32 sz;
2850
2851       SectionKind kind
2852          = SECTIONKIND_OTHER;
2853       COFF_section* sectab_i
2854          = (COFF_section*)
2855            myindex ( sizeof_COFF_section, sectab, i );
2856
2857       char *secname = cstring_from_section_name(sectab_i->Name, strtab);
2858
2859       IF_DEBUG(linker, debugBelch("section name = %s\n", secname ));
2860
2861 #     if 0
2862       /* I'm sure this is the Right Way to do it.  However, the
2863          alternative of testing the sectab_i->Name field seems to
2864          work ok with Cygwin.
2865       */
2866       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
2867           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
2868          kind = SECTIONKIND_CODE_OR_RODATA;
2869 #     endif
2870
2871       if (0==strcmp(".text",(char*)secname) ||
2872           0==strcmp(".rdata",(char*)secname)||
2873           0==strcmp(".rodata",(char*)secname))
2874          kind = SECTIONKIND_CODE_OR_RODATA;
2875       if (0==strcmp(".data",(char*)secname) ||
2876           0==strcmp(".bss",(char*)secname))
2877          kind = SECTIONKIND_RWDATA;
2878
2879       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
2880       sz = sectab_i->SizeOfRawData;
2881       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
2882
2883       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
2884       end   = start + sz - 1;
2885
2886       if (kind == SECTIONKIND_OTHER
2887           /* Ignore sections called which contain stabs debugging
2888              information. */
2889           && 0 != strcmp(".stab", (char*)secname)
2890           && 0 != strcmp(".stabstr", (char*)secname)
2891           /* ignore constructor section for now */
2892           && 0 != strcmp(".ctors", (char*)secname)
2893           /* ignore section generated from .ident */
2894           && 0!= strncmp(".debug", (char*)secname, 6)
2895           /* ignore unknown section that appeared in gcc 3.4.5(?) */
2896           && 0!= strcmp(".reloc", (char*)secname)
2897           && 0 != strcmp(".rdata$zzz", (char*)secname)
2898          ) {
2899          errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", secname, oc->fileName);
2900          stgFree(secname);
2901          return 0;
2902       }
2903
2904       if (kind != SECTIONKIND_OTHER && end >= start) {
2905          addSection(oc, kind, start, end);
2906          addProddableBlock(oc, start, end - start + 1);
2907       }
2908
2909       stgFree(secname);
2910    }
2911
2912    /* Copy exported symbols into the ObjectCode. */
2913
2914    oc->n_symbols = hdr->NumberOfSymbols;
2915    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
2916                                   "ocGetNames_PEi386(oc->symbols)");
2917    /* Call me paranoid; I don't care. */
2918    for (i = 0; i < oc->n_symbols; i++)
2919       oc->symbols[i] = NULL;
2920
2921    i = 0;
2922    while (1) {
2923       COFF_symbol* symtab_i;
2924       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2925       symtab_i = (COFF_symbol*)
2926                  myindex ( sizeof_COFF_symbol, symtab, i );
2927
2928       addr  = NULL;
2929
2930       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
2931           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
2932          /* This symbol is global and defined, viz, exported */
2933          /* for MYIMAGE_SYMCLASS_EXTERNAL
2934                 && !MYIMAGE_SYM_UNDEFINED,
2935             the address of the symbol is:
2936                 address of relevant section + offset in section
2937          */
2938          COFF_section* sectabent
2939             = (COFF_section*) myindex ( sizeof_COFF_section,
2940                                         sectab,
2941                                         symtab_i->SectionNumber-1 );
2942          addr = ((UChar*)(oc->image))
2943                 + (sectabent->PointerToRawData
2944                    + symtab_i->Value);
2945       }
2946       else
2947       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
2948           && symtab_i->Value > 0) {
2949          /* This symbol isn't in any section at all, ie, global bss.
2950             Allocate zeroed space for it. */
2951          addr = stgCallocBytes(1, symtab_i->Value,
2952                                "ocGetNames_PEi386(non-anonymous bss)");
2953          addSection(oc, SECTIONKIND_RWDATA, addr,
2954                         ((UChar*)addr) + symtab_i->Value - 1);
2955          addProddableBlock(oc, addr, symtab_i->Value);
2956          /* debugBelch("BSS      section at 0x%x\n", addr); */
2957       }
2958
2959       if (addr != NULL ) {
2960          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
2961          /* debugBelch("addSymbol %p `%s \n", addr,sname);  */
2962          IF_DEBUG(linker, debugBelch("addSymbol %p `%s'\n", addr,sname);)
2963          ASSERT(i >= 0 && i < oc->n_symbols);
2964          /* cstring_from_COFF_symbol_name always succeeds. */
2965          oc->symbols[i] = (char*)sname;
2966          ghciInsertStrHashTable(oc->fileName, symhash, (char*)sname, addr);
2967       } else {
2968 #        if 0
2969          debugBelch(
2970                    "IGNORING symbol %d\n"
2971                    "     name `",
2972                    i
2973                  );
2974          printName ( symtab_i->Name, strtab );
2975          debugBelch(
2976                    "'\n"
2977                    "    value 0x%x\n"
2978                    "   1+sec# %d\n"
2979                    "     type 0x%x\n"
2980                    "   sclass 0x%x\n"
2981                    "     nAux %d\n",
2982                    symtab_i->Value,
2983                    (Int32)(symtab_i->SectionNumber),
2984                    (UInt32)symtab_i->Type,
2985                    (UInt32)symtab_i->StorageClass,
2986                    (UInt32)symtab_i->NumberOfAuxSymbols
2987                  );
2988 #        endif
2989       }
2990
2991       i += symtab_i->NumberOfAuxSymbols;
2992       i++;
2993    }
2994
2995    return 1;
2996 }
2997
2998
2999 static int
3000 ocResolve_PEi386 ( ObjectCode* oc )
3001 {
3002    COFF_header*  hdr;
3003    COFF_section* sectab;
3004    COFF_symbol*  symtab;
3005    UChar*        strtab;
3006
3007    UInt32        A;
3008    UInt32        S;
3009    UInt32*       pP;
3010
3011    int i;
3012    UInt32 j, noRelocs;
3013
3014    /* ToDo: should be variable-sized?  But is at least safe in the
3015       sense of buffer-overrun-proof. */
3016    UChar symbol[1000];
3017    /* debugBelch("resolving for %s\n", oc->fileName); */
3018
3019    hdr = (COFF_header*)(oc->image);
3020    sectab = (COFF_section*) (
3021                ((UChar*)(oc->image))
3022                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
3023             );
3024    symtab = (COFF_symbol*) (
3025                ((UChar*)(oc->image))
3026                + hdr->PointerToSymbolTable
3027             );
3028    strtab = ((UChar*)(oc->image))
3029             + hdr->PointerToSymbolTable
3030             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
3031
3032    for (i = 0; i < hdr->NumberOfSections; i++) {
3033       COFF_section* sectab_i
3034          = (COFF_section*)
3035            myindex ( sizeof_COFF_section, sectab, i );
3036       COFF_reloc* reltab
3037          = (COFF_reloc*) (
3038               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
3039            );
3040
3041       char *secname = cstring_from_section_name(sectab_i->Name, strtab);
3042
3043       /* Ignore sections called which contain stabs debugging
3044          information. */
3045       if (0 == strcmp(".stab", (char*)secname)
3046           || 0 == strcmp(".stabstr", (char*)secname)
3047           || 0 == strcmp(".ctors", (char*)secname)
3048           || 0 == strncmp(".debug", (char*)secname, 6)
3049           || 0 == strcmp(".rdata$zzz", (char*)secname)) {
3050           stgFree(secname);
3051           continue;
3052       }
3053
3054       stgFree(secname);
3055
3056       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
3057         /* If the relocation field (a short) has overflowed, the
3058          * real count can be found in the first reloc entry.
3059          *
3060          * See Section 4.1 (last para) of the PE spec (rev6.0).
3061          *
3062          * Nov2003 update: the GNU linker still doesn't correctly
3063          * handle the generation of relocatable object files with
3064          * overflown relocations. Hence the output to warn of potential
3065          * troubles.
3066          */
3067         COFF_reloc* rel = (COFF_reloc*)
3068                            myindex ( sizeof_COFF_reloc, reltab, 0 );
3069         noRelocs = rel->VirtualAddress;
3070
3071         /* 10/05: we now assume (and check for) a GNU ld that is capable
3072          * of handling object files with (>2^16) of relocs.
3073          */
3074 #if 0
3075         debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
3076                    noRelocs);
3077 #endif
3078         j = 1;
3079       } else {
3080         noRelocs = sectab_i->NumberOfRelocations;
3081         j = 0;
3082       }
3083
3084
3085       for (; j < noRelocs; j++) {
3086          COFF_symbol* sym;
3087          COFF_reloc* reltab_j
3088             = (COFF_reloc*)
3089               myindex ( sizeof_COFF_reloc, reltab, j );
3090
3091          /* the location to patch */
3092          pP = (UInt32*)(
3093                  ((UChar*)(oc->image))
3094                  + (sectab_i->PointerToRawData
3095                     + reltab_j->VirtualAddress
3096                     - sectab_i->VirtualAddress )
3097               );
3098          /* the existing contents of pP */
3099          A = *pP;
3100          /* the symbol to connect to */
3101          sym = (COFF_symbol*)
3102                myindex ( sizeof_COFF_symbol,
3103                          symtab, reltab_j->SymbolTableIndex );
3104          IF_DEBUG(linker,
3105                   debugBelch(
3106                             "reloc sec %2d num %3d:  type 0x%-4x   "
3107                             "vaddr 0x%-8x   name `",
3108                             i, j,
3109                             (UInt32)reltab_j->Type,
3110                             reltab_j->VirtualAddress );
3111                             printName ( sym->Name, strtab );
3112                             debugBelch("'\n" ));
3113
3114          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
3115             COFF_section* section_sym
3116                = findPEi386SectionCalled ( oc, sym->Name );
3117             if (!section_sym) {
3118                errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
3119                return 0;
3120             }
3121             S = ((UInt32)(oc->image))
3122                 + (section_sym->PointerToRawData
3123                    + sym->Value);
3124          } else {
3125             copyName ( sym->Name, strtab, symbol, 1000-1 );
3126             S = (UInt32) lookupSymbol( (char*)symbol );
3127             if ((void*)S != NULL) goto foundit;
3128             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3129             return 0;
3130            foundit:;
3131          }
3132          checkProddableBlock(oc, pP);
3133          switch (reltab_j->Type) {
3134             case MYIMAGE_REL_I386_DIR32:
3135                *pP = A + S;
3136                break;
3137             case MYIMAGE_REL_I386_REL32:
3138                /* Tricky.  We have to insert a displacement at
3139                   pP which, when added to the PC for the _next_
3140                   insn, gives the address of the target (S).
3141                   Problem is to know the address of the next insn
3142                   when we only know pP.  We assume that this
3143                   literal field is always the last in the insn,
3144                   so that the address of the next insn is pP+4
3145                   -- hence the constant 4.
3146                   Also I don't know if A should be added, but so
3147                   far it has always been zero.
3148
3149                   SOF 05/2005: 'A' (old contents of *pP) have been observed
3150                   to contain values other than zero (the 'wx' object file
3151                   that came with wxhaskell-0.9.4; dunno how it was compiled..).
3152                   So, add displacement to old value instead of asserting
3153                   A to be zero. Fixes wxhaskell-related crashes, and no other
3154                   ill effects have been observed.
3155
3156                   Update: the reason why we're seeing these more elaborate
3157                   relocations is due to a switch in how the NCG compiles SRTs
3158                   and offsets to them from info tables. SRTs live in .(ro)data,
3159                   while info tables live in .text, causing GAS to emit REL32/DISP32
3160                   relocations with non-zero values. Adding the displacement is
3161                   the right thing to do.
3162                */
3163                *pP = S - ((UInt32)pP) - 4 + A;
3164                break;
3165             default:
3166                debugBelch("%s: unhandled PEi386 relocation type %d",
3167                      oc->fileName, reltab_j->Type);
3168                return 0;
3169          }
3170
3171       }
3172    }
3173
3174    IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
3175    return 1;
3176 }
3177
3178 #endif /* defined(OBJFORMAT_PEi386) */
3179
3180
3181 /* --------------------------------------------------------------------------
3182  * ELF specifics
3183  * ------------------------------------------------------------------------*/
3184
3185 #if defined(OBJFORMAT_ELF)
3186
3187 #define FALSE 0
3188 #define TRUE  1
3189
3190 #if defined(sparc_HOST_ARCH)
3191 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
3192 #elif defined(i386_HOST_ARCH)
3193 #  define ELF_TARGET_386    /* Used inside <elf.h> */
3194 #elif defined(x86_64_HOST_ARCH)
3195 #  define ELF_TARGET_X64_64
3196 #  define ELF_64BIT
3197 #endif
3198
3199 #if !defined(openbsd_HOST_OS)
3200 #  include <elf.h>
3201 #else
3202 /* openbsd elf has things in different places, with diff names */
3203 #  include <elf_abi.h>
3204 #  include <machine/reloc.h>
3205 #  define R_386_32    RELOC_32
3206 #  define R_386_PC32  RELOC_PC32
3207 #endif
3208
3209 /* If elf.h doesn't define it */
3210 #  ifndef R_X86_64_PC64
3211 #    define R_X86_64_PC64 24
3212 #  endif
3213
3214 /*
3215  * Define a set of types which can be used for both ELF32 and ELF64
3216  */
3217
3218 #ifdef ELF_64BIT
3219 #define ELFCLASS    ELFCLASS64
3220 #define Elf_Addr    Elf64_Addr
3221 #define Elf_Word    Elf64_Word
3222 #define Elf_Sword   Elf64_Sword
3223 #define Elf_Ehdr    Elf64_Ehdr
3224 #define Elf_Phdr    Elf64_Phdr
3225 #define Elf_Shdr    Elf64_Shdr
3226 #define Elf_Sym     Elf64_Sym
3227 #define Elf_Rel     Elf64_Rel
3228 #define Elf_Rela    Elf64_Rela
3229 #ifndef ELF_ST_TYPE
3230 #define ELF_ST_TYPE ELF64_ST_TYPE
3231 #endif
3232 #ifndef ELF_ST_BIND
3233 #define ELF_ST_BIND ELF64_ST_BIND
3234 #endif
3235 #ifndef ELF_R_TYPE
3236 #define ELF_R_TYPE  ELF64_R_TYPE
3237 #endif
3238 #ifndef ELF_R_SYM
3239 #define ELF_R_SYM   ELF64_R_SYM
3240 #endif
3241 #else
3242 #define ELFCLASS    ELFCLASS32
3243 #define Elf_Addr    Elf32_Addr
3244 #define Elf_Word    Elf32_Word
3245 #define Elf_Sword   Elf32_Sword
3246 #define Elf_Ehdr    Elf32_Ehdr
3247 #define Elf_Phdr    Elf32_Phdr
3248 #define Elf_Shdr    Elf32_Shdr
3249 #define Elf_Sym     Elf32_Sym
3250 #define Elf_Rel     Elf32_Rel
3251 #define Elf_Rela    Elf32_Rela
3252 #ifndef ELF_ST_TYPE
3253 #define ELF_ST_TYPE ELF32_ST_TYPE
3254 #endif
3255 #ifndef ELF_ST_BIND
3256 #define ELF_ST_BIND ELF32_ST_BIND
3257 #endif
3258 #ifndef ELF_R_TYPE
3259 #define ELF_R_TYPE  ELF32_R_TYPE
3260 #endif
3261 #ifndef ELF_R_SYM
3262 #define ELF_R_SYM   ELF32_R_SYM
3263 #endif
3264 #endif
3265
3266
3267 /*
3268  * Functions to allocate entries in dynamic sections.  Currently we simply
3269  * preallocate a large number, and we don't check if a entry for the given
3270  * target already exists (a linear search is too slow).  Ideally these
3271  * entries would be associated with symbols.
3272  */
3273
3274 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
3275 #define GOT_SIZE            0x20000
3276 #define FUNCTION_TABLE_SIZE 0x10000
3277 #define PLT_SIZE            0x08000
3278
3279 #ifdef ELF_NEED_GOT
3280 static Elf_Addr got[GOT_SIZE];
3281 static unsigned int gotIndex;
3282 static Elf_Addr gp_val = (Elf_Addr)got;
3283
3284 static Elf_Addr
3285 allocateGOTEntry(Elf_Addr target)
3286 {
3287    Elf_Addr *entry;
3288
3289    if (gotIndex >= GOT_SIZE)
3290       barf("Global offset table overflow");
3291
3292    entry = &got[gotIndex++];
3293    *entry = target;
3294    return (Elf_Addr)entry;
3295 }
3296 #endif
3297
3298 #ifdef ELF_FUNCTION_DESC
3299 typedef struct {
3300    Elf_Addr ip;
3301    Elf_Addr gp;
3302 } FunctionDesc;
3303
3304 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
3305 static unsigned int functionTableIndex;
3306
3307 static Elf_Addr
3308 allocateFunctionDesc(Elf_Addr target)
3309 {
3310    FunctionDesc *entry;
3311
3312    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
3313       barf("Function table overflow");
3314
3315    entry = &functionTable[functionTableIndex++];
3316    entry->ip = target;
3317    entry->gp = (Elf_Addr)gp_val;
3318    return (Elf_Addr)entry;
3319 }
3320
3321 static Elf_Addr
3322 copyFunctionDesc(Elf_Addr target)
3323 {
3324    FunctionDesc *olddesc = (FunctionDesc *)target;
3325    FunctionDesc *newdesc;
3326
3327    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
3328    newdesc->gp = olddesc->gp;
3329    return (Elf_Addr)newdesc;
3330 }
3331 #endif
3332
3333 #ifdef ELF_NEED_PLT
3334
3335 typedef struct {
3336    unsigned char code[sizeof(plt_code)];
3337 } PLTEntry;
3338
3339 static Elf_Addr
3340 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
3341 {
3342    PLTEntry *plt = (PLTEntry *)oc->plt;
3343    PLTEntry *entry;
3344
3345    if (oc->pltIndex >= PLT_SIZE)
3346       barf("Procedure table overflow");
3347
3348    entry = &plt[oc->pltIndex++];
3349    memcpy(entry->code, plt_code, sizeof(entry->code));
3350    PLT_RELOC(entry->code, target);
3351    return (Elf_Addr)entry;
3352 }
3353
3354 static unsigned int
3355 PLTSize(void)
3356 {
3357    return (PLT_SIZE * sizeof(PLTEntry));
3358 }
3359 #endif
3360
3361
3362 /*
3363  * Generic ELF functions
3364  */
3365
3366 static char *
3367 findElfSection ( void* objImage, Elf_Word sh_type )
3368 {
3369    char* ehdrC = (char*)objImage;
3370    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
3371    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
3372    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
3373    char* ptr = NULL;
3374    int i;
3375
3376    for (i = 0; i < ehdr->e_shnum; i++) {
3377       if (shdr[i].sh_type == sh_type
3378           /* Ignore the section header's string table. */
3379           && i != ehdr->e_shstrndx
3380           /* Ignore string tables named .stabstr, as they contain
3381              debugging info. */
3382           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
3383          ) {
3384          ptr = ehdrC + shdr[i].sh_offset;
3385          break;
3386       }
3387    }
3388    return ptr;
3389 }
3390
3391 static int
3392 ocVerifyImage_ELF ( ObjectCode* oc )
3393 {
3394    Elf_Shdr* shdr;
3395    Elf_Sym*  stab;
3396    int i, j, nent, nstrtab, nsymtabs;
3397    char* sh_strtab;
3398    char* strtab;
3399
3400    char*     ehdrC = (char*)(oc->image);
3401    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
3402
3403    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
3404        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
3405        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
3406        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
3407       errorBelch("%s: not an ELF object", oc->fileName);
3408       return 0;
3409    }
3410
3411    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
3412       errorBelch("%s: unsupported ELF format", oc->fileName);
3413       return 0;
3414    }
3415
3416    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
3417        IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
3418    } else
3419    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
3420        IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
3421    } else {
3422        errorBelch("%s: unknown endiannness", oc->fileName);
3423        return 0;
3424    }
3425
3426    if (ehdr->e_type != ET_REL) {
3427       errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
3428       return 0;
3429    }
3430    IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
3431
3432    IF_DEBUG(linker,debugBelch( "Architecture is " ));
3433    switch (ehdr->e_machine) {
3434       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
3435 #ifdef EM_SPARC32PLUS
3436       case EM_SPARC32PLUS:
3437 #endif
3438       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
3439 #ifdef EM_IA_64
3440       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
3441 #endif
3442       case EM_PPC:   IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
3443 #ifdef EM_X86_64
3444       case EM_X86_64: IF_DEBUG(linker,debugBelch( "x86_64" )); break;
3445 #elif defined(EM_AMD64)
3446       case EM_AMD64: IF_DEBUG(linker,debugBelch( "amd64" )); break;
3447 #endif
3448       default:       IF_DEBUG(linker,debugBelch( "unknown" ));
3449                      errorBelch("%s: unknown architecture (e_machine == %d)"
3450                                 , oc->fileName, ehdr->e_machine);
3451                      return 0;
3452    }
3453
3454    IF_DEBUG(linker,debugBelch(
3455              "\nSection header table: start %ld, n_entries %d, ent_size %d\n",
3456              (long)ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
3457
3458    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
3459
3460    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3461
3462    if (ehdr->e_shstrndx == SHN_UNDEF) {
3463       errorBelch("%s: no section header string table", oc->fileName);
3464       return 0;
3465    } else {
3466       IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
3467                           ehdr->e_shstrndx));
3468       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
3469    }
3470
3471    for (i = 0; i < ehdr->e_shnum; i++) {
3472       IF_DEBUG(linker,debugBelch("%2d:  ", i ));
3473       IF_DEBUG(linker,debugBelch("type=%2d  ", (int)shdr[i].sh_type ));
3474       IF_DEBUG(linker,debugBelch("size=%4d  ", (int)shdr[i].sh_size ));
3475       IF_DEBUG(linker,debugBelch("offs=%4d  ", (int)shdr[i].sh_offset ));
3476       IF_DEBUG(linker,debugBelch("  (%p .. %p)  ",
3477                ehdrC + shdr[i].sh_offset,
3478                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
3479
3480       if (shdr[i].sh_type == SHT_REL) {
3481           IF_DEBUG(linker,debugBelch("Rel  " ));
3482       } else if (shdr[i].sh_type == SHT_RELA) {
3483           IF_DEBUG(linker,debugBelch("RelA " ));
3484       } else {
3485           IF_DEBUG(linker,debugBelch("     "));
3486       }
3487       if (sh_strtab) {
3488           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
3489       }
3490    }
3491
3492    IF_DEBUG(linker,debugBelch( "\nString tables" ));
3493    strtab = NULL;
3494    nstrtab = 0;
3495    for (i = 0; i < ehdr->e_shnum; i++) {
3496       if (shdr[i].sh_type == SHT_STRTAB
3497           /* Ignore the section header's string table. */
3498           && i != ehdr->e_shstrndx
3499           /* Ignore string tables named .stabstr, as they contain
3500              debugging info. */
3501           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
3502          ) {
3503          IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
3504          strtab = ehdrC + shdr[i].sh_offset;
3505          nstrtab++;
3506       }
3507    }
3508    if (nstrtab != 1) {
3509       errorBelch("%s: no string tables, or too many", oc->fileName);
3510       return 0;
3511    }
3512
3513    nsymtabs = 0;
3514    IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
3515    for (i = 0; i < ehdr->e_shnum; i++) {
3516       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3517       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
3518       nsymtabs++;
3519       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3520       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3521       IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%ld rem)\n",
3522                nent,
3523                (long)shdr[i].sh_size % sizeof(Elf_Sym)
3524              ));
3525       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
3526          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
3527          return 0;
3528       }
3529       for (j = 0; j < nent; j++) {
3530          IF_DEBUG(linker,debugBelch("   %2d  ", j ));
3531          IF_DEBUG(linker,debugBelch("  sec=%-5d  size=%-3d  val=%5p  ",
3532                              (int)stab[j].st_shndx,
3533                              (int)stab[j].st_size,
3534                              (char*)stab[j].st_value ));
3535
3536          IF_DEBUG(linker,debugBelch("type=" ));
3537          switch (ELF_ST_TYPE(stab[j].st_info)) {
3538             case STT_NOTYPE:  IF_DEBUG(linker,debugBelch("notype " )); break;
3539             case STT_OBJECT:  IF_DEBUG(linker,debugBelch("object " )); break;
3540             case STT_FUNC  :  IF_DEBUG(linker,debugBelch("func   " )); break;
3541             case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
3542             case STT_FILE:    IF_DEBUG(linker,debugBelch("file   " )); break;
3543             default:          IF_DEBUG(linker,debugBelch("?      " )); break;
3544          }
3545          IF_DEBUG(linker,debugBelch("  " ));
3546
3547          IF_DEBUG(linker,debugBelch("bind=" ));
3548          switch (ELF_ST_BIND(stab[j].st_info)) {
3549             case STB_LOCAL :  IF_DEBUG(linker,debugBelch("local " )); break;
3550             case STB_GLOBAL:  IF_DEBUG(linker,debugBelch("global" )); break;
3551             case STB_WEAK  :  IF_DEBUG(linker,debugBelch("weak  " )); break;
3552             default:          IF_DEBUG(linker,debugBelch("?     " )); break;
3553          }
3554          IF_DEBUG(linker,debugBelch("  " ));
3555
3556          IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
3557       }
3558    }
3559
3560    if (nsymtabs == 0) {
3561       errorBelch("%s: didn't find any symbol tables", oc->fileName);
3562       return 0;
3563    }
3564
3565    return 1;
3566 }
3567
3568 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
3569 {
3570     *is_bss = FALSE;
3571
3572     if (hdr->sh_type == SHT_PROGBITS
3573         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
3574         /* .text-style section */
3575         return SECTIONKIND_CODE_OR_RODATA;
3576     }
3577
3578     if (hdr->sh_type == SHT_PROGBITS
3579             && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3580             /* .data-style section */
3581             return SECTIONKIND_RWDATA;
3582     }
3583
3584     if (hdr->sh_type == SHT_PROGBITS
3585         && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
3586         /* .rodata-style section */
3587         return SECTIONKIND_CODE_OR_RODATA;
3588     }
3589
3590     if (hdr->sh_type == SHT_NOBITS
3591         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3592         /* .bss-style section */
3593         *is_bss = TRUE;
3594         return SECTIONKIND_RWDATA;
3595     }
3596
3597     return SECTIONKIND_OTHER;
3598 }
3599
3600
3601 static int
3602 ocGetNames_ELF ( ObjectCode* oc )
3603 {
3604    int i, j, k, nent;
3605    Elf_Sym* stab;
3606
3607    char*     ehdrC    = (char*)(oc->image);
3608    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
3609    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
3610    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3611
3612    ASSERT(symhash != NULL);
3613
3614    if (!strtab) {
3615       errorBelch("%s: no strtab", oc->fileName);
3616       return 0;
3617    }
3618
3619    k = 0;
3620    for (i = 0; i < ehdr->e_shnum; i++) {
3621       /* Figure out what kind of section it is.  Logic derived from
3622          Figure 1.14 ("Special Sections") of the ELF document
3623          ("Portable Formats Specification, Version 1.1"). */
3624       int         is_bss = FALSE;
3625       SectionKind kind   = getSectionKind_ELF(&shdr[i], &is_bss);
3626
3627       if (is_bss && shdr[i].sh_size > 0) {
3628          /* This is a non-empty .bss section.  Allocate zeroed space for
3629             it, and set its .sh_offset field such that
3630             ehdrC + .sh_offset == addr_of_zeroed_space.  */
3631          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
3632                                        "ocGetNames_ELF(BSS)");
3633          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
3634          /*
3635          debugBelch("BSS section at 0x%x, size %d\n",
3636                          zspace, shdr[i].sh_size);
3637          */
3638       }
3639
3640       /* fill in the section info */
3641       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
3642          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
3643          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
3644                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
3645       }
3646
3647       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3648
3649       /* copy stuff into this module's object symbol table */
3650       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3651       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3652
3653       oc->n_symbols = nent;
3654       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3655                                    "ocGetNames_ELF(oc->symbols)");
3656
3657       for (j = 0; j < nent; j++) {
3658
3659          char  isLocal = FALSE; /* avoids uninit-var warning */
3660          char* ad      = NULL;
3661          char* nm      = strtab + stab[j].st_name;
3662          int   secno   = stab[j].st_shndx;
3663
3664          /* Figure out if we want to add it; if so, set ad to its
3665             address.  Otherwise leave ad == NULL. */
3666
3667          if (secno == SHN_COMMON) {
3668             isLocal = FALSE;
3669             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
3670             /*
3671             debugBelch("COMMON symbol, size %d name %s\n",
3672                             stab[j].st_size, nm);
3673             */
3674             /* Pointless to do addProddableBlock() for this area,
3675                since the linker should never poke around in it. */
3676          }
3677          else
3678          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
3679                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
3680               )
3681               /* and not an undefined symbol */
3682               && stab[j].st_shndx != SHN_UNDEF
3683               /* and not in a "special section" */
3684               && stab[j].st_shndx < SHN_LORESERVE
3685               &&
3686               /* and it's a not a section or string table or anything silly */
3687               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
3688                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
3689                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
3690               )
3691             ) {
3692             /* Section 0 is the undefined section, hence > and not >=. */
3693             ASSERT(secno > 0 && secno < ehdr->e_shnum);
3694             /*
3695             if (shdr[secno].sh_type == SHT_NOBITS) {
3696                debugBelch("   BSS symbol, size %d off %d name %s\n",
3697                                stab[j].st_size, stab[j].st_value, nm);
3698             }
3699             */
3700             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
3701             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
3702                isLocal = TRUE;
3703             } else {
3704 #ifdef ELF_FUNCTION_DESC
3705                /* dlsym() and the initialisation table both give us function
3706                 * descriptors, so to be consistent we store function descriptors
3707                 * in the symbol table */
3708                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
3709                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
3710 #endif
3711                IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p  %s %s\n",
3712                                       ad, oc->fileName, nm ));
3713                isLocal = FALSE;
3714             }
3715          }
3716
3717          /* And the decision is ... */
3718
3719          if (ad != NULL) {
3720             ASSERT(nm != NULL);
3721             oc->symbols[j] = nm;
3722             /* Acquire! */
3723             if (isLocal) {
3724                /* Ignore entirely. */
3725             } else {
3726                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
3727             }
3728          } else {
3729             /* Skip. */
3730             IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
3731                                    strtab + stab[j].st_name ));
3732             /*
3733             debugBelch(
3734                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
3735                     (int)ELF_ST_BIND(stab[j].st_info),
3736                     (int)ELF_ST_TYPE(stab[j].st_info),
3737                     (int)stab[j].st_shndx,
3738                     strtab + stab[j].st_name
3739                    );
3740             */
3741             oc->symbols[j] = NULL;
3742          }
3743
3744       }
3745    }
3746
3747    return 1;
3748 }
3749
3750 /* Do ELF relocations which lack an explicit addend.  All x86-linux
3751    relocations appear to be of this form. */
3752 static int
3753 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
3754                          Elf_Shdr* shdr, int shnum,
3755                          Elf_Sym*  stab, char* strtab )
3756 {
3757    int j;
3758    char *symbol;
3759    Elf_Word* targ;
3760    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
3761    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
3762    int target_shndx = shdr[shnum].sh_info;
3763    int symtab_shndx = shdr[shnum].sh_link;
3764
3765    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3766    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
3767    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3768                           target_shndx, symtab_shndx ));
3769
3770    /* Skip sections that we're not interested in. */
3771    {
3772        int is_bss;
3773        SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
3774        if (kind == SECTIONKIND_OTHER) {
3775            IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
3776            return 1;
3777        }
3778    }
3779
3780    for (j = 0; j < nent; j++) {
3781       Elf_Addr offset = rtab[j].r_offset;
3782       Elf_Addr info   = rtab[j].r_info;
3783
3784       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
3785       Elf_Word* pP = (Elf_Word*)P;
3786       Elf_Addr  A  = *pP;
3787       Elf_Addr  S;
3788       void*     S_tmp;
3789       Elf_Addr  value;
3790       StgStablePtr stablePtr;
3791       StgPtr stableVal;
3792
3793       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
3794                              j, (void*)offset, (void*)info ));
3795       if (!info) {
3796          IF_DEBUG(linker,debugBelch( " ZERO" ));
3797          S = 0;
3798       } else {
3799          Elf_Sym sym = stab[ELF_R_SYM(info)];
3800          /* First see if it is a local symbol. */
3801          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3802             /* Yes, so we can get the address directly from the ELF symbol
3803                table. */
3804             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3805             S = (Elf_Addr)
3806                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3807                        + stab[ELF_R_SYM(info)].st_value);
3808
3809          } else {
3810             symbol = strtab + sym.st_name;
3811             stablePtr = (StgStablePtr)lookupHashTable(stablehash, (StgWord)symbol);
3812             if (NULL == stablePtr) {
3813               /* No, so look up the name in our global table. */
3814               S_tmp = lookupSymbol( symbol );
3815               S = (Elf_Addr)S_tmp;
3816             } else {
3817               stableVal = deRefStablePtr( stablePtr );
3818               S_tmp = stableVal;
3819               S = (Elf_Addr)S_tmp;
3820             }
3821          }
3822          if (!S) {
3823             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3824             return 0;
3825          }
3826          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n", symbol, (void*)S ));
3827       }
3828
3829       IF_DEBUG(linker,debugBelch( "Reloc: P = %p   S = %p   A = %p\n",
3830                              (void*)P, (void*)S, (void*)A ));
3831       checkProddableBlock ( oc, pP );
3832
3833       value = S + A;
3834
3835       switch (ELF_R_TYPE(info)) {
3836 #        ifdef i386_HOST_ARCH
3837          case R_386_32:   *pP = value;     break;
3838          case R_386_PC32: *pP = value - P; break;
3839 #        endif
3840          default:
3841             errorBelch("%s: unhandled ELF relocation(Rel) type %lu\n",
3842                   oc->fileName, (lnat)ELF_R_TYPE(info));
3843             return 0;
3844       }
3845
3846    }
3847    return 1;
3848 }
3849
3850 /* Do ELF relocations for which explicit addends are supplied.
3851    sparc-solaris relocations appear to be of this form. */
3852 static int
3853 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
3854                           Elf_Shdr* shdr, int shnum,
3855                           Elf_Sym*  stab, char* strtab )
3856 {
3857    int j;
3858    char *symbol = NULL;
3859    Elf_Addr targ;
3860    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
3861    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
3862    int target_shndx = shdr[shnum].sh_info;
3863    int symtab_shndx = shdr[shnum].sh_link;
3864
3865    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3866    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
3867    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3868                           target_shndx, symtab_shndx ));
3869
3870    for (j = 0; j < nent; j++) {
3871 #if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3872       /* This #ifdef only serves to avoid unused-var warnings. */
3873       Elf_Addr  offset = rtab[j].r_offset;
3874       Elf_Addr  P      = targ + offset;
3875 #endif
3876       Elf_Addr  info   = rtab[j].r_info;
3877       Elf_Addr  A      = rtab[j].r_addend;
3878       Elf_Addr  S;
3879       void*     S_tmp;
3880       Elf_Addr  value;
3881 #     if defined(sparc_HOST_ARCH)
3882       Elf_Word* pP = (Elf_Word*)P;
3883       Elf_Word  w1, w2;
3884 #     elif defined(powerpc_HOST_ARCH)
3885       Elf_Sword delta;
3886 #     endif
3887
3888       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p %6p)   ",
3889                              j, (void*)offset, (void*)info,
3890                                 (void*)A ));
3891       if (!info) {
3892          IF_DEBUG(linker,debugBelch( " ZERO" ));
3893          S = 0;
3894       } else {
3895          Elf_Sym sym = stab[ELF_R_SYM(info)];
3896          /* First see if it is a local symbol. */
3897          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3898             /* Yes, so we can get the address directly from the ELF symbol
3899                table. */
3900             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3901             S = (Elf_Addr)
3902                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3903                        + stab[ELF_R_SYM(info)].st_value);
3904 #ifdef ELF_FUNCTION_DESC
3905             /* Make a function descriptor for this function */
3906             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
3907                S = allocateFunctionDesc(S + A);
3908                A = 0;
3909             }
3910 #endif
3911          } else {
3912             /* No, so look up the name in our global table. */
3913             symbol = strtab + sym.st_name;
3914             S_tmp = lookupSymbol( symbol );
3915             S = (Elf_Addr)S_tmp;
3916
3917 #ifdef ELF_FUNCTION_DESC
3918             /* If a function, already a function descriptor - we would
3919                have to copy it to add an offset. */
3920             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
3921                errorBelch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
3922 #endif
3923          }
3924          if (!S) {
3925            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3926            return 0;
3927          }
3928          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p", symbol, (void*)S ));
3929       }
3930
3931       IF_DEBUG(linker,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
3932                                         (void*)P, (void*)S, (void*)A ));
3933       /* checkProddableBlock ( oc, (void*)P ); */
3934
3935       value = S + A;
3936
3937       switch (ELF_R_TYPE(info)) {
3938 #        if defined(sparc_HOST_ARCH)
3939          case R_SPARC_WDISP30:
3940             w1 = *pP & 0xC0000000;
3941             w2 = (Elf_Word)((value - P) >> 2);
3942             ASSERT((w2 & 0xC0000000) == 0);
3943             w1 |= w2;
3944             *pP = w1;
3945             break;
3946          case R_SPARC_HI22:
3947             w1 = *pP & 0xFFC00000;
3948             w2 = (Elf_Word)(value >> 10);
3949             ASSERT((w2 & 0xFFC00000) == 0);
3950             w1 |= w2;
3951             *pP = w1;
3952             break;
3953          case R_SPARC_LO10:
3954             w1 = *pP & ~0x3FF;
3955             w2 = (Elf_Word)(value & 0x3FF);
3956             ASSERT((w2 & ~0x3FF) == 0);
3957             w1 |= w2;
3958             *pP = w1;
3959             break;
3960
3961          /* According to the Sun documentation:
3962             R_SPARC_UA32
3963             This relocation type resembles R_SPARC_32, except it refers to an
3964             unaligned word. That is, the word to be relocated must be treated
3965             as four separate bytes with arbitrary alignment, not as a word
3966             aligned according to the architecture requirements.
3967          */
3968          case R_SPARC_UA32:
3969             w2  = (Elf_Word)value;
3970
3971             // SPARC doesn't do misaligned writes of 32 bit words,
3972             //       so we have to do this one byte-at-a-time.
3973             char *pPc   = (char*)pP;
3974             pPc[0]      = (char) ((Elf_Word)(w2 & 0xff000000) >> 24);
3975             pPc[1]      = (char) ((Elf_Word)(w2 & 0x00ff0000) >> 16);
3976             pPc[2]      = (char) ((Elf_Word)(w2 & 0x0000ff00) >> 8);
3977             pPc[3]      = (char) ((Elf_Word)(w2 & 0x000000ff));
3978             break;
3979
3980          case R_SPARC_32:
3981             w2 = (Elf_Word)value;
3982             *pP = w2;
3983             break;
3984 #        elif defined(powerpc_HOST_ARCH)
3985          case R_PPC_ADDR16_LO:
3986             *(Elf32_Half*) P = value;
3987             break;
3988
3989          case R_PPC_ADDR16_HI:
3990             *(Elf32_Half*) P = value >> 16;
3991             break;
3992
3993          case R_PPC_ADDR16_HA:
3994             *(Elf32_Half*) P = (value + 0x8000) >> 16;
3995             break;
3996
3997          case R_PPC_ADDR32:
3998             *(Elf32_Word *) P = value;
3999             break;
4000
4001          case R_PPC_REL32:
4002             *(Elf32_Word *) P = value - P;
4003             break;
4004
4005          case R_PPC_REL24:
4006             delta = value - P;
4007
4008             if( delta << 6 >> 6 != delta )
4009             {
4010                value = (Elf_Addr) (&makeSymbolExtra( oc, ELF_R_SYM(info), value )
4011                                         ->jumpIsland);
4012                delta = value - P;
4013
4014                if( value == 0 || delta << 6 >> 6 != delta )
4015                {
4016                   barf( "Unable to make SymbolExtra for #%d",
4017                         ELF_R_SYM(info) );
4018                   return 0;
4019                }
4020             }
4021
4022             *(Elf_Word *) P = (*(Elf_Word *) P & 0xfc000003)
4023                                           | (delta & 0x3fffffc);
4024             break;
4025 #        endif
4026
4027 #if x86_64_HOST_ARCH
4028       case R_X86_64_64:
4029           *(Elf64_Xword *)P = value;
4030           break;
4031
4032       case R_X86_64_PC32:
4033       {
4034 #if defined(ALWAYS_PIC)
4035           barf("R_X86_64_PC32 relocation, but ALWAYS_PIC.");
4036 #else
4037           StgInt64 off = value - P;
4038           if (off >= 0x7fffffffL || off < -0x80000000L) {
4039 #if X86_64_ELF_NONPIC_HACK
4040               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
4041                                                 -> jumpIsland;
4042               off = pltAddress + A - P;
4043 #else
4044               barf("R_X86_64_PC32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
4045                    symbol, off, oc->fileName );
4046 #endif
4047           }
4048           *(Elf64_Word *)P = (Elf64_Word)off;
4049 #endif
4050           break;
4051       }
4052
4053       case R_X86_64_PC64:
4054       {
4055           StgInt64 off = value - P;
4056           *(Elf64_Word *)P = (Elf64_Word)off;
4057           break;
4058       }
4059
4060       case R_X86_64_32:
4061 #if defined(ALWAYS_PIC)
4062           barf("R_X86_64_32 relocation, but ALWAYS_PIC.");
4063 #else
4064           if (value >= 0x7fffffffL) {
4065 #if X86_64_ELF_NONPIC_HACK
4066               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
4067                                                 -> jumpIsland;
4068               value = pltAddress + A;
4069 #else
4070               barf("R_X86_64_32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
4071                    symbol, value, oc->fileName );
4072 #endif
4073           }
4074           *(Elf64_Word *)P = (Elf64_Word)value;
4075 #endif
4076           break;
4077
4078       case R_X86_64_32S:
4079 #if defined(ALWAYS_PIC)
4080           barf("R_X86_64_32S relocation, but ALWAYS_PIC.");
4081 #else
4082           if ((StgInt64)value > 0x7fffffffL || (StgInt64)value < -0x80000000L) {
4083 #if X86_64_ELF_NONPIC_HACK
4084               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
4085                                                 -> jumpIsland;
4086               value = pltAddress + A;
4087 #else
4088               barf("R_X86_64_32S relocation out of range: %s = %p\nRecompile %s with -fPIC.",
4089                    symbol, value, oc->fileName );
4090 #endif
4091           }
4092           *(Elf64_Sword *)P = (Elf64_Sword)value;
4093 #endif
4094           break;
4095
4096       case R_X86_64_GOTPCREL:
4097       {
4098           StgInt64 gotAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)->addr;
4099           StgInt64 off = gotAddress + A - P;
4100           *(Elf64_Word *)P = (Elf64_Word)off;
4101           break;
4102       }
4103
4104       case R_X86_64_PLT32:
4105       {
4106 #if defined(ALWAYS_PIC)
4107           barf("R_X86_64_PLT32 relocation, but ALWAYS_PIC.");
4108 #else
4109           StgInt64 off = value - P;
4110           if (off >= 0x7fffffffL || off < -0x80000000L) {
4111               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
4112                                                     -> jumpIsland;
4113               off = pltAddress + A - P;
4114           }
4115           *(Elf64_Word *)P = (Elf64_Word)off;
4116 #endif
4117           break;
4118       }
4119 #endif
4120
4121          default:
4122             errorBelch("%s: unhandled ELF relocation(RelA) type %lu\n",
4123                   oc->fileName, (lnat)ELF_R_TYPE(info));
4124             return 0;
4125       }
4126
4127    }
4128    return 1;
4129 }
4130
4131 static int
4132 ocResolve_ELF ( ObjectCode* oc )
4133 {
4134    char *strtab;
4135    int   shnum, ok;
4136    Elf_Sym*  stab  = NULL;
4137    char*     ehdrC = (char*)(oc->image);
4138    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
4139    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
4140
4141    /* first find "the" symbol table */
4142    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
4143
4144    /* also go find the string table */
4145    strtab = findElfSection ( ehdrC, SHT_STRTAB );
4146
4147    if (stab == NULL || strtab == NULL) {
4148       errorBelch("%s: can't find string or symbol table", oc->fileName);
4149       return 0;
4150    }
4151
4152    /* Process the relocation sections. */
4153    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
4154       if (shdr[shnum].sh_type == SHT_REL) {
4155          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
4156                                        shnum, stab, strtab );
4157          if (!ok) return ok;
4158       }
4159       else
4160       if (shdr[shnum].sh_type == SHT_RELA) {
4161          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
4162                                         shnum, stab, strtab );
4163          if (!ok) return ok;
4164       }
4165    }
4166
4167 #if defined(powerpc_HOST_ARCH)
4168    ocFlushInstructionCache( oc );
4169 #endif
4170
4171    return 1;
4172 }
4173
4174 /*
4175  * PowerPC & X86_64 ELF specifics
4176  */
4177
4178 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
4179
4180 static int ocAllocateSymbolExtras_ELF( ObjectCode *oc )
4181 {
4182   Elf_Ehdr *ehdr;
4183   Elf_Shdr* shdr;
4184   int i;
4185
4186   ehdr = (Elf_Ehdr *) oc->image;
4187   shdr = (Elf_Shdr *) ( ((char *)oc->image) + ehdr->e_shoff );
4188
4189   for( i = 0; i < ehdr->e_shnum; i++ )
4190     if( shdr[i].sh_type == SHT_SYMTAB )
4191       break;
4192
4193   if( i == ehdr->e_shnum )
4194   {
4195     errorBelch( "This ELF file contains no symtab" );
4196     return 0;
4197   }
4198
4199   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
4200   {
4201     errorBelch( "The entry size (%d) of the symtab isn't %d\n",
4202       (int) shdr[i].sh_entsize, (int) sizeof( Elf_Sym ) );
4203
4204     return 0;
4205   }
4206
4207   return ocAllocateSymbolExtras( oc, shdr[i].sh_size / sizeof( Elf_Sym ), 0 );
4208 }
4209
4210 #endif /* powerpc */
4211
4212 #endif /* ELF */
4213
4214 /* --------------------------------------------------------------------------
4215  * Mach-O specifics
4216  * ------------------------------------------------------------------------*/
4217
4218 #if defined(OBJFORMAT_MACHO)
4219
4220 /*
4221   Support for MachO linking on Darwin/MacOS X
4222   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
4223
4224   I hereby formally apologize for the hackish nature of this code.
4225   Things that need to be done:
4226   *) implement ocVerifyImage_MachO
4227   *) add still more sanity checks.
4228 */
4229
4230 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
4231 #define mach_header mach_header_64
4232 #define segment_command segment_command_64
4233 #define section section_64
4234 #define nlist nlist_64
4235 #endif
4236
4237 #ifdef powerpc_HOST_ARCH
4238 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
4239 {
4240     struct mach_header *header = (struct mach_header *) oc->image;
4241     struct load_command *lc = (struct load_command *) (header + 1);
4242     unsigned i;
4243
4244     for( i = 0; i < header->ncmds; i++ )
4245     {
4246         if( lc->cmd == LC_SYMTAB )
4247         {
4248                 // Find out the first and last undefined external
4249                 // symbol, so we don't have to allocate too many
4250                 // jump islands.
4251             struct symtab_command *symLC = (struct symtab_command *) lc;
4252             unsigned min = symLC->nsyms, max = 0;
4253             struct nlist *nlist =
4254                 symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
4255                       : NULL;
4256             for(i=0;i<symLC->nsyms;i++)
4257             {
4258                 if(nlist[i].n_type & N_STAB)
4259                     ;
4260                 else if(nlist[i].n_type & N_EXT)
4261                 {
4262                     if((nlist[i].n_type & N_TYPE) == N_UNDF
4263                         && (nlist[i].n_value == 0))
4264                     {
4265                         if(i < min)
4266                             min = i;
4267                         if(i > max)
4268                             max = i;
4269                     }
4270                 }
4271             }
4272             if(max >= min)
4273                 return ocAllocateSymbolExtras(oc, max - min + 1, min);
4274
4275             break;
4276         }
4277
4278         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
4279     }
4280     return ocAllocateSymbolExtras(oc,0,0);
4281 }
4282 #endif
4283 #ifdef x86_64_HOST_ARCH
4284 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
4285 {
4286     struct mach_header *header = (struct mach_header *) oc->image;
4287     struct load_command *lc = (struct load_command *) (header + 1);
4288     unsigned i;
4289
4290     for( i = 0; i < header->ncmds; i++ )
4291     {
4292         if( lc->cmd == LC_SYMTAB )
4293         {
4294                 // Just allocate one entry for every symbol
4295             struct symtab_command *symLC = (struct symtab_command *) lc;
4296
4297             return ocAllocateSymbolExtras(oc, symLC->nsyms, 0);
4298         }
4299
4300         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
4301     }
4302     return ocAllocateSymbolExtras(oc,0,0);
4303 }
4304 #endif
4305
4306 static int ocVerifyImage_MachO(ObjectCode* oc)
4307 {
4308     char *image = (char*) oc->image;
4309     struct mach_header *header = (struct mach_header*) image;
4310
4311 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
4312     if(header->magic != MH_MAGIC_64) {
4313         errorBelch("%s: Bad magic. Expected: %08x, got: %08x.\n",
4314                    oc->fileName, MH_MAGIC_64, header->magic);
4315         return 0;
4316     }
4317 #else
4318     if(header->magic != MH_MAGIC) {
4319         errorBelch("%s: Bad magic. Expected: %08x, got: %08x.\n",
4320                    oc->fileName, MH_MAGIC, header->magic);
4321         return 0;
4322     }
4323 #endif
4324     // FIXME: do some more verifying here
4325     return 1;
4326 }
4327
4328 static int resolveImports(
4329     ObjectCode* oc,
4330     char *image,
4331     struct symtab_command *symLC,
4332     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
4333     unsigned long *indirectSyms,
4334     struct nlist *nlist)
4335 {
4336     unsigned i;
4337     size_t itemSize = 4;
4338
4339 #if i386_HOST_ARCH
4340     int isJumpTable = 0;
4341     if(!strcmp(sect->sectname,"__jump_table"))
4342     {
4343         isJumpTable = 1;
4344         itemSize = 5;
4345         ASSERT(sect->reserved2 == itemSize);
4346     }
4347 #endif
4348
4349     for(i=0; i*itemSize < sect->size;i++)
4350     {
4351         // according to otool, reserved1 contains the first index into the indirect symbol table
4352         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
4353         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4354         void *addr = NULL;
4355
4356         if((symbol->n_type & N_TYPE) == N_UNDF
4357             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
4358             addr = (void*) (symbol->n_value);
4359         else
4360             addr = lookupSymbol(nm);
4361         if(!addr)
4362         {
4363             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
4364             return 0;
4365         }
4366         ASSERT(addr);
4367
4368 #if i386_HOST_ARCH
4369         if(isJumpTable)
4370         {
4371             checkProddableBlock(oc,image + sect->offset + i*itemSize);
4372             *(image + sect->offset + i*itemSize) = 0xe9; // jmp
4373             *(unsigned*)(image + sect->offset + i*itemSize + 1)
4374                 = (char*)addr - (image + sect->offset + i*itemSize + 5);
4375         }
4376         else
4377 #endif
4378         {
4379             checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
4380             ((void**)(image + sect->offset))[i] = addr;
4381         }
4382     }
4383
4384     return 1;
4385 }
4386
4387 static unsigned long relocateAddress(
4388     ObjectCode* oc,
4389     int nSections,
4390     struct section* sections,
4391     unsigned long address)
4392 {
4393     int i;
4394     for(i = 0; i < nSections; i++)
4395     {
4396         if(sections[i].addr <= address
4397             && address < sections[i].addr + sections[i].size)
4398         {
4399             return (unsigned long)oc->image
4400                     + sections[i].offset + address - sections[i].addr;
4401         }
4402     }
4403     barf("Invalid Mach-O file:"
4404          "Address out of bounds while relocating object file");
4405     return 0;
4406 }
4407
4408 static int relocateSection(
4409     ObjectCode* oc,
4410     char *image,
4411     struct symtab_command *symLC, struct nlist *nlist,
4412     int nSections, struct section* sections, struct section *sect)
4413 {
4414     struct relocation_info *relocs;
4415     int i,n;
4416
4417     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
4418         return 1;
4419     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
4420         return 1;
4421     else if(!strcmp(sect->sectname,"__la_sym_ptr2"))
4422         return 1;
4423     else if(!strcmp(sect->sectname,"__la_sym_ptr3"))
4424         return 1;
4425
4426     n = sect->nreloc;
4427     relocs = (struct relocation_info*) (image + sect->reloff);
4428
4429     for(i=0;i<n;i++)
4430     {
4431 #ifdef x86_64_HOST_ARCH
4432         struct relocation_info *reloc = &relocs[i];
4433
4434         char    *thingPtr = image + sect->offset + reloc->r_address;
4435         uint64_t thing;
4436         /* We shouldn't need to initialise this, but gcc on OS X 64 bit
4437            complains that it may be used uninitialized if we don't */
4438         uint64_t value = 0;
4439         uint64_t baseValue;
4440         int type = reloc->r_type;
4441
4442         checkProddableBlock(oc,thingPtr);
4443         switch(reloc->r_length)
4444         {
4445             case 0:
4446                 thing = *(uint8_t*)thingPtr;
4447                 baseValue = (uint64_t)thingPtr + 1;
4448                 break;
4449             case 1:
4450                 thing = *(uint16_t*)thingPtr;
4451                 baseValue = (uint64_t)thingPtr + 2;
4452                 break;
4453             case 2:
4454                 thing = *(uint32_t*)thingPtr;
4455                 baseValue = (uint64_t)thingPtr + 4;
4456                 break;
4457             case 3:
4458                 thing = *(uint64_t*)thingPtr;
4459                 baseValue = (uint64_t)thingPtr + 8;
4460                 break;
4461             default:
4462                 barf("Unknown size.");
4463         }
4464
4465         if(type == X86_64_RELOC_GOT
4466            || type == X86_64_RELOC_GOT_LOAD)
4467         {
4468             ASSERT(reloc->r_extern);
4469             value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)->addr;
4470
4471             type = X86_64_RELOC_SIGNED;
4472         }
4473         else if(reloc->r_extern)
4474         {
4475             struct nlist *symbol = &nlist[reloc->r_symbolnum];
4476             char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4477             if(symbol->n_value == 0)
4478                 value = (uint64_t) lookupSymbol(nm);
4479             else
4480                 value = relocateAddress(oc, nSections, sections,
4481                                         symbol->n_value);
4482         }
4483         else
4484         {
4485             value = sections[reloc->r_symbolnum-1].offset
4486                   - sections[reloc->r_symbolnum-1].addr
4487                   + (uint64_t) image;
4488         }
4489
4490         if(type == X86_64_RELOC_BRANCH)
4491         {
4492             if((int32_t)(value - baseValue) != (int64_t)(value - baseValue))
4493             {
4494                 ASSERT(reloc->r_extern);
4495                 value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)
4496                                         -> jumpIsland;
4497             }
4498             ASSERT((int32_t)(value - baseValue) == (int64_t)(value - baseValue));
4499             type = X86_64_RELOC_SIGNED;
4500         }
4501
4502         switch(type)
4503         {
4504             case X86_64_RELOC_UNSIGNED:
4505                 ASSERT(!reloc->r_pcrel);
4506                 thing += value;
4507                 break;
4508             case X86_64_RELOC_SIGNED:
4509             case X86_64_RELOC_SIGNED_1:
4510             case X86_64_RELOC_SIGNED_2:
4511             case X86_64_RELOC_SIGNED_4:
4512                 ASSERT(reloc->r_pcrel);
4513                 thing += value - baseValue;
4514                 break;
4515             case X86_64_RELOC_SUBTRACTOR:
4516                 ASSERT(!reloc->r_pcrel);
4517                 thing -= value;
4518                 break;
4519             default:
4520                 barf("unkown relocation");
4521         }
4522
4523         switch(reloc->r_length)
4524         {
4525             case 0:
4526                 *(uint8_t*)thingPtr = thing;
4527                 break;
4528             case 1:
4529                 *(uint16_t*)thingPtr = thing;
4530                 break;
4531             case 2:
4532                 *(uint32_t*)thingPtr = thing;
4533                 break;
4534             case 3:
4535                 *(uint64_t*)thingPtr = thing;
4536                 break;
4537         }
4538 #else
4539         if(relocs[i].r_address & R_SCATTERED)
4540         {
4541             struct scattered_relocation_info *scat =
4542                 (struct scattered_relocation_info*) &relocs[i];
4543
4544             if(!scat->r_pcrel)
4545             {
4546                 if(scat->r_length == 2)
4547                 {
4548                     unsigned long word = 0;
4549                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
4550                     checkProddableBlock(oc,wordPtr);
4551
4552                     // Note on relocation types:
4553                     // i386 uses the GENERIC_RELOC_* types,
4554                     // while ppc uses special PPC_RELOC_* types.
4555                     // *_RELOC_VANILLA and *_RELOC_PAIR have the same value
4556                     // in both cases, all others are different.
4557                     // Therefore, we use GENERIC_RELOC_VANILLA
4558                     // and GENERIC_RELOC_PAIR instead of the PPC variants,
4559                     // and use #ifdefs for the other types.
4560
4561                     // Step 1: Figure out what the relocated value should be
4562                     if(scat->r_type == GENERIC_RELOC_VANILLA)
4563                     {
4564                         word = *wordPtr + (unsigned long) relocateAddress(
4565                                                                 oc,
4566                                                                 nSections,
4567                                                                 sections,
4568                                                                 scat->r_value)
4569                                         - scat->r_value;
4570                     }
4571 #ifdef powerpc_HOST_ARCH
4572                     else if(scat->r_type == PPC_RELOC_SECTDIFF
4573                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
4574                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
4575                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF
4576                         || scat->r_type == PPC_RELOC_LOCAL_SECTDIFF)
4577 #else
4578                     else if(scat->r_type == GENERIC_RELOC_SECTDIFF
4579                         || scat->r_type == GENERIC_RELOC_LOCAL_SECTDIFF)
4580 #endif
4581                     {
4582                         struct scattered_relocation_info *pair =
4583                                 (struct scattered_relocation_info*) &relocs[i+1];
4584
4585                         if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR)
4586                             barf("Invalid Mach-O file: "
4587                                  "RELOC_*_SECTDIFF not followed by RELOC_PAIR");
4588
4589                         word = (unsigned long)
4590                                (relocateAddress(oc, nSections, sections, scat->r_value)
4591                               - relocateAddress(oc, nSections, sections, pair->r_value));
4592                         i++;
4593                     }
4594 #ifdef powerpc_HOST_ARCH
4595                     else if(scat->r_type == PPC_RELOC_HI16
4596                          || scat->r_type == PPC_RELOC_LO16
4597                          || scat->r_type == PPC_RELOC_HA16
4598                          || scat->r_type == PPC_RELOC_LO14)
4599                     {   // these are generated by label+offset things
4600                         struct relocation_info *pair = &relocs[i+1];
4601                         if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
4602                             barf("Invalid Mach-O file: "
4603                                  "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
4604
4605                         if(scat->r_type == PPC_RELOC_LO16)
4606                         {
4607                             word = ((unsigned short*) wordPtr)[1];
4608                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4609                         }
4610                         else if(scat->r_type == PPC_RELOC_LO14)
4611                         {
4612                             barf("Unsupported Relocation: PPC_RELOC_LO14");
4613                             word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
4614                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4615                         }
4616                         else if(scat->r_type == PPC_RELOC_HI16)
4617                         {
4618                             word = ((unsigned short*) wordPtr)[1] << 16;
4619                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4620                         }
4621                         else if(scat->r_type == PPC_RELOC_HA16)
4622                         {
4623                             word = ((unsigned short*) wordPtr)[1] << 16;
4624                             word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4625                         }
4626
4627
4628                         word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
4629                                                 - scat->r_value;
4630
4631                         i++;
4632                     }
4633  #endif
4634                     else
4635                     {
4636                         barf ("Don't know how to handle this Mach-O "
4637                               "scattered relocation entry: "
4638                               "object file %s; entry type %ld; "
4639                               "address %#lx\n",
4640                               oc->fileName, scat->r_type, scat->r_address);
4641                         return 0;
4642                      }
4643
4644 #ifdef powerpc_HOST_ARCH
4645                     if(scat->r_type == GENERIC_RELOC_VANILLA
4646                         || scat->r_type == PPC_RELOC_SECTDIFF)
4647 #else
4648                     if(scat->r_type == GENERIC_RELOC_VANILLA
4649                         || scat->r_type == GENERIC_RELOC_SECTDIFF
4650                         || scat->r_type == GENERIC_RELOC_LOCAL_SECTDIFF)
4651 #endif
4652                     {
4653                         *wordPtr = word;
4654                     }
4655 #ifdef powerpc_HOST_ARCH
4656                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
4657                     {
4658                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4659                     }
4660                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
4661                     {
4662                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4663                     }
4664                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
4665                     {
4666                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4667                             + ((word & (1<<15)) ? 1 : 0);
4668                     }
4669 #endif
4670                 }
4671                 else
4672                 {
4673                     barf("Can't handle Mach-O scattered relocation entry "
4674                          "with this r_length tag: "
4675                          "object file %s; entry type %ld; "
4676                          "r_length tag %ld; address %#lx\n",
4677                          oc->fileName, scat->r_type, scat->r_length,
4678                          scat->r_address);
4679                     return 0;
4680                 }
4681             }
4682             else /* scat->r_pcrel */
4683             {
4684                 barf("Don't know how to handle *PC-relative* Mach-O "
4685                      "scattered relocation entry: "
4686                      "object file %s; entry type %ld; address %#lx\n",
4687                      oc->fileName, scat->r_type, scat->r_address);
4688                return 0;
4689             }
4690
4691         }
4692         else /* !(relocs[i].r_address & R_SCATTERED) */
4693         {
4694             struct relocation_info *reloc = &relocs[i];
4695             if(reloc->r_pcrel && !reloc->r_extern)
4696                 continue;
4697
4698             if(reloc->r_length == 2)
4699             {
4700                 unsigned long word = 0;
4701 #ifdef powerpc_HOST_ARCH
4702                 unsigned long jumpIsland = 0;
4703                 long offsetToJumpIsland = 0xBADBAD42; // initialise to bad value
4704                                                       // to avoid warning and to catch
4705                                                       // bugs.
4706 #endif
4707
4708                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
4709                 checkProddableBlock(oc,wordPtr);
4710
4711                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4712                 {
4713                     word = *wordPtr;
4714                 }
4715 #ifdef powerpc_HOST_ARCH
4716                 else if(reloc->r_type == PPC_RELOC_LO16)
4717                 {
4718                     word = ((unsigned short*) wordPtr)[1];
4719                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4720                 }
4721                 else if(reloc->r_type == PPC_RELOC_HI16)
4722                 {
4723                     word = ((unsigned short*) wordPtr)[1] << 16;
4724                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4725                 }
4726                 else if(reloc->r_type == PPC_RELOC_HA16)
4727                 {
4728                     word = ((unsigned short*) wordPtr)[1] << 16;
4729                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4730                 }
4731                 else if(reloc->r_type == PPC_RELOC_BR24)
4732                 {
4733                     word = *wordPtr;
4734                     word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0);
4735                 }
4736 #endif
4737                 else
4738                 {
4739                     barf("Can't handle this Mach-O relocation entry "
4740                          "(not scattered): "
4741                          "object file %s; entry type %ld; address %#lx\n",
4742                          oc->fileName, reloc->r_type, reloc->r_address);
4743                     return 0;
4744                 }
4745
4746                 if(!reloc->r_extern)
4747                 {
4748                     long delta =
4749                         sections[reloc->r_symbolnum-1].offset
4750                         - sections[reloc->r_symbolnum-1].addr
4751                         + ((long) image);
4752
4753                     word += delta;
4754                 }
4755                 else
4756                 {
4757                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
4758                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4759                     void *symbolAddress = lookupSymbol(nm);
4760                     if(!symbolAddress)
4761                     {
4762                         errorBelch("\nunknown symbol `%s'", nm);
4763                         return 0;
4764                     }
4765
4766                     if(reloc->r_pcrel)
4767                     {
4768 #ifdef powerpc_HOST_ARCH
4769                             // In the .o file, this should be a relative jump to NULL
4770                             // and we'll change it to a relative jump to the symbol
4771                         ASSERT(word + reloc->r_address == 0);
4772                         jumpIsland = (unsigned long)
4773                                         &makeSymbolExtra(oc,
4774                                                          reloc->r_symbolnum,
4775                                                          (unsigned long) symbolAddress)
4776                                          -> jumpIsland;
4777                         if(jumpIsland != 0)
4778                         {
4779                             offsetToJumpIsland = word + jumpIsland
4780                                 - (((long)image) + sect->offset - sect->addr);
4781                         }
4782 #endif
4783                         word += (unsigned long) symbolAddress
4784                                 - (((long)image) + sect->offset - sect->addr);
4785                     }
4786                     else
4787                     {
4788                         word += (unsigned long) symbolAddress;
4789                     }
4790                 }
4791
4792                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4793                 {
4794                     *wordPtr = word;
4795                     continue;
4796                 }
4797 #ifdef powerpc_HOST_ARCH
4798                 else if(reloc->r_type == PPC_RELOC_LO16)
4799                 {
4800                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4801                     i++; continue;
4802                 }
4803                 else if(reloc->r_type == PPC_RELOC_HI16)
4804                 {
4805                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4806                     i++; continue;
4807                 }
4808                 else if(reloc->r_type == PPC_RELOC_HA16)
4809                 {
4810                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4811                         + ((word & (1<<15)) ? 1 : 0);
4812                     i++; continue;
4813                 }
4814                 else if(reloc->r_type == PPC_RELOC_BR24)
4815                 {
4816                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4817                     {
4818                         // The branch offset is too large.
4819                         // Therefore, we try to use a jump island.
4820                         if(jumpIsland == 0)
4821                         {
4822                             barf("unconditional relative branch out of range: "
4823                                  "no jump island available");
4824                         }
4825
4826                         word = offsetToJumpIsland;
4827                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4828                             barf("unconditional relative branch out of range: "
4829                                  "jump island out of range");
4830                     }
4831                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
4832                     continue;
4833                 }
4834 #endif
4835             }
4836             else
4837             {
4838                  barf("Can't handle Mach-O relocation entry (not scattered) "
4839                       "with this r_length tag: "
4840                       "object file %s; entry type %ld; "
4841                       "r_length tag %ld; address %#lx\n",
4842                       oc->fileName, reloc->r_type, reloc->r_length,
4843                       reloc->r_address);
4844                  return 0;
4845             }
4846         }
4847 #endif
4848     }
4849     return 1;
4850 }
4851
4852 static int ocGetNames_MachO(ObjectCode* oc)
4853 {
4854     char *image = (char*) oc->image;
4855     struct mach_header *header = (struct mach_header*) image;
4856     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4857     unsigned i,curSymbol = 0;
4858     struct segment_command *segLC = NULL;
4859     struct section *sections;
4860     struct symtab_command *symLC = NULL;
4861     struct nlist *nlist;
4862     unsigned long commonSize = 0;
4863     char    *commonStorage = NULL;
4864     unsigned long commonCounter;
4865
4866     IF_DEBUG(linker,debugBelch("ocGetNames_MachO\n"));
4867
4868     for(i=0;i<header->ncmds;i++)
4869     {
4870         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4871             segLC = (struct segment_command*) lc;
4872         else if(lc->cmd == LC_SYMTAB)
4873             symLC = (struct symtab_command*) lc;
4874         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4875     }
4876
4877     sections = (struct section*) (segLC+1);
4878     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4879                   : NULL;
4880
4881     if(!segLC)
4882         barf("ocGetNames_MachO: no segment load command");
4883
4884     for(i=0;i<segLC->nsects;i++)
4885     {
4886         if(sections[i].size == 0)
4887             continue;
4888
4889         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
4890         {
4891             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
4892                                       "ocGetNames_MachO(common symbols)");
4893             sections[i].offset = zeroFillArea - image;
4894         }
4895
4896         if(!strcmp(sections[i].sectname,"__text"))
4897             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
4898                 (void*) (image + sections[i].offset),
4899                 (void*) (image + sections[i].offset + sections[i].size));
4900         else if(!strcmp(sections[i].sectname,"__const"))
4901             addSection(oc, SECTIONKIND_RWDATA,
4902                 (void*) (image + sections[i].offset),
4903                 (void*) (image + sections[i].offset + sections[i].size));
4904         else if(!strcmp(sections[i].sectname,"__data"))
4905             addSection(oc, SECTIONKIND_RWDATA,
4906                 (void*) (image + sections[i].offset),
4907                 (void*) (image + sections[i].offset + sections[i].size));
4908         else if(!strcmp(sections[i].sectname,"__bss")
4909                 || !strcmp(sections[i].sectname,"__common"))
4910             addSection(oc, SECTIONKIND_RWDATA,
4911                 (void*) (image + sections[i].offset),
4912                 (void*) (image + sections[i].offset + sections[i].size));
4913
4914         addProddableBlock(oc, (void*) (image + sections[i].offset),
4915                                         sections[i].size);
4916     }
4917
4918         // count external symbols defined here
4919     oc->n_symbols = 0;
4920     if(symLC)
4921     {
4922         for(i=0;i<symLC->nsyms;i++)
4923         {
4924             if(nlist[i].n_type & N_STAB)
4925                 ;
4926             else if(nlist[i].n_type & N_EXT)
4927             {
4928                 if((nlist[i].n_type & N_TYPE) == N_UNDF
4929                     && (nlist[i].n_value != 0))
4930                 {
4931                     commonSize += nlist[i].n_value;
4932                     oc->n_symbols++;
4933                 }
4934                 else if((nlist[i].n_type & N_TYPE) == N_SECT)
4935                     oc->n_symbols++;
4936             }
4937         }
4938     }
4939     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
4940                                    "ocGetNames_MachO(oc->symbols)");
4941
4942     if(symLC)
4943     {
4944         for(i=0;i<symLC->nsyms;i++)
4945         {
4946             if(nlist[i].n_type & N_STAB)
4947                 ;
4948             else if((nlist[i].n_type & N_TYPE) == N_SECT)
4949             {
4950                 if(nlist[i].n_type & N_EXT)
4951                 {
4952                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4953                     if((nlist[i].n_desc & N_WEAK_DEF) && lookupSymbol(nm))
4954                         ; // weak definition, and we already have a definition
4955                     else
4956                     {
4957                             IF_DEBUG(linker,debugBelch("Adding symbol 1 %s\n", nm));
4958                             ghciInsertStrHashTable(oc->fileName, symhash, nm,
4959                                                     image
4960                                                     + sections[nlist[i].n_sect-1].offset
4961                                                     - sections[nlist[i].n_sect-1].addr
4962                                                     + nlist[i].n_value);
4963                             oc->symbols[curSymbol++] = nm;
4964                     }
4965                 }
4966             }
4967         }
4968     }
4969
4970     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
4971     commonCounter = (unsigned long)commonStorage;
4972     if(symLC)
4973     {
4974         for(i=0;i<symLC->nsyms;i++)
4975         {
4976             if((nlist[i].n_type & N_TYPE) == N_UNDF
4977                     && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
4978             {
4979                 char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4980                 unsigned long sz = nlist[i].n_value;
4981
4982                 nlist[i].n_value = commonCounter;
4983
4984             IF_DEBUG(linker,debugBelch("Adding symbol 2 %s\n", nm));
4985                 ghciInsertStrHashTable(oc->fileName, symhash, nm,
4986                                        (void*)commonCounter);
4987                 oc->symbols[curSymbol++] = nm;
4988
4989                 commonCounter += sz;
4990             }
4991         }
4992     }
4993     return 1;
4994 }
4995
4996 static int ocResolve_MachO(ObjectCode* oc)
4997 {
4998     char *image = (char*) oc->image;
4999     struct mach_header *header = (struct mach_header*) image;
5000     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
5001     unsigned i;
5002     struct segment_command *segLC = NULL;
5003     struct section *sections;
5004     struct symtab_command *symLC = NULL;
5005     struct dysymtab_command *dsymLC = NULL;
5006     struct nlist *nlist;
5007
5008     for(i=0;i<header->ncmds;i++)
5009     {
5010         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
5011             segLC = (struct segment_command*) lc;
5012         else if(lc->cmd == LC_SYMTAB)
5013             symLC = (struct symtab_command*) lc;
5014         else if(lc->cmd == LC_DYSYMTAB)
5015             dsymLC = (struct dysymtab_command*) lc;
5016         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
5017     }
5018
5019     sections = (struct section*) (segLC+1);
5020     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
5021                   : NULL;
5022
5023     if(dsymLC)
5024     {
5025         unsigned long *indirectSyms
5026             = (unsigned long*) (image + dsymLC->indirectsymoff);
5027
5028         for(i=0;i<segLC->nsects;i++)
5029         {
5030             if(    !strcmp(sections[i].sectname,"__la_symbol_ptr")
5031                 || !strcmp(sections[i].sectname,"__la_sym_ptr2")
5032                 || !strcmp(sections[i].sectname,"__la_sym_ptr3"))
5033             {
5034                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
5035                     return 0;
5036             }
5037             else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr")
5038                 ||  !strcmp(sections[i].sectname,"__pointers"))
5039             {
5040                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
5041                     return 0;
5042             }
5043             else if(!strcmp(sections[i].sectname,"__jump_table"))
5044             {
5045                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
5046                     return 0;
5047             }
5048         }
5049     }
5050
5051     for(i=0;i<segLC->nsects;i++)
5052     {
5053         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
5054             return 0;
5055     }
5056
5057 #if defined (powerpc_HOST_ARCH)
5058     ocFlushInstructionCache( oc );
5059 #endif
5060
5061     return 1;
5062 }
5063
5064 #ifdef powerpc_HOST_ARCH
5065 /*
5066  * The Mach-O object format uses leading underscores. But not everywhere.
5067  * There is a small number of runtime support functions defined in
5068  * libcc_dynamic.a whose name does not have a leading underscore.
5069  * As a consequence, we can't get their address from C code.
5070  * We have to use inline assembler just to take the address of a function.
5071  * Yuck.
5072  */
5073
5074 extern void* symbolsWithoutUnderscore[];
5075
5076 static void machoInitSymbolsWithoutUnderscore()
5077 {
5078     void **p = symbolsWithoutUnderscore;
5079     __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:");
5080
5081 #undef SymI_NeedsProto
5082 #define SymI_NeedsProto(x)  \
5083     __asm__ volatile(".long " # x);
5084
5085     RTS_MACHO_NOUNDERLINE_SYMBOLS
5086
5087     __asm__ volatile(".text");
5088
5089 #undef SymI_NeedsProto
5090 #define SymI_NeedsProto(x)  \
5091     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
5092
5093     RTS_MACHO_NOUNDERLINE_SYMBOLS
5094
5095 #undef SymI_NeedsProto
5096 }
5097 #endif
5098
5099 #ifndef USE_MMAP
5100 /*
5101  * Figure out by how much to shift the entire Mach-O file in memory
5102  * when loading so that its single segment ends up 16-byte-aligned
5103  */
5104 static int machoGetMisalignment( FILE * f )
5105 {
5106     struct mach_header header;
5107     int misalignment;
5108
5109     fread(&header, sizeof(header), 1, f);
5110     rewind(f);
5111
5112 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
5113     if(header.magic != MH_MAGIC_64) {
5114         errorBelch("Bad magic. Expected: %08x, got: %08x.\n",
5115                    MH_MAGIC_64, header->magic);
5116         return 0;
5117     }
5118 #else
5119     if(header.magic != MH_MAGIC) {
5120         errorBelch("Bad magic. Expected: %08x, got: %08x.\n",
5121                    MH_MAGIC, header->magic);
5122         return 0;
5123     }
5124 #endif
5125
5126     misalignment = (header.sizeofcmds + sizeof(header))
5127                     & 0xF;
5128
5129     return misalignment ? (16 - misalignment) : 0;
5130 }
5131 #endif
5132
5133 #endif