rts/Linker.c

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