rts/Linker.c

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