rts/Linker.c

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