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