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