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