ghc/rts/Linker.c

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