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