rts/Linker.c

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