rts/Linker.c

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