rts/Linker.c

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