ghc/rts/Linker.c

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