rts/Linker.c

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