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