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