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