rts/Linker.c

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