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