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