rts/Linker.c

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