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