rts/Linker.c

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