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