rts/Linker.c

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