rts/Linker.c

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