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