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         debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
2262                    noRelocs);
2263         j = 1;
2264       } else {
2265         noRelocs = sectab_i->NumberOfRelocations;
2266         j = 0;
2267       }
2268
2269
2270       for (; j < noRelocs; j++) {
2271          COFF_symbol* sym;
2272          COFF_reloc* reltab_j
2273             = (COFF_reloc*)
2274               myindex ( sizeof_COFF_reloc, reltab, j );
2275
2276          /* the location to patch */
2277          pP = (UInt32*)(
2278                  ((UChar*)(oc->image))
2279                  + (sectab_i->PointerToRawData
2280                     + reltab_j->VirtualAddress
2281                     - sectab_i->VirtualAddress )
2282               );
2283          /* the existing contents of pP */
2284          A = *pP;
2285          /* the symbol to connect to */
2286          sym = (COFF_symbol*)
2287                myindex ( sizeof_COFF_symbol,
2288                          symtab, reltab_j->SymbolTableIndex );
2289          IF_DEBUG(linker,
2290                   debugBelch(
2291                             "reloc sec %2d num %3d:  type 0x%-4x   "
2292                             "vaddr 0x%-8x   name `",
2293                             i, j,
2294                             (UInt32)reltab_j->Type,
2295                             reltab_j->VirtualAddress );
2296                             printName ( sym->Name, strtab );
2297                             debugBelch("'\n" ));
2298
2299          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
2300             COFF_section* section_sym
2301                = findPEi386SectionCalled ( oc, sym->Name );
2302             if (!section_sym) {
2303                errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
2304                return 0;
2305             }
2306             S = ((UInt32)(oc->image))
2307                 + (section_sym->PointerToRawData
2308                    + sym->Value);
2309          } else {
2310             copyName ( sym->Name, strtab, symbol, 1000-1 );
2311             (void*)S = lookupLocalSymbol( oc, symbol );
2312             if ((void*)S != NULL) goto foundit;
2313             (void*)S = lookupSymbol( symbol );
2314             if ((void*)S != NULL) goto foundit;
2315             zapTrailingAtSign ( symbol );
2316             (void*)S = lookupLocalSymbol( oc, symbol );
2317             if ((void*)S != NULL) goto foundit;
2318             (void*)S = lookupSymbol( symbol );
2319             if ((void*)S != NULL) goto foundit;
2320             /* Newline first because the interactive linker has printed "linking..." */
2321             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
2322             return 0;
2323            foundit:;
2324          }
2325          checkProddableBlock(oc, pP);
2326          switch (reltab_j->Type) {
2327             case MYIMAGE_REL_I386_DIR32:
2328                *pP = A + S;
2329                break;
2330             case MYIMAGE_REL_I386_REL32:
2331                /* Tricky.  We have to insert a displacement at
2332                   pP which, when added to the PC for the _next_
2333                   insn, gives the address of the target (S).
2334                   Problem is to know the address of the next insn
2335                   when we only know pP.  We assume that this
2336                   literal field is always the last in the insn,
2337                   so that the address of the next insn is pP+4
2338                   -- hence the constant 4.
2339                   Also I don't know if A should be added, but so
2340                   far it has always been zero.
2341
2342                   SOF 05/2005: 'A' (old contents of *pP) have been observed
2343                   to contain values other than zero (the 'wx' object file
2344                   that came with wxhaskell-0.9.4; dunno how it was compiled..).
2345                   So, add displacement to old value instead of asserting
2346                   A to be zero. Fixes wxhaskell-related crashes, and no other
2347                   ill effects have been observed.
2348
2349                   Update: the reason why we're seeing these more elaborate
2350                   relocations is due to a switch in how the NCG compiles SRTs
2351                   and offsets to them from info tables. SRTs live in .(ro)data,
2352                   while info tables live in .text, causing GAS to emit REL32/DISP32
2353                   relocations with non-zero values. Adding the displacement is
2354                   the right thing to do.
2355                */
2356                *pP = S - ((UInt32)pP) - 4 + A;
2357                break;
2358             default:
2359                debugBelch("%s: unhandled PEi386 relocation type %d",
2360                      oc->fileName, reltab_j->Type);
2361                return 0;
2362          }
2363
2364       }
2365    }
2366
2367    IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
2368    return 1;
2369 }
2370
2371 #endif /* defined(OBJFORMAT_PEi386) */
2372
2373
2374 /* --------------------------------------------------------------------------
2375  * ELF specifics
2376  * ------------------------------------------------------------------------*/
2377
2378 #if defined(OBJFORMAT_ELF)
2379
2380 #define FALSE 0
2381 #define TRUE  1
2382
2383 #if defined(sparc_HOST_ARCH)
2384 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
2385 #elif defined(i386_HOST_ARCH)
2386 #  define ELF_TARGET_386    /* Used inside <elf.h> */
2387 #elif defined(x86_64_HOST_ARCH)
2388 #  define ELF_TARGET_X64_64
2389 #  define ELF_64BIT
2390 #elif defined (ia64_HOST_ARCH)
2391 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
2392 #  define ELF_64BIT
2393 #  define ELF_FUNCTION_DESC /* calling convention uses function descriptors */
2394 #  define ELF_NEED_GOT      /* needs Global Offset Table */
2395 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
2396 #endif
2397
2398 #if !defined(openbsd_HOST_OS)
2399 #include <elf.h>
2400 #else
2401 /* openbsd elf has things in different places, with diff names */
2402 #include <elf_abi.h>
2403 #include <machine/reloc.h>
2404 #define R_386_32    RELOC_32
2405 #define R_386_PC32  RELOC_PC32
2406 #endif
2407
2408 /*
2409  * Define a set of types which can be used for both ELF32 and ELF64
2410  */
2411
2412 #ifdef ELF_64BIT
2413 #define ELFCLASS    ELFCLASS64
2414 #define Elf_Addr    Elf64_Addr
2415 #define Elf_Word    Elf64_Word
2416 #define Elf_Sword   Elf64_Sword
2417 #define Elf_Ehdr    Elf64_Ehdr
2418 #define Elf_Phdr    Elf64_Phdr
2419 #define Elf_Shdr    Elf64_Shdr
2420 #define Elf_Sym     Elf64_Sym
2421 #define Elf_Rel     Elf64_Rel
2422 #define Elf_Rela    Elf64_Rela
2423 #define ELF_ST_TYPE ELF64_ST_TYPE
2424 #define ELF_ST_BIND ELF64_ST_BIND
2425 #define ELF_R_TYPE  ELF64_R_TYPE
2426 #define ELF_R_SYM   ELF64_R_SYM
2427 #else
2428 #define ELFCLASS    ELFCLASS32
2429 #define Elf_Addr    Elf32_Addr
2430 #define Elf_Word    Elf32_Word
2431 #define Elf_Sword   Elf32_Sword
2432 #define Elf_Ehdr    Elf32_Ehdr
2433 #define Elf_Phdr    Elf32_Phdr
2434 #define Elf_Shdr    Elf32_Shdr
2435 #define Elf_Sym     Elf32_Sym
2436 #define Elf_Rel     Elf32_Rel
2437 #define Elf_Rela    Elf32_Rela
2438 #ifndef ELF_ST_TYPE
2439 #define ELF_ST_TYPE ELF32_ST_TYPE
2440 #endif
2441 #ifndef ELF_ST_BIND
2442 #define ELF_ST_BIND ELF32_ST_BIND
2443 #endif
2444 #ifndef ELF_R_TYPE
2445 #define ELF_R_TYPE  ELF32_R_TYPE
2446 #endif
2447 #ifndef ELF_R_SYM
2448 #define ELF_R_SYM   ELF32_R_SYM
2449 #endif
2450 #endif
2451
2452
2453 /*
2454  * Functions to allocate entries in dynamic sections.  Currently we simply
2455  * preallocate a large number, and we don't check if a entry for the given
2456  * target already exists (a linear search is too slow).  Ideally these
2457  * entries would be associated with symbols.
2458  */
2459
2460 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
2461 #define GOT_SIZE            0x20000
2462 #define FUNCTION_TABLE_SIZE 0x10000
2463 #define PLT_SIZE            0x08000
2464
2465 #ifdef ELF_NEED_GOT
2466 static Elf_Addr got[GOT_SIZE];
2467 static unsigned int gotIndex;
2468 static Elf_Addr gp_val = (Elf_Addr)got;
2469
2470 static Elf_Addr
2471 allocateGOTEntry(Elf_Addr target)
2472 {
2473    Elf_Addr *entry;
2474
2475    if (gotIndex >= GOT_SIZE)
2476       barf("Global offset table overflow");
2477
2478    entry = &got[gotIndex++];
2479    *entry = target;
2480    return (Elf_Addr)entry;
2481 }
2482 #endif
2483
2484 #ifdef ELF_FUNCTION_DESC
2485 typedef struct {
2486    Elf_Addr ip;
2487    Elf_Addr gp;
2488 } FunctionDesc;
2489
2490 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
2491 static unsigned int functionTableIndex;
2492
2493 static Elf_Addr
2494 allocateFunctionDesc(Elf_Addr target)
2495 {
2496    FunctionDesc *entry;
2497
2498    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
2499       barf("Function table overflow");
2500
2501    entry = &functionTable[functionTableIndex++];
2502    entry->ip = target;
2503    entry->gp = (Elf_Addr)gp_val;
2504    return (Elf_Addr)entry;
2505 }
2506
2507 static Elf_Addr
2508 copyFunctionDesc(Elf_Addr target)
2509 {
2510    FunctionDesc *olddesc = (FunctionDesc *)target;
2511    FunctionDesc *newdesc;
2512
2513    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
2514    newdesc->gp = olddesc->gp;
2515    return (Elf_Addr)newdesc;
2516 }
2517 #endif
2518
2519 #ifdef ELF_NEED_PLT
2520 #ifdef ia64_HOST_ARCH
2521 static void ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value);
2522 static void ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc);
2523
2524 static unsigned char plt_code[] =
2525 {
2526    /* taken from binutils bfd/elfxx-ia64.c */
2527    0x0b, 0x78, 0x00, 0x02, 0x00, 0x24,  /*   [MMI]       addl r15=0,r1;;    */
2528    0x00, 0x41, 0x3c, 0x30, 0x28, 0xc0,  /*               ld8 r16=[r15],8    */
2529    0x01, 0x08, 0x00, 0x84,              /*               mov r14=r1;;       */
2530    0x11, 0x08, 0x00, 0x1e, 0x18, 0x10,  /*   [MIB]       ld8 r1=[r15]       */
2531    0x60, 0x80, 0x04, 0x80, 0x03, 0x00,  /*               mov b6=r16         */
2532    0x60, 0x00, 0x80, 0x00               /*               br.few b6;;        */
2533 };
2534
2535 /* If we can't get to the function descriptor via gp, take a local copy of it */
2536 #define PLT_RELOC(code, target) { \
2537    Elf64_Sxword rel_value = target - gp_val; \
2538    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff)) \
2539       ia64_reloc_gprel22((Elf_Addr)code, copyFunctionDesc(target)); \
2540    else \
2541       ia64_reloc_gprel22((Elf_Addr)code, target); \
2542    }
2543 #endif
2544
2545 typedef struct {
2546    unsigned char code[sizeof(plt_code)];
2547 } PLTEntry;
2548
2549 static Elf_Addr
2550 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
2551 {
2552    PLTEntry *plt = (PLTEntry *)oc->plt;
2553    PLTEntry *entry;
2554
2555    if (oc->pltIndex >= PLT_SIZE)
2556       barf("Procedure table overflow");
2557
2558    entry = &plt[oc->pltIndex++];
2559    memcpy(entry->code, plt_code, sizeof(entry->code));
2560    PLT_RELOC(entry->code, target);
2561    return (Elf_Addr)entry;
2562 }
2563
2564 static unsigned int
2565 PLTSize(void)
2566 {
2567    return (PLT_SIZE * sizeof(PLTEntry));
2568 }
2569 #endif
2570
2571
2572 #if x86_64_HOST_ARCH
2573 // On x86_64, 32-bit relocations are often used, which requires that
2574 // we can resolve a symbol to a 32-bit offset.  However, shared
2575 // libraries are placed outside the 2Gb area, which leaves us with a
2576 // problem when we need to give a 32-bit offset to a symbol in a
2577 // shared library.
2578 //
2579 // For a function symbol, we can allocate a bounce sequence inside the
2580 // 2Gb area and resolve the symbol to this.  The bounce sequence is
2581 // simply a long jump instruction to the real location of the symbol.
2582 //
2583 // For data references, we're screwed.
2584 //
2585 typedef struct {
2586     unsigned char jmp[8];  /* 6 byte instruction: jmpq *0x00000002(%rip) */
2587     void *addr;
2588 } x86_64_bounce;
2589
2590 #define X86_64_BB_SIZE 1024
2591
2592 static x86_64_bounce *x86_64_bounce_buffer = NULL;
2593 static nat x86_64_bb_next_off;
2594
2595 static void*
2596 x86_64_high_symbol( char *lbl, void *addr )
2597 {
2598     x86_64_bounce *bounce;
2599
2600     if ( x86_64_bounce_buffer == NULL ||
2601          x86_64_bb_next_off >= X86_64_BB_SIZE ) {
2602         x86_64_bounce_buffer =
2603             mmap(NULL, X86_64_BB_SIZE * sizeof(x86_64_bounce),
2604                  PROT_EXEC|PROT_READ|PROT_WRITE,
2605                  MAP_PRIVATE|MAP_32BIT|MAP_ANONYMOUS, -1, 0);
2606         if (x86_64_bounce_buffer == MAP_FAILED) {
2607             barf("x86_64_high_symbol: mmap failed");
2608         }
2609         x86_64_bb_next_off = 0;
2610     }
2611     bounce = &x86_64_bounce_buffer[x86_64_bb_next_off];
2612     bounce->jmp[0] = 0xff;
2613     bounce->jmp[1] = 0x25;
2614     bounce->jmp[2] = 0x02;
2615     bounce->jmp[3] = 0x00;
2616     bounce->jmp[4] = 0x00;
2617     bounce->jmp[5] = 0x00;
2618     bounce->addr = addr;
2619     x86_64_bb_next_off++;
2620
2621     IF_DEBUG(linker, debugBelch("x86_64: allocated bounce entry for %s->%p at %p\n",
2622                                 lbl, addr, bounce));
2623
2624     insertStrHashTable(symhash, lbl, bounce);
2625     return bounce;
2626 }
2627 #endif
2628
2629
2630 /*
2631  * Generic ELF functions
2632  */
2633
2634 static char *
2635 findElfSection ( void* objImage, Elf_Word sh_type )
2636 {
2637    char* ehdrC = (char*)objImage;
2638    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2639    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
2640    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2641    char* ptr = NULL;
2642    int i;
2643
2644    for (i = 0; i < ehdr->e_shnum; i++) {
2645       if (shdr[i].sh_type == sh_type
2646           /* Ignore the section header's string table. */
2647           && i != ehdr->e_shstrndx
2648           /* Ignore string tables named .stabstr, as they contain
2649              debugging info. */
2650           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2651          ) {
2652          ptr = ehdrC + shdr[i].sh_offset;
2653          break;
2654       }
2655    }
2656    return ptr;
2657 }
2658
2659 #if defined(ia64_HOST_ARCH)
2660 static Elf_Addr
2661 findElfSegment ( void* objImage, Elf_Addr vaddr )
2662 {
2663    char* ehdrC = (char*)objImage;
2664    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2665    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2666    Elf_Addr segaddr = 0;
2667    int i;
2668
2669    for (i = 0; i < ehdr->e_phnum; i++) {
2670       segaddr = phdr[i].p_vaddr;
2671       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2672               break;
2673    }
2674    return segaddr;
2675 }
2676 #endif
2677
2678 static int
2679 ocVerifyImage_ELF ( ObjectCode* oc )
2680 {
2681    Elf_Shdr* shdr;
2682    Elf_Sym*  stab;
2683    int i, j, nent, nstrtab, nsymtabs;
2684    char* sh_strtab;
2685    char* strtab;
2686
2687    char*     ehdrC = (char*)(oc->image);
2688    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2689
2690    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2691        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2692        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2693        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2694       errorBelch("%s: not an ELF object", oc->fileName);
2695       return 0;
2696    }
2697
2698    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2699       errorBelch("%s: unsupported ELF format", oc->fileName);
2700       return 0;
2701    }
2702
2703    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2704        IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
2705    } else
2706    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2707        IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
2708    } else {
2709        errorBelch("%s: unknown endiannness", oc->fileName);
2710        return 0;
2711    }
2712
2713    if (ehdr->e_type != ET_REL) {
2714       errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
2715       return 0;
2716    }
2717    IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
2718
2719    IF_DEBUG(linker,debugBelch( "Architecture is " ));
2720    switch (ehdr->e_machine) {
2721       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
2722       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
2723 #ifdef EM_IA_64
2724       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
2725 #endif
2726       case EM_PPC:   IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
2727 #ifdef EM_X86_64
2728       case EM_X86_64: IF_DEBUG(linker,debugBelch( "x86_64" )); break;
2729 #endif
2730       default:       IF_DEBUG(linker,debugBelch( "unknown" ));
2731                      errorBelch("%s: unknown architecture", oc->fileName);
2732                      return 0;
2733    }
2734
2735    IF_DEBUG(linker,debugBelch(
2736              "\nSection header table: start %ld, n_entries %d, ent_size %d\n",
2737              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
2738
2739    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
2740
2741    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2742
2743    if (ehdr->e_shstrndx == SHN_UNDEF) {
2744       errorBelch("%s: no section header string table", oc->fileName);
2745       return 0;
2746    } else {
2747       IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
2748                           ehdr->e_shstrndx));
2749       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2750    }
2751
2752    for (i = 0; i < ehdr->e_shnum; i++) {
2753       IF_DEBUG(linker,debugBelch("%2d:  ", i ));
2754       IF_DEBUG(linker,debugBelch("type=%2d  ", (int)shdr[i].sh_type ));
2755       IF_DEBUG(linker,debugBelch("size=%4d  ", (int)shdr[i].sh_size ));
2756       IF_DEBUG(linker,debugBelch("offs=%4d  ", (int)shdr[i].sh_offset ));
2757       IF_DEBUG(linker,debugBelch("  (%p .. %p)  ",
2758                ehdrC + shdr[i].sh_offset,
2759                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
2760
2761       if (shdr[i].sh_type == SHT_REL) {
2762           IF_DEBUG(linker,debugBelch("Rel  " ));
2763       } else if (shdr[i].sh_type == SHT_RELA) {
2764           IF_DEBUG(linker,debugBelch("RelA " ));
2765       } else {
2766           IF_DEBUG(linker,debugBelch("     "));
2767       }
2768       if (sh_strtab) {
2769           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
2770       }
2771    }
2772
2773    IF_DEBUG(linker,debugBelch( "\nString tables" ));
2774    strtab = NULL;
2775    nstrtab = 0;
2776    for (i = 0; i < ehdr->e_shnum; i++) {
2777       if (shdr[i].sh_type == SHT_STRTAB
2778           /* Ignore the section header's string table. */
2779           && i != ehdr->e_shstrndx
2780           /* Ignore string tables named .stabstr, as they contain
2781              debugging info. */
2782           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2783          ) {
2784          IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
2785          strtab = ehdrC + shdr[i].sh_offset;
2786          nstrtab++;
2787       }
2788    }
2789    if (nstrtab != 1) {
2790       errorBelch("%s: no string tables, or too many", oc->fileName);
2791       return 0;
2792    }
2793
2794    nsymtabs = 0;
2795    IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
2796    for (i = 0; i < ehdr->e_shnum; i++) {
2797       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2798       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
2799       nsymtabs++;
2800       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2801       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2802       IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%ld rem)\n",
2803                nent,
2804                shdr[i].sh_size % sizeof(Elf_Sym)
2805              ));
2806       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
2807          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
2808          return 0;
2809       }
2810       for (j = 0; j < nent; j++) {
2811          IF_DEBUG(linker,debugBelch("   %2d  ", j ));
2812          IF_DEBUG(linker,debugBelch("  sec=%-5d  size=%-3d  val=%5p  ",
2813                              (int)stab[j].st_shndx,
2814                              (int)stab[j].st_size,
2815                              (char*)stab[j].st_value ));
2816
2817          IF_DEBUG(linker,debugBelch("type=" ));
2818          switch (ELF_ST_TYPE(stab[j].st_info)) {
2819             case STT_NOTYPE:  IF_DEBUG(linker,debugBelch("notype " )); break;
2820             case STT_OBJECT:  IF_DEBUG(linker,debugBelch("object " )); break;
2821             case STT_FUNC  :  IF_DEBUG(linker,debugBelch("func   " )); break;
2822             case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
2823             case STT_FILE:    IF_DEBUG(linker,debugBelch("file   " )); break;
2824             default:          IF_DEBUG(linker,debugBelch("?      " )); break;
2825          }
2826          IF_DEBUG(linker,debugBelch("  " ));
2827
2828          IF_DEBUG(linker,debugBelch("bind=" ));
2829          switch (ELF_ST_BIND(stab[j].st_info)) {
2830             case STB_LOCAL :  IF_DEBUG(linker,debugBelch("local " )); break;
2831             case STB_GLOBAL:  IF_DEBUG(linker,debugBelch("global" )); break;
2832             case STB_WEAK  :  IF_DEBUG(linker,debugBelch("weak  " )); break;
2833             default:          IF_DEBUG(linker,debugBelch("?     " )); break;
2834          }
2835          IF_DEBUG(linker,debugBelch("  " ));
2836
2837          IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
2838       }
2839    }
2840
2841    if (nsymtabs == 0) {
2842       errorBelch("%s: didn't find any symbol tables", oc->fileName);
2843       return 0;
2844    }
2845
2846    return 1;
2847 }
2848
2849 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
2850 {
2851     *is_bss = FALSE;
2852
2853     if (hdr->sh_type == SHT_PROGBITS
2854         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
2855         /* .text-style section */
2856         return SECTIONKIND_CODE_OR_RODATA;
2857     }
2858
2859     if (hdr->sh_type == SHT_PROGBITS
2860             && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
2861             /* .data-style section */
2862             return SECTIONKIND_RWDATA;
2863     }
2864
2865     if (hdr->sh_type == SHT_PROGBITS
2866         && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
2867         /* .rodata-style section */
2868         return SECTIONKIND_CODE_OR_RODATA;
2869     }
2870
2871     if (hdr->sh_type == SHT_NOBITS
2872         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
2873         /* .bss-style section */
2874         *is_bss = TRUE;
2875         return SECTIONKIND_RWDATA;
2876     }
2877
2878     return SECTIONKIND_OTHER;
2879 }
2880
2881
2882 static int
2883 ocGetNames_ELF ( ObjectCode* oc )
2884 {
2885    int i, j, k, nent;
2886    Elf_Sym* stab;
2887
2888    char*     ehdrC    = (char*)(oc->image);
2889    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
2890    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
2891    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2892
2893    ASSERT(symhash != NULL);
2894
2895    if (!strtab) {
2896       errorBelch("%s: no strtab", oc->fileName);
2897       return 0;
2898    }
2899
2900    k = 0;
2901    for (i = 0; i < ehdr->e_shnum; i++) {
2902       /* Figure out what kind of section it is.  Logic derived from
2903          Figure 1.14 ("Special Sections") of the ELF document
2904          ("Portable Formats Specification, Version 1.1"). */
2905       int         is_bss = FALSE;
2906       SectionKind kind   = getSectionKind_ELF(&shdr[i], &is_bss);
2907
2908       if (is_bss && shdr[i].sh_size > 0) {
2909          /* This is a non-empty .bss section.  Allocate zeroed space for
2910             it, and set its .sh_offset field such that
2911             ehdrC + .sh_offset == addr_of_zeroed_space.  */
2912          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
2913                                        "ocGetNames_ELF(BSS)");
2914          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
2915          /*
2916          debugBelch("BSS section at 0x%x, size %d\n",
2917                          zspace, shdr[i].sh_size);
2918          */
2919       }
2920
2921       /* fill in the section info */
2922       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
2923          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
2924          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
2925                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
2926       }
2927
2928       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2929
2930       /* copy stuff into this module's object symbol table */
2931       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2932       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2933
2934       oc->n_symbols = nent;
2935       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
2936                                    "ocGetNames_ELF(oc->symbols)");
2937
2938       for (j = 0; j < nent; j++) {
2939
2940          char  isLocal = FALSE; /* avoids uninit-var warning */
2941          char* ad      = NULL;
2942          char* nm      = strtab + stab[j].st_name;
2943          int   secno   = stab[j].st_shndx;
2944
2945          /* Figure out if we want to add it; if so, set ad to its
2946             address.  Otherwise leave ad == NULL. */
2947
2948          if (secno == SHN_COMMON) {
2949             isLocal = FALSE;
2950             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
2951             /*
2952             debugBelch("COMMON symbol, size %d name %s\n",
2953                             stab[j].st_size, nm);
2954             */
2955             /* Pointless to do addProddableBlock() for this area,
2956                since the linker should never poke around in it. */
2957          }
2958          else
2959          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
2960                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
2961               )
2962               /* and not an undefined symbol */
2963               && stab[j].st_shndx != SHN_UNDEF
2964               /* and not in a "special section" */
2965               && stab[j].st_shndx < SHN_LORESERVE
2966               &&
2967               /* and it's a not a section or string table or anything silly */
2968               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
2969                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
2970                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
2971               )
2972             ) {
2973             /* Section 0 is the undefined section, hence > and not >=. */
2974             ASSERT(secno > 0 && secno < ehdr->e_shnum);
2975             /*
2976             if (shdr[secno].sh_type == SHT_NOBITS) {
2977                debugBelch("   BSS symbol, size %d off %d name %s\n",
2978                                stab[j].st_size, stab[j].st_value, nm);
2979             }
2980             */
2981             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
2982             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
2983                isLocal = TRUE;
2984             } else {
2985 #ifdef ELF_FUNCTION_DESC
2986                /* dlsym() and the initialisation table both give us function
2987                 * descriptors, so to be consistent we store function descriptors
2988                 * in the symbol table */
2989                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
2990                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
2991 #endif
2992                IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p  %s %s",
2993                                       ad, oc->fileName, nm ));
2994                isLocal = FALSE;
2995             }
2996          }
2997
2998          /* And the decision is ... */
2999
3000          if (ad != NULL) {
3001             ASSERT(nm != NULL);
3002             oc->symbols[j] = nm;
3003             /* Acquire! */
3004             if (isLocal) {
3005                /* Ignore entirely. */
3006             } else {
3007                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
3008             }
3009          } else {
3010             /* Skip. */
3011             IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
3012                                    strtab + stab[j].st_name ));
3013             /*
3014             debugBelch(
3015                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
3016                     (int)ELF_ST_BIND(stab[j].st_info),
3017                     (int)ELF_ST_TYPE(stab[j].st_info),
3018                     (int)stab[j].st_shndx,
3019                     strtab + stab[j].st_name
3020                    );
3021             */
3022             oc->symbols[j] = NULL;
3023          }
3024
3025       }
3026    }
3027
3028    return 1;
3029 }
3030
3031 /* Do ELF relocations which lack an explicit addend.  All x86-linux
3032    relocations appear to be of this form. */
3033 static int
3034 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
3035                          Elf_Shdr* shdr, int shnum,
3036                          Elf_Sym*  stab, char* strtab )
3037 {
3038    int j;
3039    char *symbol;
3040    Elf_Word* targ;
3041    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
3042    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
3043    int target_shndx = shdr[shnum].sh_info;
3044    int symtab_shndx = shdr[shnum].sh_link;
3045
3046    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3047    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
3048    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3049                           target_shndx, symtab_shndx ));
3050
3051    /* Skip sections that we're not interested in. */
3052    {
3053        int is_bss;
3054        SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
3055        if (kind == SECTIONKIND_OTHER) {
3056            IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
3057            return 1;
3058        }
3059    }
3060
3061    for (j = 0; j < nent; j++) {
3062       Elf_Addr offset = rtab[j].r_offset;
3063       Elf_Addr info   = rtab[j].r_info;
3064
3065       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
3066       Elf_Word* pP = (Elf_Word*)P;
3067       Elf_Addr  A  = *pP;
3068       Elf_Addr  S;
3069       void*     S_tmp;
3070       Elf_Addr  value;
3071
3072       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
3073                              j, (void*)offset, (void*)info ));
3074       if (!info) {
3075          IF_DEBUG(linker,debugBelch( " ZERO" ));
3076          S = 0;
3077       } else {
3078          Elf_Sym sym = stab[ELF_R_SYM(info)];
3079          /* First see if it is a local symbol. */
3080          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3081             /* Yes, so we can get the address directly from the ELF symbol
3082                table. */
3083             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3084             S = (Elf_Addr)
3085                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3086                        + stab[ELF_R_SYM(info)].st_value);
3087
3088          } else {
3089             /* No, so look up the name in our global table. */
3090             symbol = strtab + sym.st_name;
3091             S_tmp = lookupSymbol( symbol );
3092             S = (Elf_Addr)S_tmp;
3093          }
3094          if (!S) {
3095             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3096             return 0;
3097          }
3098          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n", symbol, (void*)S ));
3099       }
3100
3101       IF_DEBUG(linker,debugBelch( "Reloc: P = %p   S = %p   A = %p\n",
3102                              (void*)P, (void*)S, (void*)A ));
3103       checkProddableBlock ( oc, pP );
3104
3105       value = S + A;
3106
3107       switch (ELF_R_TYPE(info)) {
3108 #        ifdef i386_HOST_ARCH
3109          case R_386_32:   *pP = value;     break;
3110          case R_386_PC32: *pP = value - P; break;
3111 #        endif
3112          default:
3113             errorBelch("%s: unhandled ELF relocation(Rel) type %ld\n",
3114                   oc->fileName, ELF_R_TYPE(info));
3115             return 0;
3116       }
3117
3118    }
3119    return 1;
3120 }
3121
3122 /* Do ELF relocations for which explicit addends are supplied.
3123    sparc-solaris relocations appear to be of this form. */
3124 static int
3125 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
3126                           Elf_Shdr* shdr, int shnum,
3127                           Elf_Sym*  stab, char* strtab )
3128 {
3129    int j;
3130    char *symbol = NULL;
3131    Elf_Addr targ;
3132    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
3133    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
3134    int target_shndx = shdr[shnum].sh_info;
3135    int symtab_shndx = shdr[shnum].sh_link;
3136
3137    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3138    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
3139    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3140                           target_shndx, symtab_shndx ));
3141
3142    for (j = 0; j < nent; j++) {
3143 #if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3144       /* This #ifdef only serves to avoid unused-var warnings. */
3145       Elf_Addr  offset = rtab[j].r_offset;
3146       Elf_Addr  P      = targ + offset;
3147 #endif
3148       Elf_Addr  info   = rtab[j].r_info;
3149       Elf_Addr  A      = rtab[j].r_addend;
3150       Elf_Addr  S;
3151       void*     S_tmp;
3152       Elf_Addr  value;
3153 #     if defined(sparc_HOST_ARCH)
3154       Elf_Word* pP = (Elf_Word*)P;
3155       Elf_Word  w1, w2;
3156 #     elif defined(ia64_HOST_ARCH)
3157       Elf64_Xword *pP = (Elf64_Xword *)P;
3158       Elf_Addr addr;
3159 #     elif defined(powerpc_HOST_ARCH)
3160       Elf_Sword delta;
3161 #     endif
3162
3163       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p %6p)   ",
3164                              j, (void*)offset, (void*)info,
3165                                 (void*)A ));
3166       if (!info) {
3167          IF_DEBUG(linker,debugBelch( " ZERO" ));
3168          S = 0;
3169       } else {
3170          Elf_Sym sym = stab[ELF_R_SYM(info)];
3171          /* First see if it is a local symbol. */
3172          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3173             /* Yes, so we can get the address directly from the ELF symbol
3174                table. */
3175             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3176             S = (Elf_Addr)
3177                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3178                        + stab[ELF_R_SYM(info)].st_value);
3179 #ifdef ELF_FUNCTION_DESC
3180             /* Make a function descriptor for this function */
3181             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
3182                S = allocateFunctionDesc(S + A);
3183                A = 0;
3184             }
3185 #endif
3186          } else {
3187             /* No, so look up the name in our global table. */
3188             symbol = strtab + sym.st_name;
3189             S_tmp = lookupSymbol( symbol );
3190             S = (Elf_Addr)S_tmp;
3191
3192 #ifdef ELF_FUNCTION_DESC
3193             /* If a function, already a function descriptor - we would
3194                have to copy it to add an offset. */
3195             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
3196                errorBelch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
3197 #endif
3198          }
3199          if (!S) {
3200            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3201            return 0;
3202          }
3203          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p", symbol, (void*)S ));
3204       }
3205
3206       IF_DEBUG(linker,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
3207                                         (void*)P, (void*)S, (void*)A ));
3208       /* checkProddableBlock ( oc, (void*)P ); */
3209
3210       value = S + A;
3211
3212       switch (ELF_R_TYPE(info)) {
3213 #        if defined(sparc_HOST_ARCH)
3214          case R_SPARC_WDISP30:
3215             w1 = *pP & 0xC0000000;
3216             w2 = (Elf_Word)((value - P) >> 2);
3217             ASSERT((w2 & 0xC0000000) == 0);
3218             w1 |= w2;
3219             *pP = w1;
3220             break;
3221          case R_SPARC_HI22:
3222             w1 = *pP & 0xFFC00000;
3223             w2 = (Elf_Word)(value >> 10);
3224             ASSERT((w2 & 0xFFC00000) == 0);
3225             w1 |= w2;
3226             *pP = w1;
3227             break;
3228          case R_SPARC_LO10:
3229             w1 = *pP & ~0x3FF;
3230             w2 = (Elf_Word)(value & 0x3FF);
3231             ASSERT((w2 & ~0x3FF) == 0);
3232             w1 |= w2;
3233             *pP = w1;
3234             break;
3235          /* According to the Sun documentation:
3236             R_SPARC_UA32
3237             This relocation type resembles R_SPARC_32, except it refers to an
3238             unaligned word. That is, the word to be relocated must be treated
3239             as four separate bytes with arbitrary alignment, not as a word
3240             aligned according to the architecture requirements.
3241
3242             (JRS: which means that freeloading on the R_SPARC_32 case
3243             is probably wrong, but hey ...)
3244          */
3245          case R_SPARC_UA32:
3246          case R_SPARC_32:
3247             w2 = (Elf_Word)value;
3248             *pP = w2;
3249             break;
3250 #        elif defined(ia64_HOST_ARCH)
3251          case R_IA64_DIR64LSB:
3252          case R_IA64_FPTR64LSB:
3253             *pP = value;
3254             break;
3255          case R_IA64_PCREL64LSB:
3256             *pP = value - P;
3257             break;
3258          case R_IA64_SEGREL64LSB:
3259             addr = findElfSegment(ehdrC, value);
3260             *pP = value - addr;
3261             break;
3262          case R_IA64_GPREL22:
3263             ia64_reloc_gprel22(P, value);
3264             break;
3265          case R_IA64_LTOFF22:
3266          case R_IA64_LTOFF22X:
3267          case R_IA64_LTOFF_FPTR22:
3268             addr = allocateGOTEntry(value);
3269             ia64_reloc_gprel22(P, addr);
3270             break;
3271          case R_IA64_PCREL21B:
3272             ia64_reloc_pcrel21(P, S, oc);
3273             break;
3274          case R_IA64_LDXMOV:
3275             /* This goes with R_IA64_LTOFF22X and points to the load to
3276              * convert into a move.  We don't implement relaxation. */
3277             break;
3278 #        elif defined(powerpc_HOST_ARCH)
3279          case R_PPC_ADDR16_LO:
3280             *(Elf32_Half*) P = value;
3281             break;
3282
3283          case R_PPC_ADDR16_HI:
3284             *(Elf32_Half*) P = value >> 16;
3285             break;
3286
3287          case R_PPC_ADDR16_HA:
3288             *(Elf32_Half*) P = (value + 0x8000) >> 16;
3289             break;
3290
3291          case R_PPC_ADDR32:
3292             *(Elf32_Word *) P = value;
3293             break;
3294
3295          case R_PPC_REL32:
3296             *(Elf32_Word *) P = value - P;
3297             break;
3298
3299          case R_PPC_REL24:
3300             delta = value - P;
3301
3302             if( delta << 6 >> 6 != delta )
3303             {
3304                value = makeJumpIsland( oc, ELF_R_SYM(info), value );
3305                delta = value - P;
3306
3307                if( value == 0 || delta << 6 >> 6 != delta )
3308                {
3309                   barf( "Unable to make ppcJumpIsland for #%d",
3310                         ELF_R_SYM(info) );
3311                   return 0;
3312                }
3313             }
3314
3315             *(Elf_Word *) P = (*(Elf_Word *) P & 0xfc000003)
3316                                           | (delta & 0x3fffffc);
3317             break;
3318 #        endif
3319
3320 #if x86_64_HOST_ARCH
3321       case R_X86_64_64:
3322           *(Elf64_Xword *)P = value;
3323           break;
3324
3325       case R_X86_64_PC32:
3326       {
3327           StgInt64 off = value - P;
3328           if (off >= 0x7fffffffL || off < -0x80000000L) {
3329               barf("R_X86_64_PC32 relocation out of range: %s = %p",
3330                    symbol, off);
3331           }
3332           *(Elf64_Word *)P = (Elf64_Word)off;
3333           break;
3334       }
3335
3336       case R_X86_64_32:
3337           if (value >= 0x7fffffffL) {
3338               barf("R_X86_64_32 relocation out of range: %s = %p\n",
3339                    symbol, value);
3340           }
3341           *(Elf64_Word *)P = (Elf64_Word)value;
3342           break;
3343
3344       case R_X86_64_32S:
3345           if ((StgInt64)value > 0x7fffffffL || (StgInt64)value < -0x80000000L) {
3346               barf("R_X86_64_32S relocation out of range: %s = %p\n",
3347                    symbol, value);
3348           }
3349           *(Elf64_Sword *)P = (Elf64_Sword)value;
3350           break;
3351 #endif
3352
3353          default:
3354             errorBelch("%s: unhandled ELF relocation(RelA) type %ld\n",
3355                   oc->fileName, ELF_R_TYPE(info));
3356             return 0;
3357       }
3358
3359    }
3360    return 1;
3361 }
3362
3363 static int
3364 ocResolve_ELF ( ObjectCode* oc )
3365 {
3366    char *strtab;
3367    int   shnum, ok;
3368    Elf_Sym*  stab  = NULL;
3369    char*     ehdrC = (char*)(oc->image);
3370    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
3371    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3372
3373    /* first find "the" symbol table */
3374    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
3375
3376    /* also go find the string table */
3377    strtab = findElfSection ( ehdrC, SHT_STRTAB );
3378
3379    if (stab == NULL || strtab == NULL) {
3380       errorBelch("%s: can't find string or symbol table", oc->fileName);
3381       return 0;
3382    }
3383
3384    /* Process the relocation sections. */
3385    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
3386       if (shdr[shnum].sh_type == SHT_REL) {
3387          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
3388                                        shnum, stab, strtab );
3389          if (!ok) return ok;
3390       }
3391       else
3392       if (shdr[shnum].sh_type == SHT_RELA) {
3393          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
3394                                         shnum, stab, strtab );
3395          if (!ok) return ok;
3396       }
3397    }
3398
3399    /* Free the local symbol table; we won't need it again. */
3400    freeHashTable(oc->lochash, NULL);
3401    oc->lochash = NULL;
3402
3403 #if defined(powerpc_HOST_ARCH)
3404    ocFlushInstructionCache( oc );
3405 #endif
3406
3407    return 1;
3408 }
3409
3410 /*
3411  * IA64 specifics
3412  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
3413  * at the front.  The following utility functions pack and unpack instructions, and
3414  * take care of the most common relocations.
3415  */
3416
3417 #ifdef ia64_HOST_ARCH
3418
3419 static Elf64_Xword
3420 ia64_extract_instruction(Elf64_Xword *target)
3421 {
3422    Elf64_Xword w1, w2;
3423    int slot = (Elf_Addr)target & 3;
3424    target = (Elf_Addr)target & ~3;
3425
3426    w1 = *target;
3427    w2 = *(target+1);
3428
3429    switch (slot)
3430    {
3431       case 0:
3432          return ((w1 >> 5) & 0x1ffffffffff);
3433       case 1:
3434          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
3435       case 2:
3436          return (w2 >> 23);
3437       default:
3438          barf("ia64_extract_instruction: invalid slot %p", target);
3439    }
3440 }
3441
3442 static void
3443 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
3444 {
3445    int slot = (Elf_Addr)target & 3;
3446    target = (Elf_Addr)target & ~3;
3447
3448    switch (slot)
3449    {
3450       case 0:
3451          *target |= value << 5;
3452          break;
3453       case 1:
3454          *target |= value << 46;
3455          *(target+1) |= value >> 18;
3456          break;
3457       case 2:
3458          *(target+1) |= value << 23;
3459          break;
3460    }
3461 }
3462
3463 static void
3464 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
3465 {
3466    Elf64_Xword instruction;
3467    Elf64_Sxword rel_value;
3468
3469    rel_value = value - gp_val;
3470    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
3471       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
3472
3473    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3474    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
3475                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
3476                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
3477                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3478    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3479 }
3480
3481 static void
3482 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
3483 {
3484    Elf64_Xword instruction;
3485    Elf64_Sxword rel_value;
3486    Elf_Addr entry;
3487
3488    entry = allocatePLTEntry(value, oc);
3489
3490    rel_value = (entry >> 4) - (target >> 4);
3491    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
3492       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
3493
3494    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3495    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
3496                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3497    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3498 }
3499
3500 #endif /* ia64 */
3501
3502 /*
3503  * PowerPC ELF specifics
3504  */
3505
3506 #ifdef powerpc_HOST_ARCH
3507
3508 static int ocAllocateJumpIslands_ELF( ObjectCode *oc )
3509 {
3510   Elf_Ehdr *ehdr;
3511   Elf_Shdr* shdr;
3512   int i;
3513
3514   ehdr = (Elf_Ehdr *) oc->image;
3515   shdr = (Elf_Shdr *) ( ((char *)oc->image) + ehdr->e_shoff );
3516
3517   for( i = 0; i < ehdr->e_shnum; i++ )
3518     if( shdr[i].sh_type == SHT_SYMTAB )
3519       break;
3520
3521   if( i == ehdr->e_shnum )
3522   {
3523     errorBelch( "This ELF file contains no symtab" );
3524     return 0;
3525   }
3526
3527   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
3528   {
3529     errorBelch( "The entry size (%d) of the symtab isn't %d\n",
3530       shdr[i].sh_entsize, sizeof( Elf_Sym ) );
3531
3532     return 0;
3533   }
3534
3535   return ocAllocateJumpIslands( oc, shdr[i].sh_size / sizeof( Elf_Sym ), 0 );
3536 }
3537
3538 #endif /* powerpc */
3539
3540 #endif /* ELF */
3541
3542 /* --------------------------------------------------------------------------
3543  * Mach-O specifics
3544  * ------------------------------------------------------------------------*/
3545
3546 #if defined(OBJFORMAT_MACHO)
3547
3548 /*
3549   Support for MachO linking on Darwin/MacOS X
3550   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
3551
3552   I hereby formally apologize for the hackish nature of this code.
3553   Things that need to be done:
3554   *) implement ocVerifyImage_MachO
3555   *) add still more sanity checks.
3556 */
3557
3558 #ifdef powerpc_HOST_ARCH
3559 static int ocAllocateJumpIslands_MachO(ObjectCode* oc)
3560 {
3561     struct mach_header *header = (struct mach_header *) oc->image;
3562     struct load_command *lc = (struct load_command *) (header + 1);
3563     unsigned i;
3564
3565     for( i = 0; i < header->ncmds; i++ )
3566     {
3567         if( lc->cmd == LC_SYMTAB )
3568         {
3569                 // Find out the first and last undefined external
3570                 // symbol, so we don't have to allocate too many
3571                 // jump islands.
3572             struct symtab_command *symLC = (struct symtab_command *) lc;
3573             unsigned min = symLC->nsyms, max = 0;
3574             struct nlist *nlist =
3575                 symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
3576                       : NULL;
3577             for(i=0;i<symLC->nsyms;i++)
3578             {
3579                 if(nlist[i].n_type & N_STAB)
3580                     ;
3581                 else if(nlist[i].n_type & N_EXT)
3582                 {
3583                     if((nlist[i].n_type & N_TYPE) == N_UNDF
3584                         && (nlist[i].n_value == 0))
3585                     {
3586                         if(i < min)
3587                             min = i;
3588                         if(i > max)
3589                             max = i;
3590                     }
3591                 }
3592             }
3593             if(max >= min)
3594                 return ocAllocateJumpIslands(oc, max - min + 1, min);
3595
3596             break;
3597         }
3598
3599         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3600     }
3601     return ocAllocateJumpIslands(oc,0,0);
3602 }
3603 #endif
3604
3605 static int ocVerifyImage_MachO(ObjectCode* oc STG_UNUSED)
3606 {
3607     // FIXME: do some verifying here
3608     return 1;
3609 }
3610
3611 static int resolveImports(
3612     ObjectCode* oc,
3613     char *image,
3614     struct symtab_command *symLC,
3615     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
3616     unsigned long *indirectSyms,
3617     struct nlist *nlist)
3618 {
3619     unsigned i;
3620
3621     for(i=0;i*4<sect->size;i++)
3622     {
3623         // according to otool, reserved1 contains the first index into the indirect symbol table
3624         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
3625         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3626         void *addr = NULL;
3627
3628         if((symbol->n_type & N_TYPE) == N_UNDF
3629             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
3630             addr = (void*) (symbol->n_value);
3631         else if((addr = lookupLocalSymbol(oc,nm)) != NULL)
3632             ;
3633         else
3634             addr = lookupSymbol(nm);
3635         if(!addr)
3636         {
3637             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
3638             return 0;
3639         }
3640         ASSERT(addr);
3641         checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
3642         ((void**)(image + sect->offset))[i] = addr;
3643     }
3644
3645     return 1;
3646 }
3647
3648 static unsigned long relocateAddress(
3649     ObjectCode* oc,
3650     int nSections,
3651     struct section* sections,
3652     unsigned long address)
3653 {
3654     int i;
3655     for(i = 0; i < nSections; i++)
3656     {
3657         if(sections[i].addr <= address
3658             && address < sections[i].addr + sections[i].size)
3659         {
3660             return (unsigned long)oc->image
3661                     + sections[i].offset + address - sections[i].addr;
3662         }
3663     }
3664     barf("Invalid Mach-O file:"
3665          "Address out of bounds while relocating object file");
3666     return 0;
3667 }
3668
3669 static int relocateSection(
3670     ObjectCode* oc,
3671     char *image,
3672     struct symtab_command *symLC, struct nlist *nlist,
3673     int nSections, struct section* sections, struct section *sect)
3674 {
3675     struct relocation_info *relocs;
3676     int i,n;
3677
3678     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
3679         return 1;
3680     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
3681         return 1;
3682     else if(!strcmp(sect->sectname,"__la_sym_ptr2"))
3683         return 1;
3684     else if(!strcmp(sect->sectname,"__la_sym_ptr3"))
3685         return 1;
3686
3687     n = sect->nreloc;
3688     relocs = (struct relocation_info*) (image + sect->reloff);
3689
3690     for(i=0;i<n;i++)
3691     {
3692         if(relocs[i].r_address & R_SCATTERED)
3693         {
3694             struct scattered_relocation_info *scat =
3695                 (struct scattered_relocation_info*) &relocs[i];
3696
3697             if(!scat->r_pcrel)
3698             {
3699                 if(scat->r_length == 2)
3700                 {
3701                     unsigned long word = 0;
3702                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
3703                     checkProddableBlock(oc,wordPtr);
3704
3705                     // Note on relocation types:
3706                     // i386 uses the GENERIC_RELOC_* types,
3707                     // while ppc uses special PPC_RELOC_* types.
3708                     // *_RELOC_VANILLA and *_RELOC_PAIR have the same value
3709                     // in both cases, all others are different.
3710                     // Therefore, we use GENERIC_RELOC_VANILLA
3711                     // and GENERIC_RELOC_PAIR instead of the PPC variants,
3712                     // and use #ifdefs for the other types.
3713
3714                     // Step 1: Figure out what the relocated value should be
3715                     if(scat->r_type == GENERIC_RELOC_VANILLA)
3716                     {
3717                         word = *wordPtr + (unsigned long) relocateAddress(
3718                                                                 oc,
3719                                                                 nSections,
3720                                                                 sections,
3721                                                                 scat->r_value)
3722                                         - scat->r_value;
3723                     }
3724 #ifdef powerpc_HOST_ARCH
3725                     else if(scat->r_type == PPC_RELOC_SECTDIFF
3726                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
3727                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
3728                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
3729 #else
3730                     else if(scat->r_type == GENERIC_RELOC_SECTDIFF)
3731 #endif
3732                     {
3733                         struct scattered_relocation_info *pair =
3734                                 (struct scattered_relocation_info*) &relocs[i+1];
3735
3736                         if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR)
3737                             barf("Invalid Mach-O file: "
3738                                  "RELOC_*_SECTDIFF not followed by RELOC_PAIR");
3739
3740                         word = (unsigned long)
3741                                (relocateAddress(oc, nSections, sections, scat->r_value)
3742                               - relocateAddress(oc, nSections, sections, pair->r_value));
3743                         i++;
3744                     }
3745 #ifdef powerpc_HOST_ARCH
3746                     else if(scat->r_type == PPC_RELOC_HI16
3747                          || scat->r_type == PPC_RELOC_LO16
3748                          || scat->r_type == PPC_RELOC_HA16
3749                          || scat->r_type == PPC_RELOC_LO14)
3750                     {   // these are generated by label+offset things
3751                         struct relocation_info *pair = &relocs[i+1];
3752                         if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
3753                             barf("Invalid Mach-O file: "
3754                                  "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
3755
3756                         if(scat->r_type == PPC_RELOC_LO16)
3757                         {
3758                             word = ((unsigned short*) wordPtr)[1];
3759                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3760                         }
3761                         else if(scat->r_type == PPC_RELOC_LO14)
3762                         {
3763                             barf("Unsupported Relocation: PPC_RELOC_LO14");
3764                             word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
3765                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3766                         }
3767                         else if(scat->r_type == PPC_RELOC_HI16)
3768                         {
3769                             word = ((unsigned short*) wordPtr)[1] << 16;
3770                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
3771                         }
3772                         else if(scat->r_type == PPC_RELOC_HA16)
3773                         {
3774                             word = ((unsigned short*) wordPtr)[1] << 16;
3775                             word += ((short)relocs[i+1].r_address & (short)0xFFFF);
3776                         }
3777
3778
3779                         word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
3780                                                 - scat->r_value;
3781
3782                         i++;
3783                     }
3784  #endif
3785                     else
3786                         continue;  // ignore the others
3787
3788 #ifdef powerpc_HOST_ARCH
3789                     if(scat->r_type == GENERIC_RELOC_VANILLA
3790                         || scat->r_type == PPC_RELOC_SECTDIFF)
3791 #else
3792                     if(scat->r_type == GENERIC_RELOC_VANILLA
3793                         || scat->r_type == GENERIC_RELOC_SECTDIFF)
3794 #endif
3795                     {
3796                         *wordPtr = word;
3797                     }
3798 #ifdef powerpc_HOST_ARCH
3799                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
3800                     {
3801                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3802                     }
3803                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
3804                     {
3805                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3806                     }
3807                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
3808                     {
3809                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3810                             + ((word & (1<<15)) ? 1 : 0);
3811                     }
3812 #endif
3813                 }
3814             }
3815
3816             continue; // FIXME: I hope it's OK to ignore all the others.
3817         }
3818         else
3819         {
3820             struct relocation_info *reloc = &relocs[i];
3821             if(reloc->r_pcrel && !reloc->r_extern)
3822                 continue;
3823
3824             if(reloc->r_length == 2)
3825             {
3826                 unsigned long word = 0;
3827 #ifdef powerpc_HOST_ARCH
3828                 unsigned long jumpIsland = 0;
3829                 long offsetToJumpIsland = 0xBADBAD42; // initialise to bad value
3830                                                       // to avoid warning and to catch
3831                                                       // bugs.
3832 #endif
3833
3834                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
3835                 checkProddableBlock(oc,wordPtr);
3836
3837                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3838                 {
3839                     word = *wordPtr;
3840                 }
3841 #ifdef powerpc_HOST_ARCH
3842                 else if(reloc->r_type == PPC_RELOC_LO16)
3843                 {
3844                     word = ((unsigned short*) wordPtr)[1];
3845                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3846                 }
3847                 else if(reloc->r_type == PPC_RELOC_HI16)
3848                 {
3849                     word = ((unsigned short*) wordPtr)[1] << 16;
3850                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
3851                 }
3852                 else if(reloc->r_type == PPC_RELOC_HA16)
3853                 {
3854                     word = ((unsigned short*) wordPtr)[1] << 16;
3855                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
3856                 }
3857                 else if(reloc->r_type == PPC_RELOC_BR24)
3858                 {
3859                     word = *wordPtr;
3860                     word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0);
3861                 }
3862 #endif
3863
3864                 if(!reloc->r_extern)
3865                 {
3866                     long delta =
3867                         sections[reloc->r_symbolnum-1].offset
3868                         - sections[reloc->r_symbolnum-1].addr
3869                         + ((long) image);
3870
3871                     word += delta;
3872                 }
3873                 else
3874                 {
3875                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
3876                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3877                     void *symbolAddress = lookupSymbol(nm);
3878                     if(!symbolAddress)
3879                     {
3880                         errorBelch("\nunknown symbol `%s'", nm);
3881                         return 0;
3882                     }
3883
3884                     if(reloc->r_pcrel)
3885                     {
3886 #ifdef powerpc_HOST_ARCH
3887                             // In the .o file, this should be a relative jump to NULL
3888                             // and we'll change it to a relative jump to the symbol
3889                         ASSERT(-word == reloc->r_address);
3890                         jumpIsland = makeJumpIsland(oc,reloc->r_symbolnum,(unsigned long) symbolAddress);
3891                         if(jumpIsland != 0)
3892                         {
3893                             offsetToJumpIsland = word + jumpIsland
3894                                 - (((long)image) + sect->offset - sect->addr);
3895                         }
3896 #endif
3897                         word += (unsigned long) symbolAddress
3898                                 - (((long)image) + sect->offset - sect->addr);
3899                     }
3900                     else
3901                     {
3902                         word += (unsigned long) symbolAddress;
3903                     }
3904                 }
3905
3906                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3907                 {
3908                     *wordPtr = word;
3909                     continue;
3910                 }
3911 #ifdef powerpc_HOST_ARCH
3912                 else if(reloc->r_type == PPC_RELOC_LO16)
3913                 {
3914                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3915                     i++; continue;
3916                 }
3917                 else if(reloc->r_type == PPC_RELOC_HI16)
3918                 {
3919                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3920                     i++; continue;
3921                 }
3922                 else if(reloc->r_type == PPC_RELOC_HA16)
3923                 {
3924                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3925                         + ((word & (1<<15)) ? 1 : 0);
3926                     i++; continue;
3927                 }
3928                 else if(reloc->r_type == PPC_RELOC_BR24)
3929                 {
3930                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3931                     {
3932                         // The branch offset is too large.
3933                         // Therefore, we try to use a jump island.
3934                         if(jumpIsland == 0)
3935                         {
3936                             barf("unconditional relative branch out of range: "
3937                                  "no jump island available");
3938                         }
3939
3940                         word = offsetToJumpIsland;
3941                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3942                             barf("unconditional relative branch out of range: "
3943                                  "jump island out of range");
3944                     }
3945                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
3946                     continue;
3947                 }
3948 #endif
3949             }
3950             barf("\nunknown relocation %d",reloc->r_type);
3951             return 0;
3952         }
3953     }
3954     return 1;
3955 }
3956
3957 static int ocGetNames_MachO(ObjectCode* oc)
3958 {
3959     char *image = (char*) oc->image;
3960     struct mach_header *header = (struct mach_header*) image;
3961     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3962     unsigned i,curSymbol = 0;
3963     struct segment_command *segLC = NULL;
3964     struct section *sections;
3965     struct symtab_command *symLC = NULL;
3966     struct nlist *nlist;
3967     unsigned long commonSize = 0;
3968     char    *commonStorage = NULL;
3969     unsigned long commonCounter;
3970
3971     for(i=0;i<header->ncmds;i++)
3972     {
3973         if(lc->cmd == LC_SEGMENT)
3974             segLC = (struct segment_command*) lc;
3975         else if(lc->cmd == LC_SYMTAB)
3976             symLC = (struct symtab_command*) lc;
3977         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3978     }
3979
3980     sections = (struct section*) (segLC+1);
3981     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
3982                   : NULL;
3983
3984     for(i=0;i<segLC->nsects;i++)
3985     {
3986         if(sections[i].size == 0)
3987             continue;
3988
3989         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
3990         {
3991             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
3992                                       "ocGetNames_MachO(common symbols)");
3993             sections[i].offset = zeroFillArea - image;
3994         }
3995
3996         if(!strcmp(sections[i].sectname,"__text"))
3997             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
3998                 (void*) (image + sections[i].offset),
3999                 (void*) (image + sections[i].offset + sections[i].size));
4000         else if(!strcmp(sections[i].sectname,"__const"))
4001             addSection(oc, SECTIONKIND_RWDATA,
4002                 (void*) (image + sections[i].offset),
4003                 (void*) (image + sections[i].offset + sections[i].size));
4004         else if(!strcmp(sections[i].sectname,"__data"))
4005             addSection(oc, SECTIONKIND_RWDATA,
4006                 (void*) (image + sections[i].offset),
4007                 (void*) (image + sections[i].offset + sections[i].size));
4008         else if(!strcmp(sections[i].sectname,"__bss")
4009                 || !strcmp(sections[i].sectname,"__common"))
4010             addSection(oc, SECTIONKIND_RWDATA,
4011                 (void*) (image + sections[i].offset),
4012                 (void*) (image + sections[i].offset + sections[i].size));
4013
4014         addProddableBlock(oc, (void*) (image + sections[i].offset),
4015                                         sections[i].size);
4016     }
4017
4018         // count external symbols defined here
4019     oc->n_symbols = 0;
4020     if(symLC)
4021     {
4022         for(i=0;i<symLC->nsyms;i++)
4023         {
4024             if(nlist[i].n_type & N_STAB)
4025                 ;
4026             else if(nlist[i].n_type & N_EXT)
4027             {
4028                 if((nlist[i].n_type & N_TYPE) == N_UNDF
4029                     && (nlist[i].n_value != 0))
4030                 {
4031                     commonSize += nlist[i].n_value;
4032                     oc->n_symbols++;
4033                 }
4034                 else if((nlist[i].n_type & N_TYPE) == N_SECT)
4035                     oc->n_symbols++;
4036             }
4037         }
4038     }
4039     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
4040                                    "ocGetNames_MachO(oc->symbols)");
4041
4042     if(symLC)
4043     {
4044         for(i=0;i<symLC->nsyms;i++)
4045         {
4046             if(nlist[i].n_type & N_STAB)
4047                 ;
4048             else if((nlist[i].n_type & N_TYPE) == N_SECT)
4049             {
4050                 if(nlist[i].n_type & N_EXT)
4051                 {
4052                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4053                     ghciInsertStrHashTable(oc->fileName, symhash, nm,
4054                                             image
4055                                             + sections[nlist[i].n_sect-1].offset
4056                                             - sections[nlist[i].n_sect-1].addr
4057                                             + nlist[i].n_value);
4058                     oc->symbols[curSymbol++] = nm;
4059                 }
4060                 else
4061                 {
4062                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4063                     ghciInsertStrHashTable(oc->fileName, oc->lochash, nm,
4064                                             image
4065                                             + sections[nlist[i].n_sect-1].offset
4066                                             - sections[nlist[i].n_sect-1].addr
4067                                             + nlist[i].n_value);
4068                 }
4069             }
4070         }
4071     }
4072
4073     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
4074     commonCounter = (unsigned long)commonStorage;
4075     if(symLC)
4076     {
4077         for(i=0;i<symLC->nsyms;i++)
4078         {
4079             if((nlist[i].n_type & N_TYPE) == N_UNDF
4080                     && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
4081             {
4082                 char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4083                 unsigned long sz = nlist[i].n_value;
4084
4085                 nlist[i].n_value = commonCounter;
4086
4087                 ghciInsertStrHashTable(oc->fileName, symhash, nm,
4088                                        (void*)commonCounter);
4089                 oc->symbols[curSymbol++] = nm;
4090
4091                 commonCounter += sz;
4092             }
4093         }
4094     }
4095     return 1;
4096 }
4097
4098 static int ocResolve_MachO(ObjectCode* oc)
4099 {
4100     char *image = (char*) oc->image;
4101     struct mach_header *header = (struct mach_header*) image;
4102     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4103     unsigned i;
4104     struct segment_command *segLC = NULL;
4105     struct section *sections, *la_ptrs = NULL, *nl_ptrs = NULL;
4106     struct symtab_command *symLC = NULL;
4107     struct dysymtab_command *dsymLC = NULL;
4108     struct nlist *nlist;
4109
4110     for(i=0;i<header->ncmds;i++)
4111     {
4112         if(lc->cmd == LC_SEGMENT)
4113             segLC = (struct segment_command*) lc;
4114         else if(lc->cmd == LC_SYMTAB)
4115             symLC = (struct symtab_command*) lc;
4116         else if(lc->cmd == LC_DYSYMTAB)
4117             dsymLC = (struct dysymtab_command*) lc;
4118         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4119     }
4120
4121     sections = (struct section*) (segLC+1);
4122     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4123                   : NULL;
4124
4125     for(i=0;i<segLC->nsects;i++)
4126     {
4127         if(!strcmp(sections[i].sectname,"__la_symbol_ptr"))
4128             la_ptrs = &sections[i];
4129         else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr"))
4130             nl_ptrs = &sections[i];
4131         else if(!strcmp(sections[i].sectname,"__la_sym_ptr2"))
4132             la_ptrs = &sections[i];
4133         else if(!strcmp(sections[i].sectname,"__la_sym_ptr3"))
4134             la_ptrs = &sections[i];
4135     }
4136
4137     if(dsymLC)
4138     {
4139         unsigned long *indirectSyms
4140             = (unsigned long*) (image + dsymLC->indirectsymoff);
4141
4142         if(la_ptrs)
4143             if(!resolveImports(oc,image,symLC,la_ptrs,indirectSyms,nlist))
4144                 return 0;
4145         if(nl_ptrs)
4146             if(!resolveImports(oc,image,symLC,nl_ptrs,indirectSyms,nlist))
4147                 return 0;
4148     }
4149
4150     for(i=0;i<segLC->nsects;i++)
4151     {
4152         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
4153             return 0;
4154     }
4155
4156     /* Free the local symbol table; we won't need it again. */
4157     freeHashTable(oc->lochash, NULL);
4158     oc->lochash = NULL;
4159
4160 #if defined (powerpc_HOST_ARCH)
4161     ocFlushInstructionCache( oc );
4162 #endif
4163
4164     return 1;
4165 }
4166
4167 #ifdef powerpc_HOST_ARCH
4168 /*
4169  * The Mach-O object format uses leading underscores. But not everywhere.
4170  * There is a small number of runtime support functions defined in
4171  * libcc_dynamic.a whose name does not have a leading underscore.
4172  * As a consequence, we can't get their address from C code.
4173  * We have to use inline assembler just to take the address of a function.
4174  * Yuck.
4175  */
4176
4177 static void machoInitSymbolsWithoutUnderscore()
4178 {
4179     extern void* symbolsWithoutUnderscore[];
4180     void **p = symbolsWithoutUnderscore;
4181     __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:");
4182
4183 #undef Sym
4184 #define Sym(x)  \
4185     __asm__ volatile(".long " # x);
4186
4187     RTS_MACHO_NOUNDERLINE_SYMBOLS
4188
4189     __asm__ volatile(".text");
4190
4191 #undef Sym
4192 #define Sym(x)  \
4193     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
4194
4195     RTS_MACHO_NOUNDERLINE_SYMBOLS
4196
4197 #undef Sym
4198 }
4199 #endif
4200
4201 /*
4202  * Figure out by how much to shift the entire Mach-O file in memory
4203  * when loading so that its single segment ends up 16-byte-aligned
4204  */
4205 static int machoGetMisalignment( FILE * f )
4206 {
4207     struct mach_header header;
4208     int misalignment;
4209
4210     fread(&header, sizeof(header), 1, f);
4211     rewind(f);
4212
4213     if(header.magic != MH_MAGIC)
4214         return 0;
4215
4216     misalignment = (header.sizeofcmds + sizeof(header))
4217                     & 0xF;
4218
4219     return misalignment ? (16 - misalignment) : 0;
4220 }
4221
4222 #endif