rts/Linker.c

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