rts/Linker.c

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