rts/Linker.c

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