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        if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
1070        // KAA: allow loading of drivers (like winspool.drv)
1071        sprintf(buf, "%s.DRV", dll_name);
1072        instance = LoadLibrary(buf);
1073        if (instance == NULL) {
1074            if (GetLastError() != ERROR_MOD_NOT_FOUND) goto error;
1075            // #1883: allow loading of unix-style libfoo.dll DLLs
1076            sprintf(buf, "lib%s.DLL", dll_name);
1077            instance = LoadLibrary(buf);
1078            if (instance == NULL) {
1079                goto error;
1080            }
1081        }
1082    }
1083    stgFree(buf);
1084
1085    /* Add this DLL to the list of DLLs in which to search for symbols. */
1086    o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
1087    o_dll->name     = stgMallocBytes(1+strlen(dll_name), "addDLL");
1088    strcpy(o_dll->name, dll_name);
1089    o_dll->instance = instance;
1090    o_dll->next     = opened_dlls;
1091    opened_dlls     = o_dll;
1092
1093    return NULL;
1094
1095 error:
1096    stgFree(buf);
1097    sysErrorBelch(dll_name);
1098
1099    /* LoadLibrary failed; return a ptr to the error msg. */
1100    return "addDLL: could not load DLL";
1101
1102 #  else
1103    barf("addDLL: not implemented on this platform");
1104 #  endif
1105 }
1106
1107 /* -----------------------------------------------------------------------------
1108  * insert a stable symbol in the hash table
1109  */
1110
1111 void
1112 insertStableSymbol(char* obj_name, char* key, StgPtr p)
1113 {
1114   ghciInsertStrHashTable(obj_name, stablehash, key, getStablePtr(p));
1115 }
1116
1117
1118 /* -----------------------------------------------------------------------------
1119  * insert a symbol in the hash table
1120  */
1121 void
1122 insertSymbol(char* obj_name, char* key, void* data)
1123 {
1124   ghciInsertStrHashTable(obj_name, symhash, key, data);
1125 }
1126
1127 /* -----------------------------------------------------------------------------
1128  * lookup a symbol in the hash table
1129  */
1130 void *
1131 lookupSymbol( char *lbl )
1132 {
1133     void *val;
1134     initLinker() ;
1135     ASSERT(symhash != NULL);
1136     val = lookupStrHashTable(symhash, lbl);
1137
1138     if (val == NULL) {
1139 #       if defined(OBJFORMAT_ELF)
1140         return dlsym(dl_prog_handle, lbl);
1141 #       elif defined(OBJFORMAT_MACHO)
1142 #       if HAVE_DLFCN_H
1143         /* On OS X 10.3 and later, we use dlsym instead of the old legacy
1144            interface.
1145
1146            HACK: On OS X, global symbols are prefixed with an underscore.
1147                  However, dlsym wants us to omit the leading underscore from the
1148                  symbol name. For now, we simply strip it off here (and ONLY
1149                  here).
1150         */
1151         ASSERT(lbl[0] == '_');
1152         return dlsym(dl_prog_handle, lbl+1);
1153 #       else
1154         if(NSIsSymbolNameDefined(lbl)) {
1155             NSSymbol symbol = NSLookupAndBindSymbol(lbl);
1156             return NSAddressOfSymbol(symbol);
1157         } else {
1158             return NULL;
1159         }
1160 #       endif /* HAVE_DLFCN_H */
1161 #       elif defined(OBJFORMAT_PEi386)
1162         OpenedDLL* o_dll;
1163         void* sym;
1164         for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
1165           /* debugBelch("look in %s for %s\n", o_dll->name, lbl); */
1166            if (lbl[0] == '_') {
1167               /* HACK: if the name has an initial underscore, try stripping
1168                  it off & look that up first. I've yet to verify whether there's
1169                  a Rule that governs whether an initial '_' *should always* be
1170                  stripped off when mapping from import lib name to the DLL name.
1171               */
1172               sym = GetProcAddress(o_dll->instance, (lbl+1));
1173               if (sym != NULL) {
1174                 /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
1175                 return sym;
1176               }
1177            }
1178            sym = GetProcAddress(o_dll->instance, lbl);
1179            if (sym != NULL) {
1180              /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
1181              return sym;
1182            }
1183         }
1184         return NULL;
1185 #       else
1186         ASSERT(2+2 == 5);
1187         return NULL;
1188 #       endif
1189     } else {
1190         return val;
1191     }
1192 }
1193
1194 /* -----------------------------------------------------------------------------
1195  * Debugging aid: look in GHCi's object symbol tables for symbols
1196  * within DELTA bytes of the specified address, and show their names.
1197  */
1198 #ifdef DEBUG
1199 void ghci_enquire ( char* addr );
1200
1201 void ghci_enquire ( char* addr )
1202 {
1203    int   i;
1204    char* sym;
1205    char* a;
1206    const int DELTA = 64;
1207    ObjectCode* oc;
1208
1209    initLinker();
1210
1211    for (oc = objects; oc; oc = oc->next) {
1212       for (i = 0; i < oc->n_symbols; i++) {
1213          sym = oc->symbols[i];
1214          if (sym == NULL) continue;
1215          a = NULL;
1216          if (a == NULL) {
1217             a = lookupStrHashTable(symhash, sym);
1218          }
1219          if (a == NULL) {
1220              // debugBelch("ghci_enquire: can't find %s\n", sym);
1221          }
1222          else if (addr-DELTA <= a && a <= addr+DELTA) {
1223             debugBelch("%p + %3d  ==  `%s'\n", addr, (int)(a - addr), sym);
1224          }
1225       }
1226    }
1227 }
1228 #endif
1229
1230 #ifdef ia64_HOST_ARCH
1231 static unsigned int PLTSize(void);
1232 #endif
1233
1234 /* -----------------------------------------------------------------------------
1235  * Load an obj (populate the global symbol table, but don't resolve yet)
1236  *
1237  * Returns: 1 if ok, 0 on error.
1238  */
1239 HsInt
1240 loadObj( char *path )
1241 {
1242    ObjectCode* oc;
1243    struct stat st;
1244    int r, n;
1245 #ifdef USE_MMAP
1246    int fd, pagesize;
1247    void *map_addr = NULL;
1248 #else
1249    FILE *f;
1250 #endif
1251    initLinker();
1252
1253    /* debugBelch("loadObj %s\n", path ); */
1254
1255    /* Check that we haven't already loaded this object.
1256       Ignore requests to load multiple times */
1257    {
1258        ObjectCode *o;
1259        int is_dup = 0;
1260        for (o = objects; o; o = o->next) {
1261           if (0 == strcmp(o->fileName, path)) {
1262              is_dup = 1;
1263              break; /* don't need to search further */
1264           }
1265        }
1266        if (is_dup) {
1267           IF_DEBUG(linker, debugBelch(
1268             "GHCi runtime linker: warning: looks like you're trying to load the\n"
1269             "same object file twice:\n"
1270             "   %s\n"
1271             "GHCi will ignore this, but be warned.\n"
1272             , path));
1273           return 1; /* success */
1274        }
1275    }
1276
1277    oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)");
1278
1279 #  if defined(OBJFORMAT_ELF)
1280    oc->formatName = "ELF";
1281 #  elif defined(OBJFORMAT_PEi386)
1282    oc->formatName = "PEi386";
1283 #  elif defined(OBJFORMAT_MACHO)
1284    oc->formatName = "Mach-O";
1285 #  else
1286    stgFree(oc);
1287    barf("loadObj: not implemented on this platform");
1288 #  endif
1289
1290    r = stat(path, &st);
1291    if (r == -1) { return 0; }
1292
1293    /* sigh, strdup() isn't a POSIX function, so do it the long way */
1294    oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
1295    strcpy(oc->fileName, path);
1296
1297    oc->fileSize          = st.st_size;
1298    oc->symbols           = NULL;
1299    oc->sections          = NULL;
1300    oc->proddables        = NULL;
1301
1302    /* chain it onto the list of objects */
1303    oc->next              = objects;
1304    objects               = oc;
1305
1306 #ifdef USE_MMAP
1307 #define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))
1308
1309    /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
1310
1311 #if defined(openbsd_HOST_OS)
1312    fd = open(path, O_RDONLY, S_IRUSR);
1313 #else
1314    fd = open(path, O_RDONLY);
1315 #endif
1316    if (fd == -1)
1317       barf("loadObj: can't open `%s'", path);
1318
1319    pagesize = getpagesize();
1320
1321 #ifdef ia64_HOST_ARCH
1322    /* The PLT needs to be right before the object */
1323    n = ROUND_UP(PLTSize(), pagesize);
1324    oc->plt = mmap(NULL, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0);
1325    if (oc->plt == MAP_FAILED)
1326       barf("loadObj: can't allocate PLT");
1327
1328    oc->pltIndex = 0;
1329    map_addr = oc->plt + n;
1330 #endif
1331
1332    n = ROUND_UP(oc->fileSize, pagesize);
1333
1334    /* Link objects into the lower 2Gb on x86_64.  GHC assumes the
1335     * small memory model on this architecture (see gcc docs,
1336     * -mcmodel=small).
1337     *
1338     * MAP_32BIT not available on OpenBSD/amd64
1339     */
1340 #if defined(x86_64_HOST_ARCH) && defined(MAP_32BIT)
1341 #define EXTRA_MAP_FLAGS MAP_32BIT
1342 #else
1343 #define EXTRA_MAP_FLAGS 0
1344 #endif
1345
1346    /* MAP_ANONYMOUS is MAP_ANON on some systems, e.g. OpenBSD */
1347 #if !defined(MAP_ANONYMOUS) && defined(MAP_ANON)
1348 #define MAP_ANONYMOUS MAP_ANON
1349 #endif
1350
1351    oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE,
1352                     MAP_PRIVATE|EXTRA_MAP_FLAGS, fd, 0);
1353    if (oc->image == MAP_FAILED)
1354       barf("loadObj: can't map `%s'", path);
1355
1356    close(fd);
1357
1358 #else /* !USE_MMAP */
1359
1360    /* load the image into memory */
1361    f = fopen(path, "rb");
1362    if (!f)
1363        barf("loadObj: can't read `%s'", path);
1364
1365 #   if defined(mingw32_HOST_OS)
1366         // TODO: We would like to use allocateExec here, but allocateExec
1367         //       cannot currently allocate blocks large enough.
1368     oc->image = VirtualAlloc(NULL, oc->fileSize, MEM_RESERVE | MEM_COMMIT,
1369                              PAGE_EXECUTE_READWRITE);
1370 #   elif defined(darwin_HOST_OS)
1371     // In a Mach-O .o file, all sections can and will be misaligned
1372     // if the total size of the headers is not a multiple of the
1373     // desired alignment. This is fine for .o files that only serve
1374     // as input for the static linker, but it's not fine for us,
1375     // as SSE (used by gcc for floating point) and Altivec require
1376     // 16-byte alignment.
1377     // We calculate the correct alignment from the header before
1378     // reading the file, and then we misalign oc->image on purpose so
1379     // that the actual sections end up aligned again.
1380    oc->misalignment = machoGetMisalignment(f);
1381    oc->image = stgMallocBytes(oc->fileSize + oc->misalignment, "loadObj(image)");
1382    oc->image += oc->misalignment;
1383 #  else
1384    oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)");
1385 #  endif
1386
1387    n = fread ( oc->image, 1, oc->fileSize, f );
1388    if (n != oc->fileSize)
1389       barf("loadObj: error whilst reading `%s'", path);
1390
1391    fclose(f);
1392 #endif /* USE_MMAP */
1393
1394 #  if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1395    r = ocAllocateSymbolExtras_MachO ( oc );
1396    if (!r) { return r; }
1397 #  elif defined(OBJFORMAT_ELF) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1398    r = ocAllocateSymbolExtras_ELF ( oc );
1399    if (!r) { return r; }
1400 #endif
1401
1402    /* verify the in-memory image */
1403 #  if defined(OBJFORMAT_ELF)
1404    r = ocVerifyImage_ELF ( oc );
1405 #  elif defined(OBJFORMAT_PEi386)
1406    r = ocVerifyImage_PEi386 ( oc );
1407 #  elif defined(OBJFORMAT_MACHO)
1408    r = ocVerifyImage_MachO ( oc );
1409 #  else
1410    barf("loadObj: no verify method");
1411 #  endif
1412    if (!r) { return r; }
1413
1414    /* build the symbol list for this image */
1415 #  if defined(OBJFORMAT_ELF)
1416    r = ocGetNames_ELF ( oc );
1417 #  elif defined(OBJFORMAT_PEi386)
1418    r = ocGetNames_PEi386 ( oc );
1419 #  elif defined(OBJFORMAT_MACHO)
1420    r = ocGetNames_MachO ( oc );
1421 #  else
1422    barf("loadObj: no getNames method");
1423 #  endif
1424    if (!r) { return r; }
1425
1426    /* loaded, but not resolved yet */
1427    oc->status = OBJECT_LOADED;
1428
1429    return 1;
1430 }
1431
1432 /* -----------------------------------------------------------------------------
1433  * resolve all the currently unlinked objects in memory
1434  *
1435  * Returns: 1 if ok, 0 on error.
1436  */
1437 HsInt
1438 resolveObjs( void )
1439 {
1440     ObjectCode *oc;
1441     int r;
1442
1443     initLinker();
1444
1445     for (oc = objects; oc; oc = oc->next) {
1446         if (oc->status != OBJECT_RESOLVED) {
1447 #           if defined(OBJFORMAT_ELF)
1448             r = ocResolve_ELF ( oc );
1449 #           elif defined(OBJFORMAT_PEi386)
1450             r = ocResolve_PEi386 ( oc );
1451 #           elif defined(OBJFORMAT_MACHO)
1452             r = ocResolve_MachO ( oc );
1453 #           else
1454             barf("resolveObjs: not implemented on this platform");
1455 #           endif
1456             if (!r) { return r; }
1457             oc->status = OBJECT_RESOLVED;
1458         }
1459     }
1460     return 1;
1461 }
1462
1463 /* -----------------------------------------------------------------------------
1464  * delete an object from the pool
1465  */
1466 HsInt
1467 unloadObj( char *path )
1468 {
1469     ObjectCode *oc, *prev;
1470
1471     ASSERT(symhash != NULL);
1472     ASSERT(objects != NULL);
1473
1474     initLinker();
1475
1476     prev = NULL;
1477     for (oc = objects; oc; prev = oc, oc = oc->next) {
1478         if (!strcmp(oc->fileName,path)) {
1479
1480             /* Remove all the mappings for the symbols within this
1481              * object..
1482              */
1483             {
1484                 int i;
1485                 for (i = 0; i < oc->n_symbols; i++) {
1486                    if (oc->symbols[i] != NULL) {
1487                        removeStrHashTable(symhash, oc->symbols[i], NULL);
1488                    }
1489                 }
1490             }
1491
1492             if (prev == NULL) {
1493                 objects = oc->next;
1494             } else {
1495                 prev->next = oc->next;
1496             }
1497
1498             // We're going to leave this in place, in case there are
1499             // any pointers from the heap into it:
1500                 // #ifdef mingw32_HOST_OS
1501                 //  VirtualFree(oc->image);
1502                 // #else
1503             //  stgFree(oc->image);
1504             // #endif
1505             stgFree(oc->fileName);
1506             stgFree(oc->symbols);
1507             stgFree(oc->sections);
1508             stgFree(oc);
1509             return 1;
1510         }
1511     }
1512
1513     errorBelch("unloadObj: can't find `%s' to unload", path);
1514     return 0;
1515 }
1516
1517 /* -----------------------------------------------------------------------------
1518  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
1519  * which may be prodded during relocation, and abort if we try and write
1520  * outside any of these.
1521  */
1522 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
1523 {
1524    ProddableBlock* pb
1525       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
1526    /* debugBelch("aPB %p %p %d\n", oc, start, size); */
1527    ASSERT(size > 0);
1528    pb->start      = start;
1529    pb->size       = size;
1530    pb->next       = oc->proddables;
1531    oc->proddables = pb;
1532 }
1533
1534 static void checkProddableBlock ( ObjectCode* oc, void* addr )
1535 {
1536    ProddableBlock* pb;
1537    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
1538       char* s = (char*)(pb->start);
1539       char* e = s + pb->size - 1;
1540       char* a = (char*)addr;
1541       /* Assumes that the biggest fixup involves a 4-byte write.  This
1542          probably needs to be changed to 8 (ie, +7) on 64-bit
1543          plats. */
1544       if (a >= s && (a+3) <= e) return;
1545    }
1546    barf("checkProddableBlock: invalid fixup in runtime linker");
1547 }
1548
1549 /* -----------------------------------------------------------------------------
1550  * Section management.
1551  */
1552 static void addSection ( ObjectCode* oc, SectionKind kind,
1553                          void* start, void* end )
1554 {
1555    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
1556    s->start     = start;
1557    s->end       = end;
1558    s->kind      = kind;
1559    s->next      = oc->sections;
1560    oc->sections = s;
1561    /*
1562    debugBelch("addSection: %p-%p (size %d), kind %d\n",
1563                    start, ((char*)end)-1, end - start + 1, kind );
1564    */
1565 }
1566
1567
1568 /* --------------------------------------------------------------------------
1569  * Symbol Extras.
1570  * This is about allocating a small chunk of memory for every symbol in the
1571  * object file. We make sure that the SymboLExtras are always "in range" of
1572  * limited-range PC-relative instructions on various platforms by allocating
1573  * them right next to the object code itself.
1574  */
1575
1576 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
1577
1578 /*
1579   ocAllocateSymbolExtras
1580
1581   Allocate additional space at the end of the object file image to make room
1582   for jump islands (powerpc, x86_64) and GOT entries (x86_64).
1583
1584   PowerPC relative branch instructions have a 24 bit displacement field.
1585   As PPC code is always 4-byte-aligned, this yields a +-32MB range.
1586   If a particular imported symbol is outside this range, we have to redirect
1587   the jump to a short piece of new code that just loads the 32bit absolute
1588   address and jumps there.
1589   On x86_64, PC-relative jumps and PC-relative accesses to the GOT are limited
1590   to 32 bits (+-2GB).
1591
1592   This function just allocates space for one SymbolExtra for every
1593   undefined symbol in the object file. The code for the jump islands is
1594   filled in by makeSymbolExtra below.
1595 */
1596
1597 static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first )
1598 {
1599 #ifdef USE_MMAP
1600   int pagesize, n, m;
1601 #endif
1602   int aligned;
1603 #ifndef USE_MMAP
1604   int misalignment = 0;
1605 #ifdef darwin_HOST_OS
1606   misalignment = oc->misalignment;
1607 #endif
1608 #endif
1609
1610   if( count > 0 )
1611   {
1612     // round up to the nearest 4
1613     aligned = (oc->fileSize + 3) & ~3;
1614
1615 #ifdef USE_MMAP
1616     #ifndef linux_HOST_OS /* mremap is a linux extension */
1617         #error ocAllocateSymbolExtras doesnt want USE_MMAP to be defined
1618     #endif
1619
1620     pagesize = getpagesize();
1621     n = ROUND_UP( oc->fileSize, pagesize );
1622     m = ROUND_UP( aligned + sizeof (SymbolExtra) * count, pagesize );
1623
1624     /* If we have a half-page-size file and map one page of it then
1625      * the part of the page after the size of the file remains accessible.
1626      * If, however, we map in 2 pages, the 2nd page is not accessible
1627      * and will give a "Bus Error" on access.  To get around this, we check
1628      * if we need any extra pages for the jump islands and map them in
1629      * anonymously.  We must check that we actually require extra pages
1630      * otherwise the attempt to mmap 0 pages of anonymous memory will
1631      * fail -EINVAL.
1632      */
1633
1634     if( m > n )
1635     {
1636       /* The effect of this mremap() call is only the ensure that we have
1637        * a sufficient number of virtually contiguous pages.  As returned from
1638        * mremap, the pages past the end of the file are not backed.  We give
1639        * them a backing by using MAP_FIXED to map in anonymous pages.
1640        */
1641       oc->image = mremap( oc->image, n, m, MREMAP_MAYMOVE );
1642
1643       if( oc->image == MAP_FAILED )
1644       {
1645         errorBelch( "Unable to mremap for Jump Islands\n" );
1646         return 0;
1647       }
1648
1649       if( mmap( oc->image + n, m - n, PROT_READ | PROT_WRITE | PROT_EXEC,
1650                 MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED, 0, 0 ) == MAP_FAILED )
1651       {
1652         errorBelch( "Unable to mmap( MAP_FIXED ) for Jump Islands\n" );
1653         return 0;
1654       }
1655     }
1656
1657 #else
1658     oc->image -= misalignment;
1659     oc->image = stgReallocBytes( oc->image,
1660                                  misalignment +
1661                                  aligned + sizeof (SymbolExtra) * count,
1662                                  "ocAllocateSymbolExtras" );
1663     oc->image += misalignment;
1664 #endif /* USE_MMAP */
1665
1666     oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
1667     memset( oc->symbol_extras, 0, sizeof (SymbolExtra) * count );
1668   }
1669   else
1670     oc->symbol_extras = NULL;
1671
1672   oc->first_symbol_extra = first;
1673   oc->n_symbol_extras = count;
1674
1675   return 1;
1676 }
1677
1678 static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
1679                                      unsigned long symbolNumber,
1680                                      unsigned long target )
1681 {
1682   SymbolExtra *extra;
1683
1684   ASSERT( symbolNumber >= oc->first_symbol_extra
1685         && symbolNumber - oc->first_symbol_extra < oc->n_symbol_extras);
1686
1687   extra = &oc->symbol_extras[symbolNumber - oc->first_symbol_extra];
1688
1689 #ifdef powerpc_HOST_ARCH
1690   // lis r12, hi16(target)
1691   extra->jumpIsland.lis_r12     = 0x3d80;
1692   extra->jumpIsland.hi_addr     = target >> 16;
1693
1694   // ori r12, r12, lo16(target)
1695   extra->jumpIsland.ori_r12_r12 = 0x618c;
1696   extra->jumpIsland.lo_addr     = target & 0xffff;
1697
1698   // mtctr r12
1699   extra->jumpIsland.mtctr_r12   = 0x7d8903a6;
1700
1701   // bctr
1702   extra->jumpIsland.bctr        = 0x4e800420;
1703 #endif
1704 #ifdef x86_64_HOST_ARCH
1705         // jmp *-14(%rip)
1706   static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
1707   extra->addr = target;
1708   memcpy(extra->jumpIsland, jmp, 6);
1709 #endif
1710
1711   return extra;
1712 }
1713
1714 #endif
1715
1716 /* --------------------------------------------------------------------------
1717  * PowerPC specifics (instruction cache flushing)
1718  * ------------------------------------------------------------------------*/
1719
1720 #ifdef powerpc_TARGET_ARCH
1721 /*
1722    ocFlushInstructionCache
1723
1724    Flush the data & instruction caches.
1725    Because the PPC has split data/instruction caches, we have to
1726    do that whenever we modify code at runtime.
1727  */
1728
1729 static void ocFlushInstructionCache( ObjectCode *oc )
1730 {
1731     int n = (oc->fileSize + sizeof( SymbolExtra ) * oc->n_symbol_extras + 3) / 4;
1732     unsigned long *p = (unsigned long *) oc->image;
1733
1734     while( n-- )
1735     {
1736         __asm__ volatile ( "dcbf 0,%0\n\t"
1737                            "sync\n\t"
1738                            "icbi 0,%0"
1739                            :
1740                            : "r" (p)
1741                          );
1742         p++;
1743     }
1744     __asm__ volatile ( "sync\n\t"
1745                        "isync"
1746                      );
1747 }
1748 #endif
1749
1750 /* --------------------------------------------------------------------------
1751  * PEi386 specifics (Win32 targets)
1752  * ------------------------------------------------------------------------*/
1753
1754 /* The information for this linker comes from
1755       Microsoft Portable Executable
1756       and Common Object File Format Specification
1757       revision 5.1 January 1998
1758    which SimonM says comes from the MS Developer Network CDs.
1759
1760    It can be found there (on older CDs), but can also be found
1761    online at:
1762
1763       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
1764
1765    (this is Rev 6.0 from February 1999).
1766
1767    Things move, so if that fails, try searching for it via
1768
1769       http://www.google.com/search?q=PE+COFF+specification
1770
1771    The ultimate reference for the PE format is the Winnt.h
1772    header file that comes with the Platform SDKs; as always,
1773    implementations will drift wrt their documentation.
1774
1775    A good background article on the PE format is Matt Pietrek's
1776    March 1994 article in Microsoft System Journal (MSJ)
1777    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
1778    Win32 Portable Executable File Format." The info in there
1779    has recently been updated in a two part article in
1780    MSDN magazine, issues Feb and March 2002,
1781    "Inside Windows: An In-Depth Look into the Win32 Portable
1782    Executable File Format"
1783
1784    John Levine's book "Linkers and Loaders" contains useful
1785    info on PE too.
1786 */
1787
1788
1789 #if defined(OBJFORMAT_PEi386)
1790
1791
1792
1793 typedef unsigned char  UChar;
1794 typedef unsigned short UInt16;
1795 typedef unsigned int   UInt32;
1796 typedef          int   Int32;
1797
1798
1799 typedef
1800    struct {
1801       UInt16 Machine;
1802       UInt16 NumberOfSections;
1803       UInt32 TimeDateStamp;
1804       UInt32 PointerToSymbolTable;
1805       UInt32 NumberOfSymbols;
1806       UInt16 SizeOfOptionalHeader;
1807       UInt16 Characteristics;
1808    }
1809    COFF_header;
1810
1811 #define sizeof_COFF_header 20
1812
1813
1814 typedef
1815    struct {
1816       UChar  Name[8];
1817       UInt32 VirtualSize;
1818       UInt32 VirtualAddress;
1819       UInt32 SizeOfRawData;
1820       UInt32 PointerToRawData;
1821       UInt32 PointerToRelocations;
1822       UInt32 PointerToLinenumbers;
1823       UInt16 NumberOfRelocations;
1824       UInt16 NumberOfLineNumbers;
1825       UInt32 Characteristics;
1826    }
1827    COFF_section;
1828
1829 #define sizeof_COFF_section 40
1830
1831
1832 typedef
1833    struct {
1834       UChar  Name[8];
1835       UInt32 Value;
1836       UInt16 SectionNumber;
1837       UInt16 Type;
1838       UChar  StorageClass;
1839       UChar  NumberOfAuxSymbols;
1840    }
1841    COFF_symbol;
1842
1843 #define sizeof_COFF_symbol 18
1844
1845
1846 typedef
1847    struct {
1848       UInt32 VirtualAddress;
1849       UInt32 SymbolTableIndex;
1850       UInt16 Type;
1851    }
1852    COFF_reloc;
1853
1854 #define sizeof_COFF_reloc 10
1855
1856
1857 /* From PE spec doc, section 3.3.2 */
1858 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
1859    windows.h -- for the same purpose, but I want to know what I'm
1860    getting, here. */
1861 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
1862 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
1863 #define MYIMAGE_FILE_DLL                 0x2000
1864 #define MYIMAGE_FILE_SYSTEM              0x1000
1865 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
1866 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
1867 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
1868
1869 /* From PE spec doc, section 5.4.2 and 5.4.4 */
1870 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
1871 #define MYIMAGE_SYM_CLASS_STATIC         3
1872 #define MYIMAGE_SYM_UNDEFINED            0
1873
1874 /* From PE spec doc, section 4.1 */
1875 #define MYIMAGE_SCN_CNT_CODE             0x00000020
1876 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
1877 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
1878
1879 /* From PE spec doc, section 5.2.1 */
1880 #define MYIMAGE_REL_I386_DIR32           0x0006
1881 #define MYIMAGE_REL_I386_REL32           0x0014
1882
1883
1884 /* We use myindex to calculate array addresses, rather than
1885    simply doing the normal subscript thing.  That's because
1886    some of the above structs have sizes which are not
1887    a whole number of words.  GCC rounds their sizes up to a
1888    whole number of words, which means that the address calcs
1889    arising from using normal C indexing or pointer arithmetic
1890    are just plain wrong.  Sigh.
1891 */
1892 static UChar *
1893 myindex ( int scale, void* base, int index )
1894 {
1895    return
1896       ((UChar*)base) + scale * index;
1897 }
1898
1899
1900 static void
1901 printName ( UChar* name, UChar* strtab )
1902 {
1903    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1904       UInt32 strtab_offset = * (UInt32*)(name+4);
1905       debugBelch("%s", strtab + strtab_offset );
1906    } else {
1907       int i;
1908       for (i = 0; i < 8; i++) {
1909          if (name[i] == 0) break;
1910          debugBelch("%c", name[i] );
1911       }
1912    }
1913 }
1914
1915
1916 static void
1917 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
1918 {
1919    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1920       UInt32 strtab_offset = * (UInt32*)(name+4);
1921       strncpy ( dst, strtab+strtab_offset, dstSize );
1922       dst[dstSize-1] = 0;
1923    } else {
1924       int i = 0;
1925       while (1) {
1926          if (i >= 8) break;
1927          if (name[i] == 0) break;
1928          dst[i] = name[i];
1929          i++;
1930       }
1931       dst[i] = 0;
1932    }
1933 }
1934
1935
1936 static UChar *
1937 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
1938 {
1939    UChar* newstr;
1940    /* If the string is longer than 8 bytes, look in the
1941       string table for it -- this will be correctly zero terminated.
1942    */
1943    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1944       UInt32 strtab_offset = * (UInt32*)(name+4);
1945       return ((UChar*)strtab) + strtab_offset;
1946    }
1947    /* Otherwise, if shorter than 8 bytes, return the original,
1948       which by defn is correctly terminated.
1949    */
1950    if (name[7]==0) return name;
1951    /* The annoying case: 8 bytes.  Copy into a temporary
1952       (which is never freed ...)
1953    */
1954    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
1955    ASSERT(newstr);
1956    strncpy(newstr,name,8);
1957    newstr[8] = 0;
1958    return newstr;
1959 }
1960
1961
1962 /* Just compares the short names (first 8 chars) */
1963 static COFF_section *
1964 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
1965 {
1966    int i;
1967    COFF_header* hdr
1968       = (COFF_header*)(oc->image);
1969    COFF_section* sectab
1970       = (COFF_section*) (
1971            ((UChar*)(oc->image))
1972            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1973         );
1974    for (i = 0; i < hdr->NumberOfSections; i++) {
1975       UChar* n1;
1976       UChar* n2;
1977       COFF_section* section_i
1978          = (COFF_section*)
1979            myindex ( sizeof_COFF_section, sectab, i );
1980       n1 = (UChar*) &(section_i->Name);
1981       n2 = name;
1982       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
1983           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
1984           n1[6]==n2[6] && n1[7]==n2[7])
1985          return section_i;
1986    }
1987
1988    return NULL;
1989 }
1990
1991
1992 static void
1993 zapTrailingAtSign ( UChar* sym )
1994 {
1995 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
1996    int i, j;
1997    if (sym[0] == 0) return;
1998    i = 0;
1999    while (sym[i] != 0) i++;
2000    i--;
2001    j = i;
2002    while (j > 0 && my_isdigit(sym[j])) j--;
2003    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
2004 #  undef my_isdigit
2005 }
2006
2007
2008 static int
2009 ocVerifyImage_PEi386 ( ObjectCode* oc )
2010 {
2011    int i;
2012    UInt32 j, noRelocs;
2013    COFF_header*  hdr;
2014    COFF_section* sectab;
2015    COFF_symbol*  symtab;
2016    UChar*        strtab;
2017    /* debugBelch("\nLOADING %s\n", oc->fileName); */
2018    hdr = (COFF_header*)(oc->image);
2019    sectab = (COFF_section*) (
2020                ((UChar*)(oc->image))
2021                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2022             );
2023    symtab = (COFF_symbol*) (
2024                ((UChar*)(oc->image))
2025                + hdr->PointerToSymbolTable
2026             );
2027    strtab = ((UChar*)symtab)
2028             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2029
2030    if (hdr->Machine != 0x14c) {
2031       errorBelch("%s: Not x86 PEi386", oc->fileName);
2032       return 0;
2033    }
2034    if (hdr->SizeOfOptionalHeader != 0) {
2035       errorBelch("%s: PEi386 with nonempty optional header", oc->fileName);
2036       return 0;
2037    }
2038    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
2039         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
2040         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
2041         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
2042       errorBelch("%s: Not a PEi386 object file", oc->fileName);
2043       return 0;
2044    }
2045    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
2046         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
2047       errorBelch("%s: Invalid PEi386 word size or endiannness: %d",
2048                  oc->fileName,
2049                  (int)(hdr->Characteristics));
2050       return 0;
2051    }
2052    /* If the string table size is way crazy, this might indicate that
2053       there are more than 64k relocations, despite claims to the
2054       contrary.  Hence this test. */
2055    /* debugBelch("strtab size %d\n", * (UInt32*)strtab); */
2056 #if 0
2057    if ( (*(UInt32*)strtab) > 600000 ) {
2058       /* Note that 600k has no special significance other than being
2059          big enough to handle the almost-2MB-sized lumps that
2060          constitute HSwin32*.o. */
2061       debugBelch("PEi386 object has suspiciously large string table; > 64k relocs?");
2062       return 0;
2063    }
2064 #endif
2065
2066    /* No further verification after this point; only debug printing. */
2067    i = 0;
2068    IF_DEBUG(linker, i=1);
2069    if (i == 0) return 1;
2070
2071    debugBelch( "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
2072    debugBelch( "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
2073    debugBelch( "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
2074
2075    debugBelch("\n" );
2076    debugBelch( "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
2077    debugBelch( "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
2078    debugBelch( "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
2079    debugBelch( "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
2080    debugBelch( "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
2081    debugBelch( "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
2082    debugBelch( "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
2083
2084    /* Print the section table. */
2085    debugBelch("\n" );
2086    for (i = 0; i < hdr->NumberOfSections; i++) {
2087       COFF_reloc* reltab;
2088       COFF_section* sectab_i
2089          = (COFF_section*)
2090            myindex ( sizeof_COFF_section, sectab, i );
2091       debugBelch(
2092                 "\n"
2093                 "section %d\n"
2094                 "     name `",
2095                 i
2096               );
2097       printName ( sectab_i->Name, strtab );
2098       debugBelch(
2099                 "'\n"
2100                 "    vsize %d\n"
2101                 "    vaddr %d\n"
2102                 "  data sz %d\n"
2103                 " data off %d\n"
2104                 "  num rel %d\n"
2105                 "  off rel %d\n"
2106                 "  ptr raw 0x%x\n",
2107                 sectab_i->VirtualSize,
2108                 sectab_i->VirtualAddress,
2109                 sectab_i->SizeOfRawData,
2110                 sectab_i->PointerToRawData,
2111                 sectab_i->NumberOfRelocations,
2112                 sectab_i->PointerToRelocations,
2113                 sectab_i->PointerToRawData
2114               );
2115       reltab = (COFF_reloc*) (
2116                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2117                );
2118
2119       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2120         /* If the relocation field (a short) has overflowed, the
2121          * real count can be found in the first reloc entry.
2122          *
2123          * See Section 4.1 (last para) of the PE spec (rev6.0).
2124          */
2125         COFF_reloc* rel = (COFF_reloc*)
2126                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2127         noRelocs = rel->VirtualAddress;
2128         j = 1;
2129       } else {
2130         noRelocs = sectab_i->NumberOfRelocations;
2131         j = 0;
2132       }
2133
2134       for (; j < noRelocs; j++) {
2135          COFF_symbol* sym;
2136          COFF_reloc* rel = (COFF_reloc*)
2137                            myindex ( sizeof_COFF_reloc, reltab, j );
2138          debugBelch(
2139                    "        type 0x%-4x   vaddr 0x%-8x   name `",
2140                    (UInt32)rel->Type,
2141                    rel->VirtualAddress );
2142          sym = (COFF_symbol*)
2143                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
2144          /* Hmm..mysterious looking offset - what's it for? SOF */
2145          printName ( sym->Name, strtab -10 );
2146          debugBelch("'\n" );
2147       }
2148
2149       debugBelch("\n" );
2150    }
2151    debugBelch("\n" );
2152    debugBelch("string table has size 0x%x\n", * (UInt32*)strtab );
2153    debugBelch("---START of string table---\n");
2154    for (i = 4; i < *(Int32*)strtab; i++) {
2155       if (strtab[i] == 0)
2156          debugBelch("\n"); else
2157          debugBelch("%c", strtab[i] );
2158    }
2159    debugBelch("--- END  of string table---\n");
2160
2161    debugBelch("\n" );
2162    i = 0;
2163    while (1) {
2164       COFF_symbol* symtab_i;
2165       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2166       symtab_i = (COFF_symbol*)
2167                  myindex ( sizeof_COFF_symbol, symtab, i );
2168       debugBelch(
2169                 "symbol %d\n"
2170                 "     name `",
2171                 i
2172               );
2173       printName ( symtab_i->Name, strtab );
2174       debugBelch(
2175                 "'\n"
2176                 "    value 0x%x\n"
2177                 "   1+sec# %d\n"
2178                 "     type 0x%x\n"
2179                 "   sclass 0x%x\n"
2180                 "     nAux %d\n",
2181                 symtab_i->Value,
2182                 (Int32)(symtab_i->SectionNumber),
2183                 (UInt32)symtab_i->Type,
2184                 (UInt32)symtab_i->StorageClass,
2185                 (UInt32)symtab_i->NumberOfAuxSymbols
2186               );
2187       i += symtab_i->NumberOfAuxSymbols;
2188       i++;
2189    }
2190
2191    debugBelch("\n" );
2192    return 1;
2193 }
2194
2195
2196 static int
2197 ocGetNames_PEi386 ( ObjectCode* oc )
2198 {
2199    COFF_header*  hdr;
2200    COFF_section* sectab;
2201    COFF_symbol*  symtab;
2202    UChar*        strtab;
2203
2204    UChar* sname;
2205    void*  addr;
2206    int    i;
2207
2208    hdr = (COFF_header*)(oc->image);
2209    sectab = (COFF_section*) (
2210                ((UChar*)(oc->image))
2211                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2212             );
2213    symtab = (COFF_symbol*) (
2214                ((UChar*)(oc->image))
2215                + hdr->PointerToSymbolTable
2216             );
2217    strtab = ((UChar*)(oc->image))
2218             + hdr->PointerToSymbolTable
2219             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2220
2221    /* Allocate space for any (local, anonymous) .bss sections. */
2222
2223    for (i = 0; i < hdr->NumberOfSections; i++) {
2224       UInt32 bss_sz;
2225       UChar* zspace;
2226       COFF_section* sectab_i
2227          = (COFF_section*)
2228            myindex ( sizeof_COFF_section, sectab, i );
2229       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
2230       /* sof 10/05: the PE spec text isn't too clear regarding what
2231        * the SizeOfRawData field is supposed to hold for object
2232        * file sections containing just uninitialized data -- for executables,
2233        * it is supposed to be zero; unclear what it's supposed to be
2234        * for object files. However, VirtualSize is guaranteed to be
2235        * zero for object files, which definitely suggests that SizeOfRawData
2236        * will be non-zero (where else would the size of this .bss section be
2237        * stored?) Looking at the COFF_section info for incoming object files,
2238        * this certainly appears to be the case.
2239        *
2240        * => I suspect we've been incorrectly handling .bss sections in (relocatable)
2241        * object files up until now. This turned out to bite us with ghc-6.4.1's use
2242        * of gcc-3.4.x, which has started to emit initially-zeroed-out local 'static'
2243        * variable decls into to the .bss section. (The specific function in Q which
2244        * triggered this is libraries/base/cbits/dirUtils.c:__hscore_getFolderPath())
2245        */
2246       if (sectab_i->VirtualSize == 0 && sectab_i->SizeOfRawData == 0) continue;
2247       /* This is a non-empty .bss section.  Allocate zeroed space for
2248          it, and set its PointerToRawData field such that oc->image +
2249          PointerToRawData == addr_of_zeroed_space.  */
2250       bss_sz = sectab_i->VirtualSize;
2251       if ( bss_sz < sectab_i->SizeOfRawData) { bss_sz = sectab_i->SizeOfRawData; }
2252       zspace = stgCallocBytes(1, bss_sz, "ocGetNames_PEi386(anonymous bss)");
2253       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
2254       addProddableBlock(oc, zspace, bss_sz);
2255       /* debugBelch("BSS anon section at 0x%x\n", zspace); */
2256    }
2257
2258    /* Copy section information into the ObjectCode. */
2259
2260    for (i = 0; i < hdr->NumberOfSections; i++) {
2261       UChar* start;
2262       UChar* end;
2263       UInt32 sz;
2264
2265       SectionKind kind
2266          = SECTIONKIND_OTHER;
2267       COFF_section* sectab_i
2268          = (COFF_section*)
2269            myindex ( sizeof_COFF_section, sectab, i );
2270       IF_DEBUG(linker, debugBelch("section name = %s\n", sectab_i->Name ));
2271
2272 #     if 0
2273       /* I'm sure this is the Right Way to do it.  However, the
2274          alternative of testing the sectab_i->Name field seems to
2275          work ok with Cygwin.
2276       */
2277       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
2278           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
2279          kind = SECTIONKIND_CODE_OR_RODATA;
2280 #     endif
2281
2282       if (0==strcmp(".text",sectab_i->Name) ||
2283           0==strcmp(".rdata",sectab_i->Name)||
2284           0==strcmp(".rodata",sectab_i->Name))
2285          kind = SECTIONKIND_CODE_OR_RODATA;
2286       if (0==strcmp(".data",sectab_i->Name) ||
2287           0==strcmp(".bss",sectab_i->Name))
2288          kind = SECTIONKIND_RWDATA;
2289
2290       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
2291       sz = sectab_i->SizeOfRawData;
2292       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
2293
2294       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
2295       end   = start + sz - 1;
2296
2297       if (kind == SECTIONKIND_OTHER
2298           /* Ignore sections called which contain stabs debugging
2299              information. */
2300           && 0 != strcmp(".stab", sectab_i->Name)
2301           && 0 != strcmp(".stabstr", sectab_i->Name)
2302           /* ignore constructor section for now */
2303           && 0 != strcmp(".ctors", sectab_i->Name)
2304           /* ignore section generated from .ident */
2305           && 0!= strcmp("/4", sectab_i->Name)
2306           /* ignore unknown section that appeared in gcc 3.4.5(?) */
2307           && 0!= strcmp(".reloc", sectab_i->Name)
2308          ) {
2309          errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", sectab_i->Name, oc->fileName);
2310          return 0;
2311       }
2312
2313       if (kind != SECTIONKIND_OTHER && end >= start) {
2314          addSection(oc, kind, start, end);
2315          addProddableBlock(oc, start, end - start + 1);
2316       }
2317    }
2318
2319    /* Copy exported symbols into the ObjectCode. */
2320
2321    oc->n_symbols = hdr->NumberOfSymbols;
2322    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
2323                                   "ocGetNames_PEi386(oc->symbols)");
2324    /* Call me paranoid; I don't care. */
2325    for (i = 0; i < oc->n_symbols; i++)
2326       oc->symbols[i] = NULL;
2327
2328    i = 0;
2329    while (1) {
2330       COFF_symbol* symtab_i;
2331       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2332       symtab_i = (COFF_symbol*)
2333                  myindex ( sizeof_COFF_symbol, symtab, i );
2334
2335       addr  = NULL;
2336
2337       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
2338           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
2339          /* This symbol is global and defined, viz, exported */
2340          /* for MYIMAGE_SYMCLASS_EXTERNAL
2341                 && !MYIMAGE_SYM_UNDEFINED,
2342             the address of the symbol is:
2343                 address of relevant section + offset in section
2344          */
2345          COFF_section* sectabent
2346             = (COFF_section*) myindex ( sizeof_COFF_section,
2347                                         sectab,
2348                                         symtab_i->SectionNumber-1 );
2349          addr = ((UChar*)(oc->image))
2350                 + (sectabent->PointerToRawData
2351                    + symtab_i->Value);
2352       }
2353       else
2354       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
2355           && symtab_i->Value > 0) {
2356          /* This symbol isn't in any section at all, ie, global bss.
2357             Allocate zeroed space for it. */
2358          addr = stgCallocBytes(1, symtab_i->Value,
2359                                "ocGetNames_PEi386(non-anonymous bss)");
2360          addSection(oc, SECTIONKIND_RWDATA, addr,
2361                         ((UChar*)addr) + symtab_i->Value - 1);
2362          addProddableBlock(oc, addr, symtab_i->Value);
2363          /* debugBelch("BSS      section at 0x%x\n", addr); */
2364       }
2365
2366       if (addr != NULL ) {
2367          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
2368          /* debugBelch("addSymbol %p `%s \n", addr,sname);  */
2369          IF_DEBUG(linker, debugBelch("addSymbol %p `%s'\n", addr,sname);)
2370          ASSERT(i >= 0 && i < oc->n_symbols);
2371          /* cstring_from_COFF_symbol_name always succeeds. */
2372          oc->symbols[i] = sname;
2373          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
2374       } else {
2375 #        if 0
2376          debugBelch(
2377                    "IGNORING symbol %d\n"
2378                    "     name `",
2379                    i
2380                  );
2381          printName ( symtab_i->Name, strtab );
2382          debugBelch(
2383                    "'\n"
2384                    "    value 0x%x\n"
2385                    "   1+sec# %d\n"
2386                    "     type 0x%x\n"
2387                    "   sclass 0x%x\n"
2388                    "     nAux %d\n",
2389                    symtab_i->Value,
2390                    (Int32)(symtab_i->SectionNumber),
2391                    (UInt32)symtab_i->Type,
2392                    (UInt32)symtab_i->StorageClass,
2393                    (UInt32)symtab_i->NumberOfAuxSymbols
2394                  );
2395 #        endif
2396       }
2397
2398       i += symtab_i->NumberOfAuxSymbols;
2399       i++;
2400    }
2401
2402    return 1;
2403 }
2404
2405
2406 static int
2407 ocResolve_PEi386 ( ObjectCode* oc )
2408 {
2409    COFF_header*  hdr;
2410    COFF_section* sectab;
2411    COFF_symbol*  symtab;
2412    UChar*        strtab;
2413
2414    UInt32        A;
2415    UInt32        S;
2416    UInt32*       pP;
2417
2418    int i;
2419    UInt32 j, noRelocs;
2420
2421    /* ToDo: should be variable-sized?  But is at least safe in the
2422       sense of buffer-overrun-proof. */
2423    char symbol[1000];
2424    /* debugBelch("resolving for %s\n", oc->fileName); */
2425
2426    hdr = (COFF_header*)(oc->image);
2427    sectab = (COFF_section*) (
2428                ((UChar*)(oc->image))
2429                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2430             );
2431    symtab = (COFF_symbol*) (
2432                ((UChar*)(oc->image))
2433                + hdr->PointerToSymbolTable
2434             );
2435    strtab = ((UChar*)(oc->image))
2436             + hdr->PointerToSymbolTable
2437             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2438
2439    for (i = 0; i < hdr->NumberOfSections; i++) {
2440       COFF_section* sectab_i
2441          = (COFF_section*)
2442            myindex ( sizeof_COFF_section, sectab, i );
2443       COFF_reloc* reltab
2444          = (COFF_reloc*) (
2445               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2446            );
2447
2448       /* Ignore sections called which contain stabs debugging
2449          information. */
2450       if (0 == strcmp(".stab", sectab_i->Name)
2451           || 0 == strcmp(".stabstr", sectab_i->Name)
2452           || 0 == strcmp(".ctors", sectab_i->Name))
2453          continue;
2454
2455       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2456         /* If the relocation field (a short) has overflowed, the
2457          * real count can be found in the first reloc entry.
2458          *
2459          * See Section 4.1 (last para) of the PE spec (rev6.0).
2460          *
2461          * Nov2003 update: the GNU linker still doesn't correctly
2462          * handle the generation of relocatable object files with
2463          * overflown relocations. Hence the output to warn of potential
2464          * troubles.
2465          */
2466         COFF_reloc* rel = (COFF_reloc*)
2467                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2468         noRelocs = rel->VirtualAddress;
2469
2470         /* 10/05: we now assume (and check for) a GNU ld that is capable
2471          * of handling object files with (>2^16) of relocs.
2472          */
2473 #if 0
2474         debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
2475                    noRelocs);
2476 #endif
2477         j = 1;
2478       } else {
2479         noRelocs = sectab_i->NumberOfRelocations;
2480         j = 0;
2481       }
2482
2483
2484       for (; j < noRelocs; j++) {
2485          COFF_symbol* sym;
2486          COFF_reloc* reltab_j
2487             = (COFF_reloc*)
2488               myindex ( sizeof_COFF_reloc, reltab, j );
2489
2490          /* the location to patch */
2491          pP = (UInt32*)(
2492                  ((UChar*)(oc->image))
2493                  + (sectab_i->PointerToRawData
2494                     + reltab_j->VirtualAddress
2495                     - sectab_i->VirtualAddress )
2496               );
2497          /* the existing contents of pP */
2498          A = *pP;
2499          /* the symbol to connect to */
2500          sym = (COFF_symbol*)
2501                myindex ( sizeof_COFF_symbol,
2502                          symtab, reltab_j->SymbolTableIndex );
2503          IF_DEBUG(linker,
2504                   debugBelch(
2505                             "reloc sec %2d num %3d:  type 0x%-4x   "
2506                             "vaddr 0x%-8x   name `",
2507                             i, j,
2508                             (UInt32)reltab_j->Type,
2509                             reltab_j->VirtualAddress );
2510                             printName ( sym->Name, strtab );
2511                             debugBelch("'\n" ));
2512
2513          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
2514             COFF_section* section_sym
2515                = findPEi386SectionCalled ( oc, sym->Name );
2516             if (!section_sym) {
2517                errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
2518                return 0;
2519             }
2520             S = ((UInt32)(oc->image))
2521                 + (section_sym->PointerToRawData
2522                    + sym->Value);
2523          } else {
2524             copyName ( sym->Name, strtab, symbol, 1000-1 );
2525             S = (UInt32) lookupSymbol( symbol );
2526             if ((void*)S != NULL) goto foundit;
2527             zapTrailingAtSign ( symbol );
2528             S = (UInt32) lookupSymbol( symbol );
2529             if ((void*)S != NULL) goto foundit;
2530             /* Newline first because the interactive linker has printed "linking..." */
2531             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
2532             return 0;
2533            foundit:;
2534          }
2535          checkProddableBlock(oc, pP);
2536          switch (reltab_j->Type) {
2537             case MYIMAGE_REL_I386_DIR32:
2538                *pP = A + S;
2539                break;
2540             case MYIMAGE_REL_I386_REL32:
2541                /* Tricky.  We have to insert a displacement at
2542                   pP which, when added to the PC for the _next_
2543                   insn, gives the address of the target (S).
2544                   Problem is to know the address of the next insn
2545                   when we only know pP.  We assume that this
2546                   literal field is always the last in the insn,
2547                   so that the address of the next insn is pP+4
2548                   -- hence the constant 4.
2549                   Also I don't know if A should be added, but so
2550                   far it has always been zero.
2551
2552                   SOF 05/2005: 'A' (old contents of *pP) have been observed
2553                   to contain values other than zero (the 'wx' object file
2554                   that came with wxhaskell-0.9.4; dunno how it was compiled..).
2555                   So, add displacement to old value instead of asserting
2556                   A to be zero. Fixes wxhaskell-related crashes, and no other
2557                   ill effects have been observed.
2558
2559                   Update: the reason why we're seeing these more elaborate
2560                   relocations is due to a switch in how the NCG compiles SRTs
2561                   and offsets to them from info tables. SRTs live in .(ro)data,
2562                   while info tables live in .text, causing GAS to emit REL32/DISP32
2563                   relocations with non-zero values. Adding the displacement is
2564                   the right thing to do.
2565                */
2566                *pP = S - ((UInt32)pP) - 4 + A;
2567                break;
2568             default:
2569                debugBelch("%s: unhandled PEi386 relocation type %d",
2570                      oc->fileName, reltab_j->Type);
2571                return 0;
2572          }
2573
2574       }
2575    }
2576
2577    IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
2578    return 1;
2579 }
2580
2581 #endif /* defined(OBJFORMAT_PEi386) */
2582
2583
2584 /* --------------------------------------------------------------------------
2585  * ELF specifics
2586  * ------------------------------------------------------------------------*/
2587
2588 #if defined(OBJFORMAT_ELF)
2589
2590 #define FALSE 0
2591 #define TRUE  1
2592
2593 #if defined(sparc_HOST_ARCH)
2594 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
2595 #elif defined(i386_HOST_ARCH)
2596 #  define ELF_TARGET_386    /* Used inside <elf.h> */
2597 #elif defined(x86_64_HOST_ARCH)
2598 #  define ELF_TARGET_X64_64
2599 #  define ELF_64BIT
2600 #elif defined (ia64_HOST_ARCH)
2601 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
2602 #  define ELF_64BIT
2603 #  define ELF_FUNCTION_DESC /* calling convention uses function descriptors */
2604 #  define ELF_NEED_GOT      /* needs Global Offset Table */
2605 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
2606 #endif
2607
2608 #if !defined(openbsd_HOST_OS)
2609 #  include <elf.h>
2610 #else
2611 /* openbsd elf has things in different places, with diff names */
2612 #  include <elf_abi.h>
2613 #  include <machine/reloc.h>
2614 #  define R_386_32    RELOC_32
2615 #  define R_386_PC32  RELOC_PC32
2616 #endif
2617
2618 /* If elf.h doesn't define it */
2619 #  ifndef R_X86_64_PC64
2620 #    define R_X86_64_PC64 24
2621 #  endif
2622
2623 /*
2624  * Define a set of types which can be used for both ELF32 and ELF64
2625  */
2626
2627 #ifdef ELF_64BIT
2628 #define ELFCLASS    ELFCLASS64
2629 #define Elf_Addr    Elf64_Addr
2630 #define Elf_Word    Elf64_Word
2631 #define Elf_Sword   Elf64_Sword
2632 #define Elf_Ehdr    Elf64_Ehdr
2633 #define Elf_Phdr    Elf64_Phdr
2634 #define Elf_Shdr    Elf64_Shdr
2635 #define Elf_Sym     Elf64_Sym
2636 #define Elf_Rel     Elf64_Rel
2637 #define Elf_Rela    Elf64_Rela
2638 #define ELF_ST_TYPE ELF64_ST_TYPE
2639 #define ELF_ST_BIND ELF64_ST_BIND
2640 #define ELF_R_TYPE  ELF64_R_TYPE
2641 #define ELF_R_SYM   ELF64_R_SYM
2642 #else
2643 #define ELFCLASS    ELFCLASS32
2644 #define Elf_Addr    Elf32_Addr
2645 #define Elf_Word    Elf32_Word
2646 #define Elf_Sword   Elf32_Sword
2647 #define Elf_Ehdr    Elf32_Ehdr
2648 #define Elf_Phdr    Elf32_Phdr
2649 #define Elf_Shdr    Elf32_Shdr
2650 #define Elf_Sym     Elf32_Sym
2651 #define Elf_Rel     Elf32_Rel
2652 #define Elf_Rela    Elf32_Rela
2653 #ifndef ELF_ST_TYPE
2654 #define ELF_ST_TYPE ELF32_ST_TYPE
2655 #endif
2656 #ifndef ELF_ST_BIND
2657 #define ELF_ST_BIND ELF32_ST_BIND
2658 #endif
2659 #ifndef ELF_R_TYPE
2660 #define ELF_R_TYPE  ELF32_R_TYPE
2661 #endif
2662 #ifndef ELF_R_SYM
2663 #define ELF_R_SYM   ELF32_R_SYM
2664 #endif
2665 #endif
2666
2667
2668 /*
2669  * Functions to allocate entries in dynamic sections.  Currently we simply
2670  * preallocate a large number, and we don't check if a entry for the given
2671  * target already exists (a linear search is too slow).  Ideally these
2672  * entries would be associated with symbols.
2673  */
2674
2675 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
2676 #define GOT_SIZE            0x20000
2677 #define FUNCTION_TABLE_SIZE 0x10000
2678 #define PLT_SIZE            0x08000
2679
2680 #ifdef ELF_NEED_GOT
2681 static Elf_Addr got[GOT_SIZE];
2682 static unsigned int gotIndex;
2683 static Elf_Addr gp_val = (Elf_Addr)got;
2684
2685 static Elf_Addr
2686 allocateGOTEntry(Elf_Addr target)
2687 {
2688    Elf_Addr *entry;
2689
2690    if (gotIndex >= GOT_SIZE)
2691       barf("Global offset table overflow");
2692
2693    entry = &got[gotIndex++];
2694    *entry = target;
2695    return (Elf_Addr)entry;
2696 }
2697 #endif
2698
2699 #ifdef ELF_FUNCTION_DESC
2700 typedef struct {
2701    Elf_Addr ip;
2702    Elf_Addr gp;
2703 } FunctionDesc;
2704
2705 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
2706 static unsigned int functionTableIndex;
2707
2708 static Elf_Addr
2709 allocateFunctionDesc(Elf_Addr target)
2710 {
2711    FunctionDesc *entry;
2712
2713    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
2714       barf("Function table overflow");
2715
2716    entry = &functionTable[functionTableIndex++];
2717    entry->ip = target;
2718    entry->gp = (Elf_Addr)gp_val;
2719    return (Elf_Addr)entry;
2720 }
2721
2722 static Elf_Addr
2723 copyFunctionDesc(Elf_Addr target)
2724 {
2725    FunctionDesc *olddesc = (FunctionDesc *)target;
2726    FunctionDesc *newdesc;
2727
2728    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
2729    newdesc->gp = olddesc->gp;
2730    return (Elf_Addr)newdesc;
2731 }
2732 #endif
2733
2734 #ifdef ELF_NEED_PLT
2735 #ifdef ia64_HOST_ARCH
2736 static void ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value);
2737 static void ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc);
2738
2739 static unsigned char plt_code[] =
2740 {
2741    /* taken from binutils bfd/elfxx-ia64.c */
2742    0x0b, 0x78, 0x00, 0x02, 0x00, 0x24,  /*   [MMI]       addl r15=0,r1;;    */
2743    0x00, 0x41, 0x3c, 0x30, 0x28, 0xc0,  /*               ld8 r16=[r15],8    */
2744    0x01, 0x08, 0x00, 0x84,              /*               mov r14=r1;;       */
2745    0x11, 0x08, 0x00, 0x1e, 0x18, 0x10,  /*   [MIB]       ld8 r1=[r15]       */
2746    0x60, 0x80, 0x04, 0x80, 0x03, 0x00,  /*               mov b6=r16         */
2747    0x60, 0x00, 0x80, 0x00               /*               br.few b6;;        */
2748 };
2749
2750 /* If we can't get to the function descriptor via gp, take a local copy of it */
2751 #define PLT_RELOC(code, target) { \
2752    Elf64_Sxword rel_value = target - gp_val; \
2753    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff)) \
2754       ia64_reloc_gprel22((Elf_Addr)code, copyFunctionDesc(target)); \
2755    else \
2756       ia64_reloc_gprel22((Elf_Addr)code, target); \
2757    }
2758 #endif
2759
2760 typedef struct {
2761    unsigned char code[sizeof(plt_code)];
2762 } PLTEntry;
2763
2764 static Elf_Addr
2765 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
2766 {
2767    PLTEntry *plt = (PLTEntry *)oc->plt;
2768    PLTEntry *entry;
2769
2770    if (oc->pltIndex >= PLT_SIZE)
2771       barf("Procedure table overflow");
2772
2773    entry = &plt[oc->pltIndex++];
2774    memcpy(entry->code, plt_code, sizeof(entry->code));
2775    PLT_RELOC(entry->code, target);
2776    return (Elf_Addr)entry;
2777 }
2778
2779 static unsigned int
2780 PLTSize(void)
2781 {
2782    return (PLT_SIZE * sizeof(PLTEntry));
2783 }
2784 #endif
2785
2786
2787 /*
2788  * Generic ELF functions
2789  */
2790
2791 static char *
2792 findElfSection ( void* objImage, Elf_Word sh_type )
2793 {
2794    char* ehdrC = (char*)objImage;
2795    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2796    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
2797    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2798    char* ptr = NULL;
2799    int i;
2800
2801    for (i = 0; i < ehdr->e_shnum; i++) {
2802       if (shdr[i].sh_type == sh_type
2803           /* Ignore the section header's string table. */
2804           && i != ehdr->e_shstrndx
2805           /* Ignore string tables named .stabstr, as they contain
2806              debugging info. */
2807           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2808          ) {
2809          ptr = ehdrC + shdr[i].sh_offset;
2810          break;
2811       }
2812    }
2813    return ptr;
2814 }
2815
2816 #if defined(ia64_HOST_ARCH)
2817 static Elf_Addr
2818 findElfSegment ( void* objImage, Elf_Addr vaddr )
2819 {
2820    char* ehdrC = (char*)objImage;
2821    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2822    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2823    Elf_Addr segaddr = 0;
2824    int i;
2825
2826    for (i = 0; i < ehdr->e_phnum; i++) {
2827       segaddr = phdr[i].p_vaddr;
2828       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2829               break;
2830    }
2831    return segaddr;
2832 }
2833 #endif
2834
2835 static int
2836 ocVerifyImage_ELF ( ObjectCode* oc )
2837 {
2838    Elf_Shdr* shdr;
2839    Elf_Sym*  stab;
2840    int i, j, nent, nstrtab, nsymtabs;
2841    char* sh_strtab;
2842    char* strtab;
2843
2844    char*     ehdrC = (char*)(oc->image);
2845    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2846
2847    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2848        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2849        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2850        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2851       errorBelch("%s: not an ELF object", oc->fileName);
2852       return 0;
2853    }
2854
2855    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2856       errorBelch("%s: unsupported ELF format", oc->fileName);
2857       return 0;
2858    }
2859
2860    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2861        IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
2862    } else
2863    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2864        IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
2865    } else {
2866        errorBelch("%s: unknown endiannness", oc->fileName);
2867        return 0;
2868    }
2869
2870    if (ehdr->e_type != ET_REL) {
2871       errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
2872       return 0;
2873    }
2874    IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
2875
2876    IF_DEBUG(linker,debugBelch( "Architecture is " ));
2877    switch (ehdr->e_machine) {
2878       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
2879 #ifdef EM_SPARC32PLUS
2880       case EM_SPARC32PLUS:
2881 #endif
2882       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
2883 #ifdef EM_IA_64
2884       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
2885 #endif
2886       case EM_PPC:   IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
2887 #ifdef EM_X86_64
2888       case EM_X86_64: IF_DEBUG(linker,debugBelch( "x86_64" )); break;
2889 #elif defined(EM_AMD64)
2890       case EM_AMD64: IF_DEBUG(linker,debugBelch( "amd64" )); break;
2891 #endif
2892       default:       IF_DEBUG(linker,debugBelch( "unknown" ));
2893                      errorBelch("%s: unknown architecture (e_machine == %d)"
2894                                 , oc->fileName, ehdr->e_machine);
2895                      return 0;
2896    }
2897
2898    IF_DEBUG(linker,debugBelch(
2899              "\nSection header table: start %ld, n_entries %d, ent_size %d\n",
2900              (long)ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
2901
2902    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
2903
2904    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2905
2906    if (ehdr->e_shstrndx == SHN_UNDEF) {
2907       errorBelch("%s: no section header string table", oc->fileName);
2908       return 0;
2909    } else {
2910       IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
2911                           ehdr->e_shstrndx));
2912       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2913    }
2914
2915    for (i = 0; i < ehdr->e_shnum; i++) {
2916       IF_DEBUG(linker,debugBelch("%2d:  ", i ));
2917       IF_DEBUG(linker,debugBelch("type=%2d  ", (int)shdr[i].sh_type ));
2918       IF_DEBUG(linker,debugBelch("size=%4d  ", (int)shdr[i].sh_size ));
2919       IF_DEBUG(linker,debugBelch("offs=%4d  ", (int)shdr[i].sh_offset ));
2920       IF_DEBUG(linker,debugBelch("  (%p .. %p)  ",
2921                ehdrC + shdr[i].sh_offset,
2922                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
2923
2924       if (shdr[i].sh_type == SHT_REL) {
2925           IF_DEBUG(linker,debugBelch("Rel  " ));
2926       } else if (shdr[i].sh_type == SHT_RELA) {
2927           IF_DEBUG(linker,debugBelch("RelA " ));
2928       } else {
2929           IF_DEBUG(linker,debugBelch("     "));
2930       }
2931       if (sh_strtab) {
2932           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
2933       }
2934    }
2935
2936    IF_DEBUG(linker,debugBelch( "\nString tables" ));
2937    strtab = NULL;
2938    nstrtab = 0;
2939    for (i = 0; i < ehdr->e_shnum; i++) {
2940       if (shdr[i].sh_type == SHT_STRTAB
2941           /* Ignore the section header's string table. */
2942           && i != ehdr->e_shstrndx
2943           /* Ignore string tables named .stabstr, as they contain
2944              debugging info. */
2945           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2946          ) {
2947          IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
2948          strtab = ehdrC + shdr[i].sh_offset;
2949          nstrtab++;
2950       }
2951    }
2952    if (nstrtab != 1) {
2953       errorBelch("%s: no string tables, or too many", oc->fileName);
2954       return 0;
2955    }
2956
2957    nsymtabs = 0;
2958    IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
2959    for (i = 0; i < ehdr->e_shnum; i++) {
2960       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2961       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
2962       nsymtabs++;
2963       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2964       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2965       IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%ld rem)\n",
2966                nent,
2967                (long)shdr[i].sh_size % sizeof(Elf_Sym)
2968              ));
2969       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
2970          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
2971          return 0;
2972       }
2973       for (j = 0; j < nent; j++) {
2974          IF_DEBUG(linker,debugBelch("   %2d  ", j ));
2975          IF_DEBUG(linker,debugBelch("  sec=%-5d  size=%-3d  val=%5p  ",
2976                              (int)stab[j].st_shndx,
2977                              (int)stab[j].st_size,
2978                              (char*)stab[j].st_value ));
2979
2980          IF_DEBUG(linker,debugBelch("type=" ));
2981          switch (ELF_ST_TYPE(stab[j].st_info)) {
2982             case STT_NOTYPE:  IF_DEBUG(linker,debugBelch("notype " )); break;
2983             case STT_OBJECT:  IF_DEBUG(linker,debugBelch("object " )); break;
2984             case STT_FUNC  :  IF_DEBUG(linker,debugBelch("func   " )); break;
2985             case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
2986             case STT_FILE:    IF_DEBUG(linker,debugBelch("file   " )); break;
2987             default:          IF_DEBUG(linker,debugBelch("?      " )); break;
2988          }
2989          IF_DEBUG(linker,debugBelch("  " ));
2990
2991          IF_DEBUG(linker,debugBelch("bind=" ));
2992          switch (ELF_ST_BIND(stab[j].st_info)) {
2993             case STB_LOCAL :  IF_DEBUG(linker,debugBelch("local " )); break;
2994             case STB_GLOBAL:  IF_DEBUG(linker,debugBelch("global" )); break;
2995             case STB_WEAK  :  IF_DEBUG(linker,debugBelch("weak  " )); break;
2996             default:          IF_DEBUG(linker,debugBelch("?     " )); break;
2997          }
2998          IF_DEBUG(linker,debugBelch("  " ));
2999
3000          IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
3001       }
3002    }
3003
3004    if (nsymtabs == 0) {
3005       errorBelch("%s: didn't find any symbol tables", oc->fileName);
3006       return 0;
3007    }
3008
3009    return 1;
3010 }
3011
3012 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
3013 {
3014     *is_bss = FALSE;
3015
3016     if (hdr->sh_type == SHT_PROGBITS
3017         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
3018         /* .text-style section */
3019         return SECTIONKIND_CODE_OR_RODATA;
3020     }
3021
3022     if (hdr->sh_type == SHT_PROGBITS
3023             && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3024             /* .data-style section */
3025             return SECTIONKIND_RWDATA;
3026     }
3027
3028     if (hdr->sh_type == SHT_PROGBITS
3029         && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
3030         /* .rodata-style section */
3031         return SECTIONKIND_CODE_OR_RODATA;
3032     }
3033
3034     if (hdr->sh_type == SHT_NOBITS
3035         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3036         /* .bss-style section */
3037         *is_bss = TRUE;
3038         return SECTIONKIND_RWDATA;
3039     }
3040
3041     return SECTIONKIND_OTHER;
3042 }
3043
3044
3045 static int
3046 ocGetNames_ELF ( ObjectCode* oc )
3047 {
3048    int i, j, k, nent;
3049    Elf_Sym* stab;
3050
3051    char*     ehdrC    = (char*)(oc->image);
3052    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
3053    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
3054    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3055
3056    ASSERT(symhash != NULL);
3057
3058    if (!strtab) {
3059       errorBelch("%s: no strtab", oc->fileName);
3060       return 0;
3061    }
3062
3063    k = 0;
3064    for (i = 0; i < ehdr->e_shnum; i++) {
3065       /* Figure out what kind of section it is.  Logic derived from
3066          Figure 1.14 ("Special Sections") of the ELF document
3067          ("Portable Formats Specification, Version 1.1"). */
3068       int         is_bss = FALSE;
3069       SectionKind kind   = getSectionKind_ELF(&shdr[i], &is_bss);
3070
3071       if (is_bss && shdr[i].sh_size > 0) {
3072          /* This is a non-empty .bss section.  Allocate zeroed space for
3073             it, and set its .sh_offset field such that
3074             ehdrC + .sh_offset == addr_of_zeroed_space.  */
3075          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
3076                                        "ocGetNames_ELF(BSS)");
3077          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
3078          /*
3079          debugBelch("BSS section at 0x%x, size %d\n",
3080                          zspace, shdr[i].sh_size);
3081          */
3082       }
3083
3084       /* fill in the section info */
3085       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
3086          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
3087          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
3088                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
3089       }
3090
3091       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3092
3093       /* copy stuff into this module's object symbol table */
3094       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3095       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3096
3097       oc->n_symbols = nent;
3098       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3099                                    "ocGetNames_ELF(oc->symbols)");
3100
3101       for (j = 0; j < nent; j++) {
3102
3103          char  isLocal = FALSE; /* avoids uninit-var warning */
3104          char* ad      = NULL;
3105          char* nm      = strtab + stab[j].st_name;
3106          int   secno   = stab[j].st_shndx;
3107
3108          /* Figure out if we want to add it; if so, set ad to its
3109             address.  Otherwise leave ad == NULL. */
3110
3111          if (secno == SHN_COMMON) {
3112             isLocal = FALSE;
3113             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
3114             /*
3115             debugBelch("COMMON symbol, size %d name %s\n",
3116                             stab[j].st_size, nm);
3117             */
3118             /* Pointless to do addProddableBlock() for this area,
3119                since the linker should never poke around in it. */
3120          }
3121          else
3122          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
3123                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
3124               )
3125               /* and not an undefined symbol */
3126               && stab[j].st_shndx != SHN_UNDEF
3127               /* and not in a "special section" */
3128               && stab[j].st_shndx < SHN_LORESERVE
3129               &&
3130               /* and it's a not a section or string table or anything silly */
3131               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
3132                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
3133                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
3134               )
3135             ) {
3136             /* Section 0 is the undefined section, hence > and not >=. */
3137             ASSERT(secno > 0 && secno < ehdr->e_shnum);
3138             /*
3139             if (shdr[secno].sh_type == SHT_NOBITS) {
3140                debugBelch("   BSS symbol, size %d off %d name %s\n",
3141                                stab[j].st_size, stab[j].st_value, nm);
3142             }
3143             */
3144             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
3145             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
3146                isLocal = TRUE;
3147             } else {
3148 #ifdef ELF_FUNCTION_DESC
3149                /* dlsym() and the initialisation table both give us function
3150                 * descriptors, so to be consistent we store function descriptors
3151                 * in the symbol table */
3152                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
3153                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
3154 #endif
3155                IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p  %s %s\n",
3156                                       ad, oc->fileName, nm ));
3157                isLocal = FALSE;
3158             }
3159          }
3160
3161          /* And the decision is ... */
3162
3163          if (ad != NULL) {
3164             ASSERT(nm != NULL);
3165             oc->symbols[j] = nm;
3166             /* Acquire! */
3167             if (isLocal) {
3168                /* Ignore entirely. */
3169             } else {
3170                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
3171             }
3172          } else {
3173             /* Skip. */
3174             IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
3175                                    strtab + stab[j].st_name ));
3176             /*
3177             debugBelch(
3178                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
3179                     (int)ELF_ST_BIND(stab[j].st_info),
3180                     (int)ELF_ST_TYPE(stab[j].st_info),
3181                     (int)stab[j].st_shndx,
3182                     strtab + stab[j].st_name
3183                    );
3184             */
3185             oc->symbols[j] = NULL;
3186          }
3187
3188       }
3189    }
3190
3191    return 1;
3192 }
3193
3194 /* Do ELF relocations which lack an explicit addend.  All x86-linux
3195    relocations appear to be of this form. */
3196 static int
3197 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
3198                          Elf_Shdr* shdr, int shnum,
3199                          Elf_Sym*  stab, char* strtab )
3200 {
3201    int j;
3202    char *symbol;
3203    Elf_Word* targ;
3204    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
3205    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
3206    int target_shndx = shdr[shnum].sh_info;
3207    int symtab_shndx = shdr[shnum].sh_link;
3208
3209    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3210    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
3211    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3212                           target_shndx, symtab_shndx ));
3213
3214    /* Skip sections that we're not interested in. */
3215    {
3216        int is_bss;
3217        SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
3218        if (kind == SECTIONKIND_OTHER) {
3219            IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
3220            return 1;
3221        }
3222    }
3223
3224    for (j = 0; j < nent; j++) {
3225       Elf_Addr offset = rtab[j].r_offset;
3226       Elf_Addr info   = rtab[j].r_info;
3227
3228       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
3229       Elf_Word* pP = (Elf_Word*)P;
3230       Elf_Addr  A  = *pP;
3231       Elf_Addr  S;
3232       void*     S_tmp;
3233       Elf_Addr  value;
3234       StgStablePtr stablePtr;
3235       StgPtr stableVal;
3236
3237       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
3238                              j, (void*)offset, (void*)info ));
3239       if (!info) {
3240          IF_DEBUG(linker,debugBelch( " ZERO" ));
3241          S = 0;
3242       } else {
3243          Elf_Sym sym = stab[ELF_R_SYM(info)];
3244          /* First see if it is a local symbol. */
3245          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3246             /* Yes, so we can get the address directly from the ELF symbol
3247                table. */
3248             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3249             S = (Elf_Addr)
3250                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3251                        + stab[ELF_R_SYM(info)].st_value);
3252
3253          } else {
3254             symbol = strtab + sym.st_name;
3255             stablePtr = (StgStablePtr)lookupHashTable(stablehash, (StgWord)symbol);
3256             if (NULL == stablePtr) {
3257               /* No, so look up the name in our global table. */
3258               S_tmp = lookupSymbol( symbol );
3259               S = (Elf_Addr)S_tmp;
3260             } else {
3261               stableVal = deRefStablePtr( stablePtr );
3262               S_tmp = stableVal;
3263               S = (Elf_Addr)S_tmp;
3264             }
3265          }
3266          if (!S) {
3267             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3268             return 0;
3269          }
3270          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n", symbol, (void*)S ));
3271       }
3272
3273       IF_DEBUG(linker,debugBelch( "Reloc: P = %p   S = %p   A = %p\n",
3274                              (void*)P, (void*)S, (void*)A ));
3275       checkProddableBlock ( oc, pP );
3276
3277       value = S + A;
3278
3279       switch (ELF_R_TYPE(info)) {
3280 #        ifdef i386_HOST_ARCH
3281          case R_386_32:   *pP = value;     break;
3282          case R_386_PC32: *pP = value - P; break;
3283 #        endif
3284          default:
3285             errorBelch("%s: unhandled ELF relocation(Rel) type %lu\n",
3286                   oc->fileName, (lnat)ELF_R_TYPE(info));
3287             return 0;
3288       }
3289
3290    }
3291    return 1;
3292 }
3293
3294 /* Do ELF relocations for which explicit addends are supplied.
3295    sparc-solaris relocations appear to be of this form. */
3296 static int
3297 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
3298                           Elf_Shdr* shdr, int shnum,
3299                           Elf_Sym*  stab, char* strtab )
3300 {
3301    int j;
3302    char *symbol = NULL;
3303    Elf_Addr targ;
3304    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
3305    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
3306    int target_shndx = shdr[shnum].sh_info;
3307    int symtab_shndx = shdr[shnum].sh_link;
3308
3309    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3310    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
3311    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3312                           target_shndx, symtab_shndx ));
3313
3314    for (j = 0; j < nent; j++) {
3315 #if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3316       /* This #ifdef only serves to avoid unused-var warnings. */
3317       Elf_Addr  offset = rtab[j].r_offset;
3318       Elf_Addr  P      = targ + offset;
3319 #endif
3320       Elf_Addr  info   = rtab[j].r_info;
3321       Elf_Addr  A      = rtab[j].r_addend;
3322       Elf_Addr  S;
3323       void*     S_tmp;
3324       Elf_Addr  value;
3325 #     if defined(sparc_HOST_ARCH)
3326       Elf_Word* pP = (Elf_Word*)P;
3327       Elf_Word  w1, w2;
3328 #     elif defined(ia64_HOST_ARCH)
3329       Elf64_Xword *pP = (Elf64_Xword *)P;
3330       Elf_Addr addr;
3331 #     elif defined(powerpc_HOST_ARCH)
3332       Elf_Sword delta;
3333 #     endif
3334
3335       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p %6p)   ",
3336                              j, (void*)offset, (void*)info,
3337                                 (void*)A ));
3338       if (!info) {
3339          IF_DEBUG(linker,debugBelch( " ZERO" ));
3340          S = 0;
3341       } else {
3342          Elf_Sym sym = stab[ELF_R_SYM(info)];
3343          /* First see if it is a local symbol. */
3344          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3345             /* Yes, so we can get the address directly from the ELF symbol
3346                table. */
3347             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3348             S = (Elf_Addr)
3349                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3350                        + stab[ELF_R_SYM(info)].st_value);
3351 #ifdef ELF_FUNCTION_DESC
3352             /* Make a function descriptor for this function */
3353             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
3354                S = allocateFunctionDesc(S + A);
3355                A = 0;
3356             }
3357 #endif
3358          } else {
3359             /* No, so look up the name in our global table. */
3360             symbol = strtab + sym.st_name;
3361             S_tmp = lookupSymbol( symbol );
3362             S = (Elf_Addr)S_tmp;
3363
3364 #ifdef ELF_FUNCTION_DESC
3365             /* If a function, already a function descriptor - we would
3366                have to copy it to add an offset. */
3367             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
3368                errorBelch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
3369 #endif
3370          }
3371          if (!S) {
3372            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3373            return 0;
3374          }
3375          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p", symbol, (void*)S ));
3376       }
3377
3378       IF_DEBUG(linker,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
3379                                         (void*)P, (void*)S, (void*)A ));
3380       /* checkProddableBlock ( oc, (void*)P ); */
3381
3382       value = S + A;
3383
3384       switch (ELF_R_TYPE(info)) {
3385 #        if defined(sparc_HOST_ARCH)
3386          case R_SPARC_WDISP30:
3387             w1 = *pP & 0xC0000000;
3388             w2 = (Elf_Word)((value - P) >> 2);
3389             ASSERT((w2 & 0xC0000000) == 0);
3390             w1 |= w2;
3391             *pP = w1;
3392             break;
3393          case R_SPARC_HI22:
3394             w1 = *pP & 0xFFC00000;
3395             w2 = (Elf_Word)(value >> 10);
3396             ASSERT((w2 & 0xFFC00000) == 0);
3397             w1 |= w2;
3398             *pP = w1;
3399             break;
3400          case R_SPARC_LO10:
3401             w1 = *pP & ~0x3FF;
3402             w2 = (Elf_Word)(value & 0x3FF);
3403             ASSERT((w2 & ~0x3FF) == 0);
3404             w1 |= w2;
3405             *pP = w1;
3406             break;
3407          /* According to the Sun documentation:
3408             R_SPARC_UA32
3409             This relocation type resembles R_SPARC_32, except it refers to an
3410             unaligned word. That is, the word to be relocated must be treated
3411             as four separate bytes with arbitrary alignment, not as a word
3412             aligned according to the architecture requirements.
3413
3414             (JRS: which means that freeloading on the R_SPARC_32 case
3415             is probably wrong, but hey ...)
3416          */
3417          case R_SPARC_UA32:
3418          case R_SPARC_32:
3419             w2 = (Elf_Word)value;
3420             *pP = w2;
3421             break;
3422 #        elif defined(ia64_HOST_ARCH)
3423          case R_IA64_DIR64LSB:
3424          case R_IA64_FPTR64LSB:
3425             *pP = value;
3426             break;
3427          case R_IA64_PCREL64LSB:
3428             *pP = value - P;
3429             break;
3430          case R_IA64_SEGREL64LSB:
3431             addr = findElfSegment(ehdrC, value);
3432             *pP = value - addr;
3433             break;
3434          case R_IA64_GPREL22:
3435             ia64_reloc_gprel22(P, value);
3436             break;
3437          case R_IA64_LTOFF22:
3438          case R_IA64_LTOFF22X:
3439          case R_IA64_LTOFF_FPTR22:
3440             addr = allocateGOTEntry(value);
3441             ia64_reloc_gprel22(P, addr);
3442             break;
3443          case R_IA64_PCREL21B:
3444             ia64_reloc_pcrel21(P, S, oc);
3445             break;
3446          case R_IA64_LDXMOV:
3447             /* This goes with R_IA64_LTOFF22X and points to the load to
3448              * convert into a move.  We don't implement relaxation. */
3449             break;
3450 #        elif defined(powerpc_HOST_ARCH)
3451          case R_PPC_ADDR16_LO:
3452             *(Elf32_Half*) P = value;
3453             break;
3454
3455          case R_PPC_ADDR16_HI:
3456             *(Elf32_Half*) P = value >> 16;
3457             break;
3458
3459          case R_PPC_ADDR16_HA:
3460             *(Elf32_Half*) P = (value + 0x8000) >> 16;
3461             break;
3462
3463          case R_PPC_ADDR32:
3464             *(Elf32_Word *) P = value;
3465             break;
3466
3467          case R_PPC_REL32:
3468             *(Elf32_Word *) P = value - P;
3469             break;
3470
3471          case R_PPC_REL24:
3472             delta = value - P;
3473
3474             if( delta << 6 >> 6 != delta )
3475             {
3476                value = (Elf_Addr) (&makeSymbolExtra( oc, ELF_R_SYM(info), value )
3477                                         ->jumpIsland);
3478                delta = value - P;
3479
3480                if( value == 0 || delta << 6 >> 6 != delta )
3481                {
3482                   barf( "Unable to make SymbolExtra for #%d",
3483                         ELF_R_SYM(info) );
3484                   return 0;
3485                }
3486             }
3487
3488             *(Elf_Word *) P = (*(Elf_Word *) P & 0xfc000003)
3489                                           | (delta & 0x3fffffc);
3490             break;
3491 #        endif
3492
3493 #if x86_64_HOST_ARCH
3494       case R_X86_64_64:
3495           *(Elf64_Xword *)P = value;
3496           break;
3497
3498       case R_X86_64_PC32:
3499       {
3500           StgInt64 off = value - P;
3501           if (off >= 0x7fffffffL || off < -0x80000000L) {
3502 #if X86_64_ELF_NONPIC_HACK
3503               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3504                                                 -> jumpIsland;
3505               off = pltAddress + A - P;
3506 #else
3507               barf("R_X86_64_PC32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
3508                    symbol, off, oc->fileName );
3509 #endif
3510           }
3511           *(Elf64_Word *)P = (Elf64_Word)off;
3512           break;
3513       }
3514
3515       case R_X86_64_PC64:
3516       {
3517           StgInt64 off = value - P;
3518           *(Elf64_Word *)P = (Elf64_Word)off;
3519           break;
3520       }
3521
3522       case R_X86_64_32:
3523           if (value >= 0x7fffffffL) {
3524 #if X86_64_ELF_NONPIC_HACK
3525               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3526                                                 -> jumpIsland;
3527               value = pltAddress + A;
3528 #else
3529               barf("R_X86_64_32 relocation out of range: %s = %p\nRecompile %s with -fPIC.",
3530                    symbol, value, oc->fileName );
3531 #endif
3532           }
3533           *(Elf64_Word *)P = (Elf64_Word)value;
3534           break;
3535
3536       case R_X86_64_32S:
3537           if ((StgInt64)value > 0x7fffffffL || (StgInt64)value < -0x80000000L) {
3538 #if X86_64_ELF_NONPIC_HACK
3539               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3540                                                 -> jumpIsland;
3541               value = pltAddress + A;
3542 #else
3543               barf("R_X86_64_32S relocation out of range: %s = %p\nRecompile %s with -fPIC.",
3544                    symbol, value, oc->fileName );
3545 #endif
3546           }
3547           *(Elf64_Sword *)P = (Elf64_Sword)value;
3548           break;
3549
3550       case R_X86_64_GOTPCREL:
3551       {
3552           StgInt64 gotAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)->addr;
3553           StgInt64 off = gotAddress + A - P;
3554           *(Elf64_Word *)P = (Elf64_Word)off;
3555           break;
3556       }
3557
3558       case R_X86_64_PLT32:
3559       {
3560           StgInt64 off = value - P;
3561           if (off >= 0x7fffffffL || off < -0x80000000L) {
3562               StgInt64 pltAddress = (StgInt64) &makeSymbolExtra(oc, ELF_R_SYM(info), S)
3563                                                     -> jumpIsland;
3564               off = pltAddress + A - P;
3565           }
3566           *(Elf64_Word *)P = (Elf64_Word)off;
3567           break;
3568       }
3569 #endif
3570
3571          default:
3572             errorBelch("%s: unhandled ELF relocation(RelA) type %lu\n",
3573                   oc->fileName, (lnat)ELF_R_TYPE(info));
3574             return 0;
3575       }
3576
3577    }
3578    return 1;
3579 }
3580
3581 static int
3582 ocResolve_ELF ( ObjectCode* oc )
3583 {
3584    char *strtab;
3585    int   shnum, ok;
3586    Elf_Sym*  stab  = NULL;
3587    char*     ehdrC = (char*)(oc->image);
3588    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
3589    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3590
3591    /* first find "the" symbol table */
3592    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
3593
3594    /* also go find the string table */
3595    strtab = findElfSection ( ehdrC, SHT_STRTAB );
3596
3597    if (stab == NULL || strtab == NULL) {
3598       errorBelch("%s: can't find string or symbol table", oc->fileName);
3599       return 0;
3600    }
3601
3602    /* Process the relocation sections. */
3603    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
3604       if (shdr[shnum].sh_type == SHT_REL) {
3605          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
3606                                        shnum, stab, strtab );
3607          if (!ok) return ok;
3608       }
3609       else
3610       if (shdr[shnum].sh_type == SHT_RELA) {
3611          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
3612                                         shnum, stab, strtab );
3613          if (!ok) return ok;
3614       }
3615    }
3616
3617 #if defined(powerpc_HOST_ARCH)
3618    ocFlushInstructionCache( oc );
3619 #endif
3620
3621    return 1;
3622 }
3623
3624 /*
3625  * IA64 specifics
3626  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
3627  * at the front.  The following utility functions pack and unpack instructions, and
3628  * take care of the most common relocations.
3629  */
3630
3631 #ifdef ia64_HOST_ARCH
3632
3633 static Elf64_Xword
3634 ia64_extract_instruction(Elf64_Xword *target)
3635 {
3636    Elf64_Xword w1, w2;
3637    int slot = (Elf_Addr)target & 3;
3638    target = (Elf_Addr)target & ~3;
3639
3640    w1 = *target;
3641    w2 = *(target+1);
3642
3643    switch (slot)
3644    {
3645       case 0:
3646          return ((w1 >> 5) & 0x1ffffffffff);
3647       case 1:
3648          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
3649       case 2:
3650          return (w2 >> 23);
3651       default:
3652          barf("ia64_extract_instruction: invalid slot %p", target);
3653    }
3654 }
3655
3656 static void
3657 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
3658 {
3659    int slot = (Elf_Addr)target & 3;
3660    target = (Elf_Addr)target & ~3;
3661
3662    switch (slot)
3663    {
3664       case 0:
3665          *target |= value << 5;
3666          break;
3667       case 1:
3668          *target |= value << 46;
3669          *(target+1) |= value >> 18;
3670          break;
3671       case 2:
3672          *(target+1) |= value << 23;
3673          break;
3674    }
3675 }
3676
3677 static void
3678 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
3679 {
3680    Elf64_Xword instruction;
3681    Elf64_Sxword rel_value;
3682
3683    rel_value = value - gp_val;
3684    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
3685       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
3686
3687    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3688    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
3689                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
3690                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
3691                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3692    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3693 }
3694
3695 static void
3696 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
3697 {
3698    Elf64_Xword instruction;
3699    Elf64_Sxword rel_value;
3700    Elf_Addr entry;
3701
3702    entry = allocatePLTEntry(value, oc);
3703
3704    rel_value = (entry >> 4) - (target >> 4);
3705    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
3706       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
3707
3708    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3709    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
3710                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3711    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3712 }
3713
3714 #endif /* ia64 */
3715
3716 /*
3717  * PowerPC & X86_64 ELF specifics
3718  */
3719
3720 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3721
3722 static int ocAllocateSymbolExtras_ELF( ObjectCode *oc )
3723 {
3724   Elf_Ehdr *ehdr;
3725   Elf_Shdr* shdr;
3726   int i;
3727
3728   ehdr = (Elf_Ehdr *) oc->image;
3729   shdr = (Elf_Shdr *) ( ((char *)oc->image) + ehdr->e_shoff );
3730
3731   for( i = 0; i < ehdr->e_shnum; i++ )
3732     if( shdr[i].sh_type == SHT_SYMTAB )
3733       break;
3734
3735   if( i == ehdr->e_shnum )
3736   {
3737     errorBelch( "This ELF file contains no symtab" );
3738     return 0;
3739   }
3740
3741   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
3742   {
3743     errorBelch( "The entry size (%d) of the symtab isn't %d\n",
3744       (int) shdr[i].sh_entsize, (int) sizeof( Elf_Sym ) );
3745
3746     return 0;
3747   }
3748
3749   return ocAllocateSymbolExtras( oc, shdr[i].sh_size / sizeof( Elf_Sym ), 0 );
3750 }
3751
3752 #endif /* powerpc */
3753
3754 #endif /* ELF */
3755
3756 /* --------------------------------------------------------------------------
3757  * Mach-O specifics
3758  * ------------------------------------------------------------------------*/
3759
3760 #if defined(OBJFORMAT_MACHO)
3761
3762 /*
3763   Support for MachO linking on Darwin/MacOS X
3764   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
3765
3766   I hereby formally apologize for the hackish nature of this code.
3767   Things that need to be done:
3768   *) implement ocVerifyImage_MachO
3769   *) add still more sanity checks.
3770 */
3771
3772 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
3773 #define mach_header mach_header_64
3774 #define segment_command segment_command_64
3775 #define section section_64
3776 #define nlist nlist_64
3777 #endif
3778
3779 #ifdef powerpc_HOST_ARCH
3780 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
3781 {
3782     struct mach_header *header = (struct mach_header *) oc->image;
3783     struct load_command *lc = (struct load_command *) (header + 1);
3784     unsigned i;
3785
3786     for( i = 0; i < header->ncmds; i++ )
3787     {
3788         if( lc->cmd == LC_SYMTAB )
3789         {
3790                 // Find out the first and last undefined external
3791                 // symbol, so we don't have to allocate too many
3792                 // jump islands.
3793             struct symtab_command *symLC = (struct symtab_command *) lc;
3794             unsigned min = symLC->nsyms, max = 0;
3795             struct nlist *nlist =
3796                 symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
3797                       : NULL;
3798             for(i=0;i<symLC->nsyms;i++)
3799             {
3800                 if(nlist[i].n_type & N_STAB)
3801                     ;
3802                 else if(nlist[i].n_type & N_EXT)
3803                 {
3804                     if((nlist[i].n_type & N_TYPE) == N_UNDF
3805                         && (nlist[i].n_value == 0))
3806                     {
3807                         if(i < min)
3808                             min = i;
3809                         if(i > max)
3810                             max = i;
3811                     }
3812                 }
3813             }
3814             if(max >= min)
3815                 return ocAllocateSymbolExtras(oc, max - min + 1, min);
3816
3817             break;
3818         }
3819
3820         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3821     }
3822     return ocAllocateSymbolExtras(oc,0,0);
3823 }
3824 #endif
3825 #ifdef x86_64_HOST_ARCH
3826 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
3827 {
3828     struct mach_header *header = (struct mach_header *) oc->image;
3829     struct load_command *lc = (struct load_command *) (header + 1);
3830     unsigned i;
3831
3832     for( i = 0; i < header->ncmds; i++ )
3833     {
3834         if( lc->cmd == LC_SYMTAB )
3835         {
3836                 // Just allocate one entry for every symbol
3837             struct symtab_command *symLC = (struct symtab_command *) lc;
3838
3839             return ocAllocateSymbolExtras(oc, symLC->nsyms, 0);
3840         }
3841
3842         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3843     }
3844     return ocAllocateSymbolExtras(oc,0,0);
3845 }
3846 #endif
3847
3848 static int ocVerifyImage_MachO(ObjectCode* oc)
3849 {
3850     char *image = (char*) oc->image;
3851     struct mach_header *header = (struct mach_header*) image;
3852
3853 #if x86_64_TARGET_ARCH || powerpc64_TARGET_ARCH
3854     if(header->magic != MH_MAGIC_64)
3855         return 0;
3856 #else
3857     if(header->magic != MH_MAGIC)
3858         return 0;
3859 #endif
3860     // FIXME: do some more verifying here
3861     return 1;
3862 }
3863
3864 static int resolveImports(
3865     ObjectCode* oc,
3866     char *image,
3867     struct symtab_command *symLC,
3868     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
3869     unsigned long *indirectSyms,
3870     struct nlist *nlist)
3871 {
3872     unsigned i;
3873     size_t itemSize = 4;
3874
3875 #if i386_HOST_ARCH
3876     int isJumpTable = 0;
3877     if(!strcmp(sect->sectname,"__jump_table"))
3878     {
3879         isJumpTable = 1;
3880         itemSize = 5;
3881         ASSERT(sect->reserved2 == itemSize);
3882     }
3883 #endif
3884
3885     for(i=0; i*itemSize < sect->size;i++)
3886     {
3887         // according to otool, reserved1 contains the first index into the indirect symbol table
3888         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
3889         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3890         void *addr = NULL;
3891
3892         if((symbol->n_type & N_TYPE) == N_UNDF
3893             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
3894             addr = (void*) (symbol->n_value);
3895         else
3896             addr = lookupSymbol(nm);
3897         if(!addr)
3898         {
3899             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
3900             return 0;
3901         }
3902         ASSERT(addr);
3903
3904 #if i386_HOST_ARCH
3905         if(isJumpTable)
3906         {
3907             checkProddableBlock(oc,image + sect->offset + i*itemSize);
3908             *(image + sect->offset + i*itemSize) = 0xe9; // jmp
3909             *(unsigned*)(image + sect->offset + i*itemSize + 1)
3910                 = (char*)addr - (image + sect->offset + i*itemSize + 5);
3911         }
3912         else
3913 #endif
3914         {
3915             checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
3916             ((void**)(image + sect->offset))[i] = addr;
3917         }
3918     }
3919
3920     return 1;
3921 }
3922
3923 static unsigned long relocateAddress(
3924     ObjectCode* oc,
3925     int nSections,
3926     struct section* sections,
3927     unsigned long address)
3928 {
3929     int i;
3930     for(i = 0; i < nSections; i++)
3931     {
3932         if(sections[i].addr <= address
3933             && address < sections[i].addr + sections[i].size)
3934         {
3935             return (unsigned long)oc->image
3936                     + sections[i].offset + address - sections[i].addr;
3937         }
3938     }
3939     barf("Invalid Mach-O file:"
3940          "Address out of bounds while relocating object file");
3941     return 0;
3942 }
3943
3944 static int relocateSection(
3945     ObjectCode* oc,
3946     char *image,
3947     struct symtab_command *symLC, struct nlist *nlist,
3948     int nSections, struct section* sections, struct section *sect)
3949 {
3950     struct relocation_info *relocs;
3951     int i,n;
3952
3953     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
3954         return 1;
3955     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
3956         return 1;
3957     else if(!strcmp(sect->sectname,"__la_sym_ptr2"))
3958         return 1;
3959     else if(!strcmp(sect->sectname,"__la_sym_ptr3"))
3960         return 1;
3961
3962     n = sect->nreloc;
3963     relocs = (struct relocation_info*) (image + sect->reloff);
3964
3965     for(i=0;i<n;i++)
3966     {
3967 #ifdef x86_64_HOST_ARCH
3968         struct relocation_info *reloc = &relocs[i];
3969
3970         char    *thingPtr = image + sect->offset + reloc->r_address;
3971         uint64_t thing;
3972         uint64_t value;
3973         uint64_t baseValue;
3974         int type = reloc->r_type;
3975
3976         checkProddableBlock(oc,thingPtr);
3977         switch(reloc->r_length)
3978         {
3979             case 0:
3980                 thing = *(uint8_t*)thingPtr;
3981                 baseValue = (uint64_t)thingPtr + 1;
3982                 break;
3983             case 1:
3984                 thing = *(uint16_t*)thingPtr;
3985                 baseValue = (uint64_t)thingPtr + 2;
3986                 break;
3987             case 2:
3988                 thing = *(uint32_t*)thingPtr;
3989                 baseValue = (uint64_t)thingPtr + 4;
3990                 break;
3991             case 3:
3992                 thing = *(uint64_t*)thingPtr;
3993                 baseValue = (uint64_t)thingPtr + 8;
3994                 break;
3995             default:
3996                 barf("Unknown size.");
3997         }
3998
3999         if(type == X86_64_RELOC_GOT
4000            || type == X86_64_RELOC_GOT_LOAD)
4001         {
4002             ASSERT(reloc->r_extern);
4003             value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)->addr;
4004
4005             type = X86_64_RELOC_SIGNED;
4006         }
4007         else if(reloc->r_extern)
4008         {
4009             struct nlist *symbol = &nlist[reloc->r_symbolnum];
4010             char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4011             if(symbol->n_value == 0)
4012                 value = (uint64_t) lookupSymbol(nm);
4013             else
4014                 value = relocateAddress(oc, nSections, sections,
4015                                         symbol->n_value);
4016         }
4017         else
4018         {
4019             value = sections[reloc->r_symbolnum-1].offset
4020                   - sections[reloc->r_symbolnum-1].addr
4021                   + (uint64_t) image;
4022         }
4023
4024         if(type == X86_64_RELOC_BRANCH)
4025         {
4026             if((int32_t)(value - baseValue) != (int64_t)(value - baseValue))
4027             {
4028                 ASSERT(reloc->r_extern);
4029                 value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)
4030                                         -> jumpIsland;
4031             }
4032             ASSERT((int32_t)(value - baseValue) == (int64_t)(value - baseValue));
4033             type = X86_64_RELOC_SIGNED;
4034         }
4035
4036         switch(type)
4037         {
4038             case X86_64_RELOC_UNSIGNED:
4039                 ASSERT(!reloc->r_pcrel);
4040                 thing += value;
4041                 break;
4042             case X86_64_RELOC_SIGNED:
4043                 ASSERT(reloc->r_pcrel);
4044                 thing += value - baseValue;
4045                 break;
4046             case X86_64_RELOC_SUBTRACTOR:
4047                 ASSERT(!reloc->r_pcrel);
4048                 thing -= value;
4049                 break;
4050             default:
4051                 barf("unkown relocation");
4052         }
4053
4054         switch(reloc->r_length)
4055         {
4056             case 0:
4057                 *(uint8_t*)thingPtr = thing;
4058                 break;
4059             case 1:
4060                 *(uint16_t*)thingPtr = thing;
4061                 break;
4062             case 2:
4063                 *(uint32_t*)thingPtr = thing;
4064                 break;
4065             case 3:
4066                 *(uint64_t*)thingPtr = thing;
4067                 break;
4068         }
4069 #else
4070         if(relocs[i].r_address & R_SCATTERED)
4071         {
4072             struct scattered_relocation_info *scat =
4073                 (struct scattered_relocation_info*) &relocs[i];
4074
4075             if(!scat->r_pcrel)
4076             {
4077                 if(scat->r_length == 2)
4078                 {
4079                     unsigned long word = 0;
4080                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
4081                     checkProddableBlock(oc,wordPtr);
4082
4083                     // Note on relocation types:
4084                     // i386 uses the GENERIC_RELOC_* types,
4085                     // while ppc uses special PPC_RELOC_* types.
4086                     // *_RELOC_VANILLA and *_RELOC_PAIR have the same value
4087                     // in both cases, all others are different.
4088                     // Therefore, we use GENERIC_RELOC_VANILLA
4089                     // and GENERIC_RELOC_PAIR instead of the PPC variants,
4090                     // and use #ifdefs for the other types.
4091
4092                     // Step 1: Figure out what the relocated value should be
4093                     if(scat->r_type == GENERIC_RELOC_VANILLA)
4094                     {
4095                         word = *wordPtr + (unsigned long) relocateAddress(
4096                                                                 oc,
4097                                                                 nSections,
4098                                                                 sections,
4099                                                                 scat->r_value)
4100                                         - scat->r_value;
4101                     }
4102 #ifdef powerpc_HOST_ARCH
4103                     else if(scat->r_type == PPC_RELOC_SECTDIFF
4104                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
4105                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
4106                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
4107 #else
4108                     else if(scat->r_type == GENERIC_RELOC_SECTDIFF)
4109 #endif
4110                     {
4111                         struct scattered_relocation_info *pair =
4112                                 (struct scattered_relocation_info*) &relocs[i+1];
4113
4114                         if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR)
4115                             barf("Invalid Mach-O file: "
4116                                  "RELOC_*_SECTDIFF not followed by RELOC_PAIR");
4117
4118                         word = (unsigned long)
4119                                (relocateAddress(oc, nSections, sections, scat->r_value)
4120                               - relocateAddress(oc, nSections, sections, pair->r_value));
4121                         i++;
4122                     }
4123 #ifdef powerpc_HOST_ARCH
4124                     else if(scat->r_type == PPC_RELOC_HI16
4125                          || scat->r_type == PPC_RELOC_LO16
4126                          || scat->r_type == PPC_RELOC_HA16
4127                          || scat->r_type == PPC_RELOC_LO14)
4128                     {   // these are generated by label+offset things
4129                         struct relocation_info *pair = &relocs[i+1];
4130                         if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
4131                             barf("Invalid Mach-O file: "
4132                                  "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
4133
4134                         if(scat->r_type == PPC_RELOC_LO16)
4135                         {
4136                             word = ((unsigned short*) wordPtr)[1];
4137                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4138                         }
4139                         else if(scat->r_type == PPC_RELOC_LO14)
4140                         {
4141                             barf("Unsupported Relocation: PPC_RELOC_LO14");
4142                             word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
4143                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4144                         }
4145                         else if(scat->r_type == PPC_RELOC_HI16)
4146                         {
4147                             word = ((unsigned short*) wordPtr)[1] << 16;
4148                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4149                         }
4150                         else if(scat->r_type == PPC_RELOC_HA16)
4151                         {
4152                             word = ((unsigned short*) wordPtr)[1] << 16;
4153                             word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4154                         }
4155
4156
4157                         word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
4158                                                 - scat->r_value;
4159
4160                         i++;
4161                     }
4162  #endif
4163                     else
4164                         continue;  // ignore the others
4165
4166 #ifdef powerpc_HOST_ARCH
4167                     if(scat->r_type == GENERIC_RELOC_VANILLA
4168                         || scat->r_type == PPC_RELOC_SECTDIFF)
4169 #else
4170                     if(scat->r_type == GENERIC_RELOC_VANILLA
4171                         || scat->r_type == GENERIC_RELOC_SECTDIFF)
4172 #endif
4173                     {
4174                         *wordPtr = word;
4175                     }
4176 #ifdef powerpc_HOST_ARCH
4177                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
4178                     {
4179                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4180                     }
4181                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
4182                     {
4183                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4184                     }
4185                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
4186                     {
4187                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4188                             + ((word & (1<<15)) ? 1 : 0);
4189                     }
4190 #endif
4191                 }
4192             }
4193
4194             continue; // FIXME: I hope it's OK to ignore all the others.
4195         }
4196         else
4197         {
4198             struct relocation_info *reloc = &relocs[i];
4199             if(reloc->r_pcrel && !reloc->r_extern)
4200                 continue;
4201
4202             if(reloc->r_length == 2)
4203             {
4204                 unsigned long word = 0;
4205 #ifdef powerpc_HOST_ARCH
4206                 unsigned long jumpIsland = 0;
4207                 long offsetToJumpIsland = 0xBADBAD42; // initialise to bad value
4208                                                       // to avoid warning and to catch
4209                                                       // bugs.
4210 #endif
4211
4212                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
4213                 checkProddableBlock(oc,wordPtr);
4214
4215                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4216                 {
4217                     word = *wordPtr;
4218                 }
4219 #ifdef powerpc_HOST_ARCH
4220                 else if(reloc->r_type == PPC_RELOC_LO16)
4221                 {
4222                     word = ((unsigned short*) wordPtr)[1];
4223                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4224                 }
4225                 else if(reloc->r_type == PPC_RELOC_HI16)
4226                 {
4227                     word = ((unsigned short*) wordPtr)[1] << 16;
4228                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4229                 }
4230                 else if(reloc->r_type == PPC_RELOC_HA16)
4231                 {
4232                     word = ((unsigned short*) wordPtr)[1] << 16;
4233                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4234                 }
4235                 else if(reloc->r_type == PPC_RELOC_BR24)
4236                 {
4237                     word = *wordPtr;
4238                     word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0);
4239                 }
4240 #endif
4241
4242                 if(!reloc->r_extern)
4243                 {
4244                     long delta =
4245                         sections[reloc->r_symbolnum-1].offset
4246                         - sections[reloc->r_symbolnum-1].addr
4247                         + ((long) image);
4248
4249                     word += delta;
4250                 }
4251                 else
4252                 {
4253                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
4254                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4255                     void *symbolAddress = lookupSymbol(nm);
4256                     if(!symbolAddress)
4257                     {
4258                         errorBelch("\nunknown symbol `%s'", nm);
4259                         return 0;
4260                     }
4261
4262                     if(reloc->r_pcrel)
4263                     {
4264 #ifdef powerpc_HOST_ARCH
4265                             // In the .o file, this should be a relative jump to NULL
4266                             // and we'll change it to a relative jump to the symbol
4267                         ASSERT(word + reloc->r_address == 0);
4268                         jumpIsland = (unsigned long)
4269                                         &makeSymbolExtra(oc,
4270                                                          reloc->r_symbolnum,
4271                                                          (unsigned long) symbolAddress)
4272                                          -> jumpIsland;
4273                         if(jumpIsland != 0)
4274                         {
4275                             offsetToJumpIsland = word + jumpIsland
4276                                 - (((long)image) + sect->offset - sect->addr);
4277                         }
4278 #endif
4279                         word += (unsigned long) symbolAddress
4280                                 - (((long)image) + sect->offset - sect->addr);
4281                     }
4282                     else
4283                     {
4284                         word += (unsigned long) symbolAddress;
4285                     }
4286                 }
4287
4288                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4289                 {
4290                     *wordPtr = word;
4291                     continue;
4292                 }
4293 #ifdef powerpc_HOST_ARCH
4294                 else if(reloc->r_type == PPC_RELOC_LO16)
4295                 {
4296                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4297                     i++; continue;
4298                 }
4299                 else if(reloc->r_type == PPC_RELOC_HI16)
4300                 {
4301                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4302                     i++; continue;
4303                 }
4304                 else if(reloc->r_type == PPC_RELOC_HA16)
4305                 {
4306                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4307                         + ((word & (1<<15)) ? 1 : 0);
4308                     i++; continue;
4309                 }
4310                 else if(reloc->r_type == PPC_RELOC_BR24)
4311                 {
4312                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4313                     {
4314                         // The branch offset is too large.
4315                         // Therefore, we try to use a jump island.
4316                         if(jumpIsland == 0)
4317                         {
4318                             barf("unconditional relative branch out of range: "
4319                                  "no jump island available");
4320                         }
4321
4322                         word = offsetToJumpIsland;
4323                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4324                             barf("unconditional relative branch out of range: "
4325                                  "jump island out of range");
4326                     }
4327                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
4328                     continue;
4329                 }
4330 #endif
4331             }
4332             barf("\nunknown relocation %d",reloc->r_type);
4333             return 0;
4334         }
4335 #endif
4336     }
4337     return 1;
4338 }
4339
4340 static int ocGetNames_MachO(ObjectCode* oc)
4341 {
4342     char *image = (char*) oc->image;
4343     struct mach_header *header = (struct mach_header*) image;
4344     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4345     unsigned i,curSymbol = 0;
4346     struct segment_command *segLC = NULL;
4347     struct section *sections;
4348     struct symtab_command *symLC = NULL;
4349     struct nlist *nlist;
4350     unsigned long commonSize = 0;
4351     char    *commonStorage = NULL;
4352     unsigned long commonCounter;
4353
4354     for(i=0;i<header->ncmds;i++)
4355     {
4356         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4357             segLC = (struct segment_command*) lc;
4358         else if(lc->cmd == LC_SYMTAB)
4359             symLC = (struct symtab_command*) lc;
4360         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4361     }
4362
4363     sections = (struct section*) (segLC+1);
4364     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4365                   : NULL;
4366
4367     if(!segLC)
4368         barf("ocGetNames_MachO: no segment load command");
4369
4370     for(i=0;i<segLC->nsects;i++)
4371     {
4372         if(sections[i].size == 0)
4373             continue;
4374
4375         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
4376         {
4377             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
4378                                       "ocGetNames_MachO(common symbols)");
4379             sections[i].offset = zeroFillArea - image;
4380         }
4381
4382         if(!strcmp(sections[i].sectname,"__text"))
4383             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
4384                 (void*) (image + sections[i].offset),
4385                 (void*) (image + sections[i].offset + sections[i].size));
4386         else if(!strcmp(sections[i].sectname,"__const"))
4387             addSection(oc, SECTIONKIND_RWDATA,
4388                 (void*) (image + sections[i].offset),
4389                 (void*) (image + sections[i].offset + sections[i].size));
4390         else if(!strcmp(sections[i].sectname,"__data"))
4391             addSection(oc, SECTIONKIND_RWDATA,
4392                 (void*) (image + sections[i].offset),
4393                 (void*) (image + sections[i].offset + sections[i].size));
4394         else if(!strcmp(sections[i].sectname,"__bss")
4395                 || !strcmp(sections[i].sectname,"__common"))
4396             addSection(oc, SECTIONKIND_RWDATA,
4397                 (void*) (image + sections[i].offset),
4398                 (void*) (image + sections[i].offset + sections[i].size));
4399
4400         addProddableBlock(oc, (void*) (image + sections[i].offset),
4401                                         sections[i].size);
4402     }
4403
4404         // count external symbols defined here
4405     oc->n_symbols = 0;
4406     if(symLC)
4407     {
4408         for(i=0;i<symLC->nsyms;i++)
4409         {
4410             if(nlist[i].n_type & N_STAB)
4411                 ;
4412             else if(nlist[i].n_type & N_EXT)
4413             {
4414                 if((nlist[i].n_type & N_TYPE) == N_UNDF
4415                     && (nlist[i].n_value != 0))
4416                 {
4417                     commonSize += nlist[i].n_value;
4418                     oc->n_symbols++;
4419                 }
4420                 else if((nlist[i].n_type & N_TYPE) == N_SECT)
4421                     oc->n_symbols++;
4422             }
4423         }
4424     }
4425     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
4426                                    "ocGetNames_MachO(oc->symbols)");
4427
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_TYPE) == N_SECT)
4435             {
4436                 if(nlist[i].n_type & N_EXT)
4437                 {
4438                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4439                     if((nlist[i].n_desc & N_WEAK_DEF) && lookupSymbol(nm))
4440                         ; // weak definition, and we already have a definition
4441                     else
4442                     {
4443                             ghciInsertStrHashTable(oc->fileName, symhash, nm,
4444                                                     image
4445                                                     + sections[nlist[i].n_sect-1].offset
4446                                                     - sections[nlist[i].n_sect-1].addr
4447                                                     + nlist[i].n_value);
4448                             oc->symbols[curSymbol++] = nm;
4449                     }
4450                 }
4451             }
4452         }
4453     }
4454
4455     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
4456     commonCounter = (unsigned long)commonStorage;
4457     if(symLC)
4458     {
4459         for(i=0;i<symLC->nsyms;i++)
4460         {
4461             if((nlist[i].n_type & N_TYPE) == N_UNDF
4462                     && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
4463             {
4464                 char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4465                 unsigned long sz = nlist[i].n_value;
4466
4467                 nlist[i].n_value = commonCounter;
4468
4469                 ghciInsertStrHashTable(oc->fileName, symhash, nm,
4470                                        (void*)commonCounter);
4471                 oc->symbols[curSymbol++] = nm;
4472
4473                 commonCounter += sz;
4474             }
4475         }
4476     }
4477     return 1;
4478 }
4479
4480 static int ocResolve_MachO(ObjectCode* oc)
4481 {
4482     char *image = (char*) oc->image;
4483     struct mach_header *header = (struct mach_header*) image;
4484     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4485     unsigned i;
4486     struct segment_command *segLC = NULL;
4487     struct section *sections;
4488     struct symtab_command *symLC = NULL;
4489     struct dysymtab_command *dsymLC = NULL;
4490     struct nlist *nlist;
4491
4492     for(i=0;i<header->ncmds;i++)
4493     {
4494         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4495             segLC = (struct segment_command*) lc;
4496         else if(lc->cmd == LC_SYMTAB)
4497             symLC = (struct symtab_command*) lc;
4498         else if(lc->cmd == LC_DYSYMTAB)
4499             dsymLC = (struct dysymtab_command*) lc;
4500         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4501     }
4502
4503     sections = (struct section*) (segLC+1);
4504     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4505                   : NULL;
4506
4507     if(dsymLC)
4508     {
4509         unsigned long *indirectSyms
4510             = (unsigned long*) (image + dsymLC->indirectsymoff);
4511
4512         for(i=0;i<segLC->nsects;i++)
4513         {
4514             if(    !strcmp(sections[i].sectname,"__la_symbol_ptr")
4515                 || !strcmp(sections[i].sectname,"__la_sym_ptr2")
4516                 || !strcmp(sections[i].sectname,"__la_sym_ptr3"))
4517             {
4518                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4519                     return 0;
4520             }
4521             else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr")
4522                 ||  !strcmp(sections[i].sectname,"__pointers"))
4523             {
4524                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4525                     return 0;
4526             }
4527             else if(!strcmp(sections[i].sectname,"__jump_table"))
4528             {
4529                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4530                     return 0;
4531             }
4532         }
4533     }
4534
4535     for(i=0;i<segLC->nsects;i++)
4536     {
4537         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
4538             return 0;
4539     }
4540
4541 #if defined (powerpc_HOST_ARCH)
4542     ocFlushInstructionCache( oc );
4543 #endif
4544
4545     return 1;
4546 }
4547
4548 #ifdef powerpc_HOST_ARCH
4549 /*
4550  * The Mach-O object format uses leading underscores. But not everywhere.
4551  * There is a small number of runtime support functions defined in
4552  * libcc_dynamic.a whose name does not have a leading underscore.
4553  * As a consequence, we can't get their address from C code.
4554  * We have to use inline assembler just to take the address of a function.
4555  * Yuck.
4556  */
4557
4558 static void machoInitSymbolsWithoutUnderscore()
4559 {
4560     extern void* symbolsWithoutUnderscore[];
4561     void **p = symbolsWithoutUnderscore;
4562     __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:");
4563
4564 #undef Sym
4565 #define Sym(x)  \
4566     __asm__ volatile(".long " # x);
4567
4568     RTS_MACHO_NOUNDERLINE_SYMBOLS
4569
4570     __asm__ volatile(".text");
4571
4572 #undef Sym
4573 #define Sym(x)  \
4574     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
4575
4576     RTS_MACHO_NOUNDERLINE_SYMBOLS
4577
4578 #undef Sym
4579 }
4580 #endif
4581
4582 /*
4583  * Figure out by how much to shift the entire Mach-O file in memory
4584  * when loading so that its single segment ends up 16-byte-aligned
4585  */
4586 static int machoGetMisalignment( FILE * f )
4587 {
4588     struct mach_header header;
4589     int misalignment;
4590
4591     fread(&header, sizeof(header), 1, f);
4592     rewind(f);
4593
4594 #if x86_64_TARGET_ARCH || powerpc64_TARGET_ARCH
4595     if(header.magic != MH_MAGIC_64)
4596         return 0;
4597 #else
4598     if(header.magic != MH_MAGIC)
4599         return 0;
4600 #endif
4601
4602     misalignment = (header.sizeofcmds + sizeof(header))
4603                     & 0xF;
4604
4605     return misalignment ? (16 - misalignment) : 0;
4606 }
4607
4608 #endif
4609