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