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