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