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