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