rts/Linker.c

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