rts/Linker.c

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