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