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