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