rts/Linker.c

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