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