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