rts/Linker.c

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