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