ghc/rts/Linker.c

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