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