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