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