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