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