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