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